{-# 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 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 = "spectral-renga" :> Get '[HTML] HomeView type NewDomainAPI = "spectral-renga" :> "new-subgraph" :> Get '[HTML] NoContent type DomainAPI = "spectral-renga" :> "g" :> Capture "domainName" DomainName :> Get '[HTML] DomainView type DomainReadAPI = "spectral-renga" :> "g" :> Capture "domainName" DomainName :> "read" :> QueryParam "verse" VerseSpec :> Get '[HTML] DomainReadView type DomainWriteAPI = "spectral-renga" :> "g" :> Capture "domainName" DomainName :> "write" :> QueryParam "src" LineIden :> QueryParam "dst" LineIden :> QueryParam "init" () :> Get '[HTML] DomainWriteView type DomainWriteSubmitAPI = "spectral-renga" :> "g" :> Capture "domainName" DomainName :> "write-submit" :> ReqBody '[FormUrlEncoded] WriteSubmitForm :> Post '[HTML] NoContent type DomainWalkAPI = "spectral-renga" :> "g" :> Capture "domainName" DomainName :> "walk" :> QueryParam "line" LineIden :> Get '[HTML] DomainWalkView type DomainClearAPI = "spectral-renga" :> "g" :> Capture "domainName" DomainName :> "clear" :> Post '[HTML] NoContent type DomainResetAPI = "spectral-renga" :> "g" :> Capture "domainName" DomainName :> "reset" :> Post '[HTML] NoContent type DomainDeleteAPI = "spectral-renga" :> "g" :> Capture "domainName" DomainName :> "delete" :> Post '[HTML] NoContent type API = HomeAPI :<|> NewDomainAPI :<|> DomainAPI :<|> DomainReadAPI :<|> DomainWriteAPI :<|> DomainWriteSubmitAPI :<|> DomainWalkAPI :<|> DomainClearAPI :<|> DomainResetAPI :<|> DomainDeleteAPI :<|> "spectral-renga" :> "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, 3) :: Handler Integer let srcLineIden = if r <= 2 then getLineIden <$> src else Nothing let dstLineIden = if r <= 1 || r == 3 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 p_ $ do strong_ [class_ "title"] "Spectral Renga" span_ " is a collaborative graph of poetry." p_ $ em_ $ do a_ [href_ (domainURI (DomainName "piazza"))] "Join the public piazza" span_ ", or " a_ [href_ newDomainURI] "create a private subgraph" span_ "." p_ $ small_ $ do a_ [href_ "https://cyfraeviolae.org/git/spectral-renga"] "source code" span_ $ toHtmlRaw (T.pack " · ") a_ [href_ "/"] "cyfraeviolae.org" span_ $ toHtmlRaw (T.pack " · ") a_ [href_ "https://www.nlsun.com"] "nlsun.com" 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 p_ $ 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." p_ $ 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_ "120", required_ "1"] 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_ $ input_ [type_ "submit", value_ "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 · ") 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 · ") 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_ "shortcut icon", type_ "image/x-icon", href_ "/spectral-renga/static/favicon.ico"] link_ [rel_ "stylesheet", type_ "text/css", href_ "/spectral-renga/static/style.css"] body_ $ div_ [class_ "container"] $ do div_ [class_ "row navbar"] $ sequence_ $ intersperse (span_ [class_ "sep"] (toHtmlRaw (T.pack " → "))) (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 7 (length sampleLines) numExtraArrowsInDefault :: Int numExtraArrowsInDefault = 7 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