summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/Lib.hs829
1 files changed, 829 insertions, 0 deletions
diff --git a/src/Lib.hs b/src/Lib.hs
new file mode 100644
index 0000000..a95112d
--- /dev/null
+++ b/src/Lib.hs
@@ -0,0 +1,829 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+module Lib
+ ( startApp
+ , app
+ , createDomain
+ , withTx
+ , makeDefaultGraphSpec
+ , DomainName(..)
+ ) where
+
+import Control.Exception (throw)
+import qualified Control.Exception as E
+import qualified Control.Exception.Safe as CES
+import Control.Monad
+import Control.Monad.IO.Class
+import Data.Bits
+import Data.Char
+import Data.List
+import qualified Data.Map.Strict as M
+import Data.Maybe
+import qualified Data.Set as S
+import Data.String.Conversions (cs)
+import qualified Data.Text as T
+import Database.SQLite.Simple
+import Database.SQLite.Simple.FromField
+import Database.SQLite.Simple.ToField
+import GHC.Generics
+import Lucid
+import Network.Wai.Handler.Warp
+import Numeric
+import Servant hiding ((:.))
+import Servant.HTML.Lucid
+import System.Random.Stateful
+import Web.FormUrlEncoded
+
+-- TODO
+-- nginx rate limiting
+-- deploy
+-- put on srht, link
+-- stats report exe?
+
+newtype DomainIden = DomainIden Integer deriving (FromField, FromHttpApiData, ToHttpApiData, ToField)
+newtype LineIden = LineIden Integer deriving (Eq, Ord, FromField, FromHttpApiData, ToHttpApiData, ToField, Generic, Num)
+newtype Color = Color T.Text deriving (FromField, ToHttpApiData, ToField)
+
+hexDigits :: T.Text
+hexDigits = "0123456789abcdef"
+
+instance Uniform Color where
+ uniformM g = do
+ indices <- replicateM 6 (uniformRM (0, 15) g)
+ return $ Color $ T.pack $ fmap (T.index hexDigits) indices
+
+sampleColor :: StatefulGen g m => g -> m Color
+sampleColor g = iterateUntil (not . isLight) (uniformM g) -- unbounded loop OK in expectation
+ where iterateUntil f m = m >>= (\x -> if f x then return x else iterateUntil f m)
+
+instance FromHttpApiData Color where
+ parseUrlPiece "" = Left "color is empty"
+ parseUrlPiece s
+ | 6 /= T.length t = Left "color not 6 characters"
+ | not $ T.all isHexDigit t = Left "color not hex"
+ | otherwise = Right (Color t)
+ where t = T.drop 1 s
+
+newtype LineText = LineText T.Text deriving (FromField, ToHtml, ToHttpApiData, ToField)
+instance FromHttpApiData LineText where
+ parseUrlPiece s
+ | T.length s < 1 = Left "line text empty"
+ | T.length s > 120 = Left "line text over 120 characters"
+ | not $ T.all isPrint s = Left "line text not printable"
+ | otherwise = Right $ LineText s
+
+newtype DomainName = DomainName T.Text deriving (Eq, FromField, ToHttpApiData, ToHtml, ToField)
+instance FromHttpApiData DomainName where
+ parseUrlPiece s
+ | T.length s < 1 = Left "subgraph name empty"
+ | T.length s > 120 = Left "subgraph name over 120 characters"
+ | not $ T.all isAscii s = Left "subgraph name not ASCII"
+ | not $ T.all (\c -> isAlphaNum c || T.isInfixOf (T.singleton c) "-_.") s =
+ Left "subgraph name not in [A-Za-z0-9] or -, _, ."
+ | otherwise = Right (DomainName s)
+
+data DomainNamePart
+ = Oxbow | Limber | Steadfast | Regicide | Swarm | Weave | Bough | Canopy | Herald | Scorn |
+ Alder | Aerial | Welkin | Acrid | Kindling | Rapture | Myrtle | Envy | Solstice |
+ Juniper | Cleaving | Stream | Reaper | Sluice | Conduit | Disdain | Sylvan | Ravish | Atrium |
+ Thresh | Harvest | Water | Renewal | Rosy | Frieze | Portal | Vespers | Litany | Serpent |
+ Primate | Incite | Canon | Acquiese | Mirror | Script | Seal | Privy |
+ Piercing | Heresy | Subduct | Sceptre | Arrogance | Ivory | Accrete | Cluster |
+ Sepulchre | Summon | Pleading | Myriad | Exalted | Sentry | Shriven | River | Threshold
+ deriving (Enum, Show, Bounded)
+
+randomDomainName :: StatefulGen g m => g -> m DomainName
+randomDomainName g = do
+ parts <- replicateM 8 (randomPart g)
+ return $ DomainName $ T.intercalate "-" (fmap (T.pack . show) parts)
+ where
+ randomPart :: StatefulGen g m => g -> m DomainNamePart
+ randomPart g' = uniformRM (0, length [(minBound :: DomainNamePart)..maxBound] - 1) g' >>= (return . toEnum)
+
+data Line = Line LineIden Color LineText
+instance FromRow Line where
+ fromRow = Line <$> field <*> field <*> field
+data DomainedLine = DomainedLine DomainName Line
+data Domain = Domain DomainIden DomainName
+data DomainInfo = DomainInfo { numNodes :: Integer, numEdges :: Integer }
+
+-- a Verse is a list of lines that form a path in the graph
+newtype Verse = Verse [Line]
+newtype VerseSpec = VerseSpec [LineIden]
+instance ToHttpApiData VerseSpec where
+ toUrlPiece (VerseSpec lineIdens) = T.intercalate "-" $ fmap toUrlPiece lineIdens
+instance FromHttpApiData VerseSpec where
+ parseUrlPiece s = VerseSpec <$> mapM parseUrlPiece (T.splitOn "-" s)
+
+data WriteSubmitForm = WriteSubmitForm { src :: Maybe LineIden
+ , dst :: Maybe LineIden
+ , txt :: LineText
+ , color :: Color } deriving (Generic)
+instance FromForm WriteSubmitForm
+
+data HomeView = HomeView
+data DomainView = DomainView Domain DomainInfo Bool
+data DomainReadView = DomainReadView DomainName (Maybe Verse)
+data DomainWriteView = DomainWriteView DomainName (Maybe Line) (Maybe Line) Color
+data DomainWalkView = DomainWalkView DomainName (Maybe (Line, [Line], [Line]))
+
+type HomeAPI = Get '[HTML] HomeView
+type NewDomainAPI = "new-subgraph" :> Get '[HTML] NoContent
+type DomainAPI = "g" :> Capture "domainName" DomainName :> Get '[HTML] DomainView
+type DomainReadAPI = "g" :> Capture "domainName" DomainName :>
+ "read" :> QueryParam "verse" VerseSpec :> Get '[HTML] DomainReadView
+type DomainWriteAPI = "g" :> Capture "domainName" DomainName :>
+ "write" :> QueryParam "src" LineIden :> QueryParam "dst" LineIden :>
+ QueryParam "init" () :> Get '[HTML] DomainWriteView
+type DomainWriteSubmitAPI = "g" :> Capture "domainName" DomainName :>
+ "write-submit" :> ReqBody '[FormUrlEncoded] WriteSubmitForm :> Post '[HTML] NoContent
+type DomainWalkAPI = "g" :> Capture "domainName" DomainName :>
+ "walk" :> QueryParam "line" LineIden :> Get '[HTML] DomainWalkView
+type DomainClearAPI = "g" :> Capture "domainName" DomainName :> "clear" :> Post '[HTML] NoContent
+type DomainResetAPI = "g" :> Capture "domainName" DomainName :> "reset" :> Post '[HTML] NoContent
+type DomainDeleteAPI = "g" :> Capture "domainName" DomainName :> "delete" :> Post '[HTML] NoContent
+type API = HomeAPI
+ :<|> NewDomainAPI
+ :<|> DomainAPI
+ :<|> DomainReadAPI
+ :<|> DomainWriteAPI
+ :<|> DomainWriteSubmitAPI
+ :<|> DomainWalkAPI
+ :<|> DomainClearAPI
+ :<|> DomainResetAPI
+ :<|> DomainDeleteAPI
+ :<|> "static" :> Raw
+
+startApp :: IO ()
+startApp = run 8080 app
+
+app :: Application
+app = serve api $ hoistServer api handleErrors server
+
+handleErrors :: Handler a -> Handler a
+handleErrors f = CES.catches f [ CES.Handler (loggify handleAppException)
+ , CES.Handler (loggify handleDbException)
+ , CES.Handler (loggify handleArbitraryException)]
+
+api :: Proxy API
+api = Proxy
+
+server :: Server API
+server = handleHome
+ :<|> handleNewDomain
+ :<|> handleDomain
+ :<|> handleDomainRead
+ :<|> handleDomainWrite
+ :<|> handleDomainWriteSubmit
+ :<|> handleDomainWalk
+ :<|> handleDomainClear
+ :<|> handleDomainReset
+ :<|> handleDomainDelete
+ :<|> serveDirectoryWebApp "static/"
+
+redirectTo :: T.Text -> Handler a
+redirectTo uri = throwError err302 { errHeaders=[("Location", cs uri)] }
+
+------------------------------
+
+publicDomainName :: DomainName
+publicDomainName = DomainName "piazza"
+
+rejectOnPublicDomain :: DomainName -> IO ()
+rejectOnPublicDomain domainName = when (domainName == publicDomainName) $ throw IllegalOperation
+
+data AppException = IllegalOrphanException | DomainNameCreationFailure | VerseSpecTooLong | IllegalOperation deriving (Show)
+instance E.Exception AppException
+
+data DbException = NotFoundException | EmptyVerseException | BrokenVerseException deriving (Show)
+instance E.Exception DbException
+
+loggify :: E.Exception b => (b -> Handler a) -> b -> Handler a
+loggify f ex = do
+ liftIO $ print ex
+ f ex
+
+handleArbitraryException :: E.SomeException -> Handler a
+handleArbitraryException _ = throwError err500 {errBody="500: An unexpected error occurred."}
+
+handleAppException :: AppException -> Handler a
+handleAppException IllegalOrphanException =
+ throwError err400 {errBody="400: Cannot create an orphaned node in a nonempty subgraph."}
+handleAppException DomainNameCreationFailure =
+ throwError err500 {errBody="500: Failed to create subgraph name."}
+handleAppException VerseSpecTooLong =
+ throwError err400 {errBody="400: Verse specification is too long."}
+handleAppException IllegalOperation =
+ throwError err403 {errBody="403: You can't do that."}
+
+handleDbException :: DbException -> Handler a
+handleDbException NotFoundException =
+ throwError err404 {errBody="404: The requested resource could not be found."}
+handleDbException EmptyVerseException =
+ throwError err400 {errBody="400: Cannot display an empty verse."}
+handleDbException BrokenVerseException =
+ throwError err400 {errBody="400: The requested lines do not compose a path in the subgraph."}
+
+withDb :: (Connection -> IO a) -> IO a
+withDb = withConnection "spectralrenga.db"
+
+withTx :: (Connection -> IO a) -> IO a
+withTx f = withDb $ \conn -> withTransaction conn (f conn)
+
+handleHome :: Handler HomeView
+handleHome = return HomeView
+
+-- Thread g?
+oneNewDomain :: Connection -> IO (Maybe DomainName)
+oneNewDomain conn = do
+ g <- newStdGen >>= newIOGenM
+ domainName <- randomDomainName g
+ resolveDomainName conn domainName >>= \case
+ Nothing -> return (Just domainName)
+ Just _ -> return Nothing
+
+getDomainUntil :: Connection -> IO DomainName
+getDomainUntil conn = getDomainUntil' conn 16
+
+getDomainUntil' :: Connection -> Int -> IO DomainName
+getDomainUntil' _ 0 = throw DomainNameCreationFailure
+getDomainUntil' conn n =
+ oneNewDomain conn >>= \case
+ Just domain' -> return domain'
+ Nothing -> getDomainUntil' conn (n-1)
+
+handleNewDomain :: Handler NoContent
+handleNewDomain = do
+ newDomainName <- liftIO $ withDb getDomainUntil
+ redirectTo $ domainURI newDomainName
+
+handleDomain :: DomainName -> Handler DomainView
+handleDomain domainName = do
+ g <- liftIO $ newStdGen >>= newIOGenM
+ graphSpec <- liftIO $ makeDefaultGraphSpec g
+ (domain, domainInfo) <- liftIO $ dbFn domainName graphSpec
+ return (DomainView domain domainInfo (domainName /= publicDomainName))
+ where
+ dbFn domainName' graphSpec' = withDb $ \conn -> withTransaction conn $ do
+ domain <- resolveDomainName conn domainName' >>= \case
+ Nothing -> createDomain conn domainName' graphSpec'
+ Just domain -> return domain
+ domainInfo <- getDomainInfo conn domain
+ return (domain, domainInfo)
+
+maxReadLength :: Int
+maxReadLength = 16 -- verse could be potentially infinite due to loops, so take a prefix
+handleDomainRead :: DomainName -> Maybe VerseSpec -> Handler DomainReadView
+handleDomainRead domainName Nothing =
+ liftIO (dbFn domainName) >>= \case
+ Nothing -> return $ DomainReadView domainName Nothing
+ Just verse -> let lineIdens = fmap (\(Line lineIden _ _) -> lineIden) verse in
+ redirectTo $ domainReadURI domainName (Just (VerseSpec lineIdens))
+ where
+ dbFn domainName' = withTx $ \conn -> do
+ domain <- mustResolveDomainName conn domainName'
+ src <- randomLine conn domain
+ mapMaybeM src (collectUntil maxReadLength (getRandomSuccessor conn domain))
+handleDomainRead _ (Just (VerseSpec [])) = throwError err404 { errBody="Need some lines!" }
+handleDomainRead domainName (Just verseSpec@(VerseSpec lineIdens)) = do
+ liftIO $ when (length lineIdens > maxReadLength) $ throw VerseSpecTooLong
+ verse <- liftIO $ dbFn domainName
+ return $ DomainReadView domainName (Just verse)
+ where
+ dbFn domainName' = withTx $ \conn -> do
+ domain <- mustResolveDomainName conn domainName'
+ resolveVerseSpec conn domain verseSpec
+
+handleDomainWrite :: DomainName -> Maybe LineIden -> Maybe LineIden -> Maybe () -> Handler DomainWriteView
+handleDomainWrite domainName Nothing Nothing Nothing = do
+ (src, dst) <- liftIO $ dbFn domainName
+ r <- liftIO $ randomRIO (0, 2) :: Handler Integer
+ let srcLineIden = if r <= 1 then getLineIden <$> src else Nothing
+ let dstLineIden = if r >= 1 then getLineIden <$> dst else Nothing
+ let initFlag = if isNothing srcLineIden && isNothing dstLineIden then Just () else Nothing
+ redirectTo $ domainWriteURI domainName srcLineIden dstLineIden initFlag
+ where
+ getLineIden (Line lineIden _ _) = lineIden
+ dbFn domainName' = withTx $ \conn -> do
+ domain <- mustResolveDomainName conn domainName'
+ (,) <$> randomLine conn domain <*> randomLine conn domain
+handleDomainWrite domainName msrcLineIden mdstLineIden _ = do
+ (src, dst) <- liftIO $ dbFn domainName msrcLineIden mdstLineIden
+ color <- liftIO $ newStdGen >>= newIOGenM >>= sampleColor
+ return $ DomainWriteView domainName src dst color
+ where
+ dbFn domainName' msrcLineIden' mdstLineIden' = withTx $ \conn -> do
+ domain <- mustResolveDomainName conn domainName'
+ src <- mapMaybeM msrcLineIden' (getLineById conn domain)
+ dst <- mapMaybeM mdstLineIden' (getLineById conn domain)
+ return (src, dst)
+
+handleDomainWriteSubmit :: DomainName -> WriteSubmitForm -> Handler NoContent
+handleDomainWriteSubmit domainName form = do
+ (Line newLineIden _ _) <- liftIO $ dbFn domainName form
+ redirectTo $ domainWalkURI domainName (Just newLineIden)
+ where
+ dbFn domainName' WriteSubmitForm{src=srcLineIden, dst=dstLineIden, txt, color} = withTx $ \conn -> do
+ domain <- mustResolveDomainName conn domainName'
+ when (isNothing srcLineIden && isNothing dstLineIden) $ do
+ c <- numLinesInDomain conn domain
+ -- an orphaned node can only be inserted into an empty domain
+ when (c > 0) $ throw IllegalOrphanException
+ newLine <- addLine conn domain txt color
+ case srcLineIden of
+ Nothing -> return ()
+ Just srcLineIden' -> getLineById conn domain srcLineIden' >>= (\x -> addArrow conn domain x newLine)
+ case dstLineIden of
+ Nothing -> return ()
+ Just dstLineIden' -> getLineById conn domain dstLineIden' >>= addArrow conn domain newLine
+ return newLine
+
+handleDomainWalk :: DomainName -> Maybe LineIden -> Handler DomainWalkView
+handleDomainWalk domainName Nothing =
+ liftIO (dbFn domainName) >>= \case
+ Nothing -> return $ DomainWalkView domainName Nothing
+ Just (Line lineIden _ _) -> redirectTo $ domainWalkURI domainName (Just lineIden)
+ where
+ dbFn domainName' = withTx $ \conn -> do
+ domain <- mustResolveDomainName conn domainName'
+ randomLine conn domain
+handleDomainWalk domainName (Just lineIden) =
+ DomainWalkView domainName . Just <$> liftIO (dbFn domainName lineIden)
+ where
+ dbFn domainName' lineIden' = withTx $ \conn -> do
+ domain <- mustResolveDomainName conn domainName'
+ line <- getLineById conn domain lineIden'
+ prevs <- getPrevs conn domain line
+ nexts <- getNexts conn domain line
+ return (line, prevs, nexts)
+
+handleDomainClear :: DomainName -> Handler NoContent
+handleDomainClear domainName = managingHandler clearDomain (domainURI domainName) domainName
+
+handleDomainReset :: DomainName -> Handler NoContent
+handleDomainReset domainName = do
+ g <- liftIO $ newStdGen >>= newIOGenM
+ graphSpec <- liftIO $ makeDefaultGraphSpec g
+ managingHandler (\c d -> resetDomain c d graphSpec) (domainURI domainName) domainName
+
+handleDomainDelete :: DomainName -> Handler NoContent
+handleDomainDelete = managingHandler deleteDomain homeURI
+
+managingHandler :: (Connection -> Domain -> IO ()) -> T.Text -> DomainName -> Handler NoContent
+managingHandler f uri = \domainName -> do
+ liftIO $ rejectOnPublicDomain domainName
+ liftIO (dbFn domainName)
+ redirectTo uri
+ where
+ dbFn domainName' = withTx $ \conn -> do
+ domain <- mustResolveDomainName conn domainName'
+ f conn domain
+
+-------------------------
+
+resolveDomainName :: Connection -> DomainName -> IO (Maybe Domain)
+resolveDomainName conn domainName = do
+ ret <- headMay <$> query conn "SELECT iden \
+ \FROM domains \
+ \WHERE name=?" (Only domainName)
+ case ret of
+ Nothing -> return Nothing
+ Just (Only domainIden) -> return . Just $ Domain domainIden domainName
+
+mustResolveDomainName :: Connection -> DomainName -> IO Domain
+mustResolveDomainName conn domainName =
+ resolveDomainName conn domainName >>= \case
+ Nothing -> throw NotFoundException
+ Just domain -> return domain
+
+createDomain :: Connection -> DomainName -> GraphSpec -> IO Domain
+createDomain conn domainName graphSpec = do
+ execute conn "INSERT INTO domains (name) VALUES(?)" (Only domainName)
+ domainIden <- DomainIden . fromIntegral <$> lastInsertRowId conn
+ let domain = Domain domainIden domainName
+ insertGraphSpec conn domain graphSpec
+ return domain
+
+getDomainInfo :: Connection -> Domain -> IO DomainInfo
+getDomainInfo conn (Domain domainIden _) = do
+ (Only numNodes) <- query conn "SELECT COUNT(*) \
+ \FROM lines \
+ \WHERE domain_iden=?" (Only domainIden) >>= mustHead
+ (Only numEdges) <- query conn "SELECT COUNT(*) \
+ \FROM arrows \
+ \WHERE domain_iden=?" (Only domainIden) >>= mustHead
+ return $ DomainInfo { numNodes=numNodes, numEdges=numEdges }
+
+getLineById :: Connection -> Domain -> LineIden -> IO Line
+getLineById conn (Domain domainIden _) lineIden =
+ headMay <$> query conn "SELECT lines.iden, color, txt \
+ \FROM lines \
+ \WHERE domain_iden=? AND lines.iden=?" (domainIden, lineIden) >>= \case
+ Nothing -> throw NotFoundException
+ Just line -> return line
+
+siblingPairs :: [a] -> [(a, a)]
+siblingPairs [] = []
+siblingPairs [_] = []
+siblingPairs (x:y:rest) = (x, y):siblingPairs (y:rest)
+
+resolveVerseSpec :: Connection -> Domain -> VerseSpec -> IO Verse
+resolveVerseSpec _ _ (VerseSpec []) = throw EmptyVerseException
+resolveVerseSpec conn domain (VerseSpec [x]) = Verse . (: []) <$> getLineById conn domain x
+resolveVerseSpec conn (Domain domainIden _) (VerseSpec lineIdens) = do
+ let spairs = siblingPairs lineIdens
+ spairsFlat = concatMap (\(a, b) -> [a, b]) spairs
+ queryFragment = "(" <>
+ T.intercalate " OR " (replicate (length spairs) "(a.iden=? AND b.iden=?)") <>
+ ")"
+ rows <- query conn (Query $ "SELECT a.iden, a.color, a.txt, b.iden, b.color, b.txt \
+ \FROM lines a \
+ \INNER JOIN lines b USING(domain_iden) \
+ \INNER JOIN arrows USING(domain_iden) \
+ \WHERE arrows.src=a.iden AND arrows.dst=b.iden \
+ \AND domain_iden=? AND " <> queryFragment)
+ (toField domainIden : fmap toField spairsFlat)
+ let linePairs = fmap (\(x :. y) -> (x, y)) rows
+ lineIdenPairs = fmap (\(Line aIden _ _, Line bIden _ _) -> (aIden, bIden)) linePairs
+ m = M.fromList $ zip lineIdenPairs linePairs
+ case mapM (`M.lookup` m) spairs of
+ Just versePairs -> return . Verse $ fmap fst versePairs ++ [snd (last versePairs)]
+ Nothing -> throw BrokenVerseException
+
+randomLine :: Connection -> Domain -> IO (Maybe Line)
+randomLine conn (Domain domainIden _) = headMay <$>
+ query conn "SELECT lines.iden, color, txt \
+ \FROM lines \
+ \WHERE domain_iden=? \
+ \ORDER BY RANDOM() LIMIT 1" (Only domainIden)
+
+getRandomSuccessor :: Connection -> Domain -> Line -> IO (Maybe Line)
+getRandomSuccessor conn (Domain domainIden _) (Line lineIden _ _) = headMay <$>
+ query conn "SELECT lines.iden, color, txt FROM lines \
+ \INNER JOIN arrows USING (domain_iden) \
+ \WHERE domain_iden=? AND arrows.src=? AND lines.iden=arrows.dst \
+ \ORDER BY RANDOM() LIMIT 1" (domainIden, lineIden)
+
+numLinesInDomain :: Connection -> Domain -> IO Integer
+numLinesInDomain conn (Domain domainIden _) = do
+ (Only c) <- query conn "SELECT COUNT(*) FROM lines WHERE domain_iden=?" (Only domainIden) >>= mustHead
+ return c
+
+addLine :: Connection -> Domain -> LineText -> Color -> IO Line
+addLine conn (Domain domainIden _) txt color = do
+ execute conn "INSERT INTO lines (domain_iden, txt, color) VALUES(?, ?, ?)" (domainIden, txt, color)
+ newLineIden <- fromIntegral <$> lastInsertRowId conn
+ return $ Line newLineIden color txt
+
+addArrow :: Connection -> Domain -> Line -> Line -> IO ()
+addArrow conn (Domain domainIden _) (Line srcIden _ _) (Line dstIden _ _) =
+ execute conn "INSERT INTO arrows (domain_iden, src, dst) VALUES(?, ?, ?)" (domainIden, srcIden, dstIden)
+
+getPrevs :: Connection -> Domain -> Line -> IO [Line]
+getPrevs conn (Domain domainIden _) (Line lineIden _ _) = query conn
+ "SELECT lines.iden, color, txt FROM lines \
+ \INNER JOIN arrows USING (domain_iden) \
+ \WHERE domain_iden=? AND arrows.src=iden AND arrows.dst=?" (domainIden, lineIden)
+
+getNexts :: Connection -> Domain -> Line -> IO [Line]
+getNexts conn (Domain domainIden _) (Line lineIden _ _) = query conn
+ "SELECT lines.iden, color, txt FROM lines \
+ \INNER JOIN arrows USING (domain_iden) \
+ \WHERE domain_iden=? AND arrows.dst=iden AND arrows.src=?" (domainIden, lineIden)
+
+insertGraphSpec :: Connection -> Domain -> GraphSpec -> IO ()
+insertGraphSpec conn domain (GraphSpec lineSpecs arrowSpecs) = do
+ newLines <- mapM (uncurry (addLine conn domain)) lineSpecs
+ mapM_ (\(a, b) -> addArrow conn domain (newLines !! a) (newLines !! b)) arrowSpecs
+
+clearDomain :: Connection -> Domain -> IO ()
+clearDomain conn (Domain domainIden _) = do
+ execute conn "DELETE FROM lines WHERE domain_iden=?" (Only domainIden)
+ execute conn "DELETE FROM arrows WHERE domain_iden=?" (Only domainIden)
+
+resetDomain :: Connection -> Domain -> GraphSpec -> IO ()
+resetDomain conn domain graphSpec = do
+ clearDomain conn domain
+ insertGraphSpec conn domain graphSpec
+
+deleteDomain :: Connection -> Domain -> IO ()
+deleteDomain conn domain@(Domain domainIden _) = do
+ clearDomain conn domain
+ execute conn "DELETE FROM domains WHERE iden=?" (Only domainIden)
+
+-------------------------------
+
+homeURI :: T.Text
+homeURI = "/" <> toUrlPiece (safeLink api (Proxy :: Proxy HomeAPI) :: Link)
+
+newDomainURI :: T.Text
+newDomainURI = "/" <> toUrlPiece (safeLink api (Proxy :: Proxy NewDomainAPI) :: Link)
+
+domainURI :: DomainName -> T.Text
+domainURI domainName = "/" <> toUrlPiece (safeLink api (Proxy :: Proxy DomainAPI) domainName :: Link)
+
+domainReadURI :: DomainName -> Maybe VerseSpec -> T.Text
+domainReadURI domainName verseSpec = "/" <> toUrlPiece (safeLink api (Proxy :: Proxy DomainReadAPI) domainName verseSpec :: Link)
+
+domainWriteURI :: DomainName -> Maybe LineIden -> Maybe LineIden -> Maybe () -> T.Text
+domainWriteURI domainName src dst initFlag = "/" <> toUrlPiece (safeLink api (Proxy :: Proxy DomainWriteAPI) domainName src dst initFlag :: Link)
+
+domainWriteSubmitURI :: DomainName -> T.Text
+domainWriteSubmitURI domainName = "/" <> toUrlPiece (safeLink api (Proxy :: Proxy DomainWriteSubmitAPI) domainName :: Link)
+
+domainWalkURI :: DomainName -> Maybe LineIden -> T.Text
+domainWalkURI domainName lineIden = "/" <> toUrlPiece (safeLink api (Proxy :: Proxy DomainWalkAPI) domainName lineIden :: Link)
+
+domainClearURI :: DomainName -> T.Text
+domainClearURI domainName = "/" <> toUrlPiece (safeLink api (Proxy :: Proxy DomainClearAPI) domainName :: Link)
+
+domainResetURI :: DomainName -> T.Text
+domainResetURI domainName = "/" <> toUrlPiece (safeLink api (Proxy :: Proxy DomainResetAPI) domainName :: Link)
+
+domainDeleteURI :: DomainName -> T.Text
+domainDeleteURI domainName = "/" <> toUrlPiece (safeLink api (Proxy :: Proxy DomainDeleteAPI) domainName :: Link)
+
+-------------------------------
+
+instance ToHtml HomeView where
+ toHtml HomeView = pageTemplate
+ Nothing
+ []
+ homeBody
+ where
+ homeBody = div_ $ do
+ div_ $ do
+ strong_ [class_ "title"] "Spectral Renga"
+ span_ " is a collaborative graph of poetry."
+ div_ $ em_ $ do
+ a_ [href_ (domainURI (DomainName "piazza"))] "Join the public piazza"
+ span_ ", "
+ a_ [href_ newDomainURI] "create a private subgraph"
+ span_ ", or "
+ a_ [href_ "#"] "view the source code"
+ span_ "."
+ toHtmlRaw = toHtml
+
+instance ToHtml DomainView where
+ toHtml (DomainView (Domain _ domainName) DomainInfo {numNodes, numEdges} showControls) = pageTemplate
+ (Just domainName)
+ [domainCrumb domainName, domainActionsCrumb domainName None]
+ domainBody
+ where
+ domainBody = do
+ div_ [class_ "row"] $ do
+ div_ $ do
+ span_ (toHtmlRaw (T.pack "Welcome to "))
+ strong_ [class_ "domain-name"] (toHtml domainName)
+ span_ $ toHtml $ ". This subgraph contains " <> show numNodes <> " nodes and " <> show numEdges <> " edges."
+ div_ $ em_ $ do
+ a_ [href_ (domainReadURI domainName Nothing)] "Read a poem"
+ span_ ", "
+ a_ [href_ (domainWriteURI domainName Nothing Nothing Nothing)] "write a line"
+ span_ ", "
+ a_ [href_ (domainWalkURI domainName Nothing)] "walk the graph"
+ span_ "."
+ when showControls $ div_ [class_ "row manage-box"] $ do
+ form_ [action_ (domainClearURI domainName), method_ "post", class_ "manage-form"] $
+ button_ [type_ "submit", class_ "manage-btn"] "Clear"
+ form_ [action_ (domainResetURI domainName), method_ "post", class_ "manage-form"] $
+ button_ [type_ "submit", class_ "manage-btn"] "Reset"
+ form_ [action_ (domainDeleteURI domainName), method_ "post", class_ "manage-form"] $
+ button_ [type_ "submit", class_ "manage-btn"] "Delete"
+
+ toHtmlRaw = toHtml
+
+initialWritePrompt :: Monad m => DomainName -> HtmlT m ()
+initialWritePrompt domainName = p_ $ do
+ span_ "Nothing here yet. "
+ a_ [href_ (domainWriteURI domainName Nothing Nothing Nothing)] "Write a line"
+ span_ "."
+
+instance ToHtml DomainReadView where
+ toHtml (DomainReadView domainName verse) = pageTemplate
+ (Just domainName)
+ [domainCrumb domainName, domainActionsCrumb domainName Read]
+ (case verse of
+ Nothing -> initialWritePrompt domainName
+ Just (Verse lines') -> ul_ [class_ "verse"] $ mapM_ (li_ . toHtml . DomainedLine domainName) lines')
+ toHtmlRaw = toHtml
+
+instance ToHtml DomainWriteView where
+ toHtml (DomainWriteView domainName msrc mdst (Color color)) = pageTemplate
+ (Just domainName)
+ [domainCrumb domainName, domainActionsCrumb domainName Write]
+ (div_ [class_ "row"] $ form_ [action_ (domainWriteSubmitURI domainName), method_ "post"] $ do
+ case msrc of
+ Just src@(Line (LineIden lineIdenInt) _ _) -> div_ $ do
+ label_ [] "previous line: "
+ span_ $ toHtml (DomainedLine domainName src)
+ input_ [type_ "text", name_ "src", value_ (T.pack $ show lineIdenInt), hidden_ "1"]
+ Nothing -> div_ ""
+ div_ $ do
+ label_ [for_ "txt", class_ "focus"] "your line: "
+ input_ [type_ "text", name_ "txt", id_ "txt", value_ "", maxlength_ "100"]
+ div_ $ do
+ label_ [for_ "color", class_ "focus"] "your color: "
+ input_ [type_ "color", name_ "color", id_ "color", value_ ("#" <> color)]
+ case mdst of
+ Just dst@(Line (LineIden lineIdenInt) _ _) -> div_ $ do
+ input_ [type_ "text", name_ "dst", value_ (T.pack $ show lineIdenInt), hidden_ "1"]
+ label_ [] "next line: "
+ span_ $ toHtml (DomainedLine domainName dst)
+ Nothing -> div_ ""
+ div_ $
+ button_ [type_ "submit"] "Submit"
+ )
+ toHtmlRaw = toHtml
+
+instance ToHtml DomainWalkView where
+ toHtml (DomainWalkView domainName info) = pageTemplate
+ (Just domainName)
+ [domainCrumb domainName, domainActionsCrumb domainName Walk]
+ (case info of
+ Nothing -> initialWritePrompt domainName
+ Just (line@(Line lineIden _ _), prevs, nexts) -> div_ [class_ "row"] $ do
+ div_ [class_ "neighbors"] $ do
+ small_ $ do
+ em_ $ toHtmlRaw (T.pack "predecessors &middot; ")
+ em_ $ a_ [href_ (domainWriteURI domainName Nothing (Just lineIden) Nothing)] "write"
+ case prevs of
+ [] -> p_ "Nothing here yet."
+ _ -> ul_ [class_ "verse"] $ mapM_ (li_ . toHtml . DomainedLine domainName) prevs
+ div_ [class_ "neighbors"] $ do
+ small_ $ em_ "node"
+ p_ $ strong_ $ toHtml (DomainedLine domainName line)
+ div_ [class_ "neighbors"] $ do
+ small_ $ do
+ em_ $ toHtmlRaw (T.pack "successors &middot; ")
+ em_ $ a_ [href_ (domainWriteURI domainName (Just lineIden) Nothing Nothing)] "write"
+ case nexts of
+ [] -> p_ "Nothing here yet."
+ _ -> ul_ [class_ "verse"] $ mapM_ (li_ . toHtml . DomainedLine domainName) nexts)
+ toHtmlRaw = toHtml
+
+instance ToHtml DomainedLine where
+ toHtml (DomainedLine domainName (Line iden color@(Color colorStr) txt)) =
+ a_ [href_ (domainWalkURI domainName (Just iden)),
+ style_ ("color: #" <> colorStr),
+ class_ (if isLight color then "outline" else "")] (toHtml txt)
+ toHtmlRaw = toHtml
+
+domainCrumb :: Monad m => DomainName -> HtmlT m ()
+domainCrumb domainName = a_ [href_ (domainURI domainName), class_ "focus domain-name"] (toHtml domainName)
+
+data ActionMode = None | Read | Write | Walk deriving (Eq)
+domainActionsCrumb :: Monad m => DomainName -> ActionMode -> HtmlT m ()
+domainActionsCrumb domainName mode =
+ span_ [class_ "nonbreaking"] $ do
+ span_ "{ "
+ a_ [href_ (domainReadURI domainName Nothing), class_ readClass] "read"
+ span_ ", "
+ a_ [href_ (domainWriteURI domainName Nothing Nothing Nothing), class_ writeClass] "write"
+ span_ ", "
+ a_ [href_ (domainWalkURI domainName Nothing), class_ walkClass] "walk"
+ span_ " }"
+ where
+ readClass = if mode == Read then "focus" else ""
+ writeClass = if mode == Write then "focus" else ""
+ walkClass = if mode == Walk then "focus" else ""
+
+pageTemplate :: Monad m => Maybe DomainName -> [HtmlT m ()] -> HtmlT m () -> HtmlT m ()
+pageTemplate domainName crumbs body = doctypehtml_ $ do
+ head_ $ do
+ title_ $ toHtml $ "Spectral Renga" <> titleDomain
+ meta_ [charset_ "utf-8"]
+ meta_ [name_ "viewport", content_ "width=device-width, initial-scale=1.0"]
+ link_ [rel_ "stylesheet", type_ "text/css", href_ "/static/style.css"]
+ body_ $ div_ [class_ "container"] $ do
+ div_ [class_ "row navbar"] $
+ sequence_ $
+ intersperse (span_ [class_ "sep"] (toHtmlRaw (T.pack " &rarr; ")))
+ (a_ [href_ homeURI, class_ "title focus"] "Spectral Renga":crumbs)
+ body
+ where
+ titleDomain = case domainName of
+ Nothing -> ""
+ Just (DomainName domainNameStr) -> " - " <> domainNameStr
+
+--------------
+
+sampleLines :: [LineText]
+sampleLines = fmap LineText [
+ "A turmoil of wars-men, spread over the middle kingdom,"
+ , "And a head in the freakish Atlantic"
+ , "And drank coffee, and talked for an hour."
+ , "And he was always human when he talked;"
+ , "Babel of arcades and stairways,"
+ , "I then began seeking for some alternative. I felt"
+ , "I with the Nymphs will haunt Mount Maenalus,"
+ , "In a convex mirror, such as is used by barbers"
+ , "My mad singing startles the valleys and hills:"
+ , "Of tendrils, leaves, and rough nuts brown"
+ , "One Mite wrung from the Labrers hands"
+ , "One like a wombat prowl’d obtuse and furry,"
+ , "One warbling for the mere bright day’s delight,"
+ , "Parting track'd by arriving, perpetual payment of perpetual loan,"
+ , "Rolled round in earth's diurnal course,"
+ , "Scarce seem'd a vision; I would ne'er have striven"
+ , "Swimmer, your body is pure as the water;"
+ , "The all-beholding sun shall see no more"
+ , "The sea, whose sob created my gentle roll,"
+ , "The snows of the Tyrol, the clear beer of Vienna"
+ , "Thou mighty Poet, e'en to frenzy bold!"
+ , "Though wise men at their end know dark is right,"
+ , "Tonight I can write the saddest lines."
+ , "To resume their compulsory game:"
+ , "and the village is flooded"
+ , "i carry your heart with me(i carry it in"
+ , "in whom Death the gardener wove different veins."
+ , "which is the part of stories one never quite believes."
+ , "who burned cigarette holes in their arms protesting the narcotic tobacco haze of Capitalism,"
+ ]
+
+data GraphSpec = GraphSpec [(LineText, Color)] [(Int, Int)]
+
+makeConnectedGraph :: StatefulGen g m => g -> [LineText] -> m GraphSpec
+makeConnectedGraph _ [] = return $ GraphSpec [] []
+makeConnectedGraph g [lineText] = do
+ newColor <- sampleColor g
+ return $ GraphSpec [(lineText, newColor)] []
+makeConnectedGraph g (lineText:lineTexts) = do
+ GraphSpec lineSpecs arrowSpecs <- makeConnectedGraph g lineTexts
+ let newIdx = length lineSpecs
+ oldIdx <- uniformRM (0, newIdx - 1) g
+ newLineIsSource <- uniformM g
+ newColor <- sampleColor g
+ let newArrow = if newLineIsSource then (newIdx, oldIdx) else (oldIdx, newIdx)
+ return $ GraphSpec (lineSpecs ++ [(lineText, newColor)]) (arrowSpecs ++ [newArrow])
+
+reduceSparsity :: StatefulGen g m => g -> Int -> Int -> [(Int, Int)] -> m [(Int, Int)]
+reduceSparsity g n numNewEdges arrows = do
+ newArrows <- replicateM numNewEdges ((,) <$> uniformRM (0, n-1) g <*> uniformRM (0, n-1) g)
+ let filteredArrows = filter (uncurry (/=)) (arrows ++ newArrows) -- no trivial loops
+ return $ S.toList $ S.fromList filteredArrows -- no multiedges
+
+
+numNodesInDefault :: Int
+numNodesInDefault = min 16 (length sampleLines)
+
+numExtraArrowsInDefault :: Int
+numExtraArrowsInDefault = 10
+
+makeDefaultGraphSpec :: StatefulGen g m => g -> m GraphSpec
+makeDefaultGraphSpec g = do
+ cutAt <- uniformRM (0, length sampleLines - 1) g
+ let lineTexts = take numNodesInDefault $ drop cutAt sampleLines ++ take cutAt sampleLines
+ GraphSpec lineSpecs arrowSpecs <- makeConnectedGraph g lineTexts
+ newArrowSpecs <- reduceSparsity g (length lineSpecs) numExtraArrowsInDefault arrowSpecs
+ return $ GraphSpec lineSpecs newArrowSpecs
+
+--------------
+
+mapMaybeM :: Monad m => Maybe a -> (a -> m b) -> m (Maybe b)
+mapMaybeM m f = maybe (return Nothing) (fmap Just . f) m
+
+parseHex :: Color -> Integer
+parseHex (Color s) = case readHex (T.unpack s) of
+ [(n, _)] -> n
+ _ -> error "should not happen; color is well-formed"
+firstByte :: Integer -> Float
+firstByte n = fromIntegral $ (n .&. 0xff0000) `shiftR` 16
+secondByte :: Integer -> Float
+secondByte n = fromIntegral $ (n .&. 0x00ff00) `shiftR` 8
+thirdByte :: Integer -> Float
+thirdByte n = fromIntegral $ n .&. 0x0000ff
+brightness :: Integer -> Float
+brightness n = 1.17*firstByte n + 2.30*secondByte n + 0.45*thirdByte n
+isLight :: Color -> Bool
+isLight color = (brightness . parseHex) color >= 800
+
+collectUntil :: Int -> (a -> IO (Maybe a)) -> a -> IO [a]
+collectUntil 0 _ _ = return []
+collectUntil n f src =
+ f src >>= \case
+ Nothing -> return [src]
+ Just dst' -> (:) src <$> collectUntil (n-1) f dst'
+
+headMay :: [a] -> Maybe a
+headMay [] = Nothing
+headMay (x:_) = Just x
+
+data HeadException = HeadException deriving (Show)
+instance E.Exception HeadException
+
+mustHead :: [a] -> IO a
+mustHead [] = throw HeadException
+mustHead (x:_) = return x