summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorquidtum <quidtum>2020-11-30 20:23:16 -0500
committerquidtum <quidtum>2020-12-06 20:09:56 -0500
commit38b8e7047b944a8f6ed41bea6bda1e7e3fe00259 (patch)
tree1dcf9e39d206b7cc4e3e4fff562f36b18863c548
init
Diffstat
-rw-r--r--.gitignore2
-rw-r--r--LICENSE16
-rw-r--r--README.md3
-rw-r--r--Setup.hs2
-rw-r--r--app/Main.hs8
-rw-r--r--dbreset/Main.hs25
-rw-r--r--package.yaml75
-rw-r--r--spectralrenga.cabal124
-rw-r--r--src/Lib.hs829
-rw-r--r--stack.yaml80
-rw-r--r--stack.yaml.lock104
-rw-r--r--static/EBGaramond-Italic-VariableFont_wght.ttfbin0 -> 829752 bytes
-rw-r--r--static/EBGaramond-VariableFont_wght.ttfbin0 -> 897728 bytes
-rw-r--r--static/style.css119
-rw-r--r--test/Spec.hs8
15 files changed, 1395 insertions, 0 deletions
diff --git a/.gitignore b/.gitignore
new file mode 100644
index 0000000..9c6acc7
--- /dev/null
+++ b/.gitignore
@@ -0,0 +1,2 @@
+.stack-work
+*.db
diff --git a/LICENSE b/LICENSE
new file mode 100644
index 0000000..9a463b0
--- /dev/null
+++ b/LICENSE
@@ -0,0 +1,16 @@
+Spectral Renga
+Copyright (C) 2020 quidtum.org
+
+This program is free software: you can redistribute it and/or modify
+it under the terms of the GNU Affero General Public License as
+published by the Free Software Foundation, either version 3 of the
+License, or (at your option) any later version.
+
+This program is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU Affero General Public License for more details.
+
+You should have received a copy of the GNU Affero General Public License
+along with this program. If not, see <https://www.gnu.org/licenses/>.
+
diff --git a/README.md b/README.md
new file mode 100644
index 0000000..be93dbb
--- /dev/null
+++ b/README.md
@@ -0,0 +1,3 @@
+# spectralrenga
+
+A collaborative graph of poetry. Try a 2\*\*8\*\*3-coloring!
diff --git a/Setup.hs b/Setup.hs
new file mode 100644
index 0000000..9a994af
--- /dev/null
+++ b/Setup.hs
@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain
diff --git a/app/Main.hs b/app/Main.hs
new file mode 100644
index 0000000..ed69e33
--- /dev/null
+++ b/app/Main.hs
@@ -0,0 +1,8 @@
+module Main where
+
+import Lib
+
+main :: IO ()
+main = do
+ putStrLn "Starting..."
+ startApp
diff --git a/dbreset/Main.hs b/dbreset/Main.hs
new file mode 100644
index 0000000..83d8cb8
--- /dev/null
+++ b/dbreset/Main.hs
@@ -0,0 +1,25 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Main where
+
+import Lib
+import Database.SQLite.Simple
+import System.Random.Stateful
+
+main :: IO ()
+main = withTx $ \conn -> do
+ execute_ conn "DROP TABLE IF EXISTS domains;"
+ execute_ conn "DROP TABLE IF EXISTS lines;"
+ execute_ conn "DROP TABLE IF EXISTS arrows;"
+ execute_ conn "CREATE TABLE domains (iden INTEGER PRIMARY KEY, name TEXT, ctime UTCTIME DEFAULT (datetime('now')));"
+ execute_ conn "CREATE UNIQUE INDEX idx_domains_name ON domains(name);"
+ execute_ conn "CREATE TABLE lines (iden INTEGER PRIMARY KEY, domain_iden INTEGER, txt TEXT, ctime UTCTIME DEFAULT (datetime('now')), color TEXT, FOREIGN KEY(domain_iden) REFERENCES domains(iden));"
+ execute_ conn "CREATE INDEX idx_lines_domain_iden ON lines(domain_iden);"
+ execute_ conn "CREATE TABLE arrows (domain_iden INTEGER, src INTEGER, dst INTEGER, FOREIGN KEY(domain_iden) REFERENCES domains(iden), FOREIGN KEY(src) REFERENCES lines(iden), FOREIGN KEY(dst) REFERENCES lines(iden));"
+ execute_ conn "CREATE INDEX idx_arrows_domain_iden ON arrows(domain_iden);"
+ execute_ conn "CREATE INDEX idx_arrows_src ON arrows(src);"
+ execute_ conn "CREATE INDEX idx_arrows_dst ON arrows(dst);"
+ g <- newStdGen >>= newIOGenM
+ graphSpec <- makeDefaultGraphSpec g
+ Lib.createDomain conn (DomainName "piazza") graphSpec
+ return ()
diff --git a/package.yaml b/package.yaml
new file mode 100644
index 0000000..0d37757
--- /dev/null
+++ b/package.yaml
@@ -0,0 +1,75 @@
+name: spectralrenga
+version: 0.1.0.0
+github: "quidtum/spectralrenga"
+license: AGPL
+author: "quidtum"
+maintainer: "quidtum@quidtum.org"
+copyright: "2020 quidtum.org"
+
+extra-source-files:
+- README.md
+
+# Metadata used when publishing your package
+# synopsis: Short description of your package
+# category: Web
+
+# To avoid duplicated efforts in documentation and dealing with the
+# complications of embedding Haddock markup inside cabal files, it is
+# common to point users to the README.md file.
+description: Please see the README.
+
+dependencies:
+- base >= 4.7 && < 5
+- servant
+- servant-server
+- wai
+- warp
+- servant-lucid
+- lucid
+- string-conversions
+- sqlite-simple
+- text
+- http-api-data
+- random
+- containers
+- safe-exceptions
+
+library:
+ source-dirs: src
+ ghc-options:
+ - -Wall
+ - -fwarn-incomplete-uni-patterns
+
+executables:
+ spectralrenga-exe:
+ main: Main.hs
+ source-dirs: app
+ ghc-options:
+ - -threaded
+ - -rtsopts
+ - -with-rtsopts=-N
+ dependencies:
+ - base
+ - spectralrenga
+ dbreset-exe:
+ main: Main.hs
+ source-dirs: dbreset
+ ghc-options:
+ - -threaded
+ - -rtsopts
+ - -with-rtsopts=-N
+ dependencies:
+ - base
+ - spectralrenga
+
+tests:
+ spectralrenga-test:
+ main: Spec.hs
+ source-dirs: test
+ ghc-options:
+ - -threaded
+ - -rtsopts
+ - -with-rtsopts=-N
+ dependencies:
+ - base
+ - spectralrenga
diff --git a/spectralrenga.cabal b/spectralrenga.cabal
new file mode 100644
index 0000000..94097a0
--- /dev/null
+++ b/spectralrenga.cabal
@@ -0,0 +1,124 @@
+cabal-version: 1.12
+
+-- This file has been generated from package.yaml by hpack version 0.34.2.
+--
+-- see: https://github.com/sol/hpack
+
+name: spectralrenga
+version: 0.1.0.0
+description: Please see the README.
+homepage: https://github.com/quidtum/spectralrenga#readme
+bug-reports: https://github.com/quidtum/spectralrenga/issues
+author: quidtum
+maintainer: quidtum@quidtum.org
+copyright: 2020 quidtum.org
+license: AGPL
+license-file: LICENSE
+build-type: Simple
+extra-source-files:
+ README.md
+
+source-repository head
+ type: git
+ location: https://github.com/quidtum/spectralrenga
+
+library
+ exposed-modules:
+ Lib
+ other-modules:
+ Paths_spectralrenga
+ hs-source-dirs:
+ src
+ ghc-options: -Wall -fwarn-incomplete-uni-patterns
+ build-depends:
+ base >=4.7 && <5
+ , containers
+ , http-api-data
+ , lucid
+ , random
+ , safe-exceptions
+ , servant
+ , servant-lucid
+ , servant-server
+ , sqlite-simple
+ , string-conversions
+ , text
+ , wai
+ , warp
+ default-language: Haskell2010
+
+executable dbreset-exe
+ main-is: Main.hs
+ other-modules:
+ Paths_spectralrenga
+ hs-source-dirs:
+ dbreset
+ ghc-options: -threaded -rtsopts -with-rtsopts=-N
+ build-depends:
+ base
+ , containers
+ , http-api-data
+ , lucid
+ , random
+ , safe-exceptions
+ , servant
+ , servant-lucid
+ , servant-server
+ , spectralrenga
+ , sqlite-simple
+ , string-conversions
+ , text
+ , wai
+ , warp
+ default-language: Haskell2010
+
+executable spectralrenga-exe
+ main-is: Main.hs
+ other-modules:
+ Paths_spectralrenga
+ hs-source-dirs:
+ app
+ ghc-options: -threaded -rtsopts -with-rtsopts=-N
+ build-depends:
+ base
+ , containers
+ , http-api-data
+ , lucid
+ , random
+ , safe-exceptions
+ , servant
+ , servant-lucid
+ , servant-server
+ , spectralrenga
+ , sqlite-simple
+ , string-conversions
+ , text
+ , wai
+ , warp
+ default-language: Haskell2010
+
+test-suite spectralrenga-test
+ type: exitcode-stdio-1.0
+ main-is: Spec.hs
+ other-modules:
+ Paths_spectralrenga
+ hs-source-dirs:
+ test
+ ghc-options: -threaded -rtsopts -with-rtsopts=-N
+ build-depends:
+ base
+ , containers
+ , http-api-data
+ , lucid
+ , random
+ , safe-exceptions
+ , servant
+ , servant-lucid
+ , servant-server
+ , spectralrenga
+ , sqlite-simple
+ , string-conversions
+ , text
+ , wai
+ , warp
+ default-language: Haskell2010
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
diff --git a/stack.yaml b/stack.yaml
new file mode 100644
index 0000000..20647a8
--- /dev/null
+++ b/stack.yaml
@@ -0,0 +1,80 @@
+# This file was automatically generated by 'stack init'
+#
+# Some commonly used options have been documented as comments in this file.
+# For advanced use and comprehensive documentation of the format, please see:
+# https://docs.haskellstack.org/en/stable/yaml_configuration/
+
+# Resolver to choose a 'specific' stackage snapshot or a compiler version.
+# A snapshot resolver dictates the compiler version and the set of packages
+# to be used for project dependencies. For example:
+#
+# resolver: lts-3.5
+# resolver: nightly-2015-09-21
+# resolver: ghc-7.10.2
+#
+# The location of a snapshot can be provided as a file or url. Stack assumes
+# a snapshot provided as a file might change, whereas a url resource does not.
+#
+# resolver: ./custom-snapshot.yaml
+# resolver: https://example.com/snapshots/2018-01-01.yaml
+resolver:
+ url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/16/23.yaml
+
+# User packages to be built.
+# Various formats can be used as shown in the example below.
+#
+# packages:
+# - some-directory
+# - https://example.com/foo/bar/baz-0.0.2.tar.gz
+# subdirs:
+# - auto-update
+# - wai
+packages:
+- .
+# Dependency packages to be pulled from upstream that are not in the resolver.
+# These entries can reference officially published versions as well as
+# forks / in-progress versions pinned to a git hash. For example:
+#
+# extra-deps:
+# - acme-missiles-0.3
+# - git: https://github.com/commercialhaskell/stack.git
+# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a
+#
+extra-deps:
+ - sqlite-simple-0.4.18.0@sha256:3ceea56375c0a3590c814e411a4eb86943f8d31b93b110ca159c90689b6b39e5,3002
+ - direct-sqlite-2.3.26@sha256:04e835402f1508abca383182023e4e2b9b86297b8533afbd4e57d1a5652e0c23,3718
+ - random-1.2.0@sha256:1e8140229d21489228aa79b820c23259f3c3a1b86e13e6f9c2ad0c48d86d1912,6094
+ - splitmix-0.1.0.3
+ - QuickCheck-2.14.2
+ - servant-0.18.2
+ - servant-lucid-0.9.0.2
+ - servant-server-0.18.2
+ - hlint-2.2.11@sha256:f4eef0d718264824254bf375a85a91a8756b20c4f7d2a4854ffe4e69e8bd1679,4069
+ - stylish-haskell-0.9.4.4@sha256:ea514922e47ea05a924355a841abd26d18101037c46fbb90e201ae83582a8728,4953
+ - ghc-lib-parser-ex-8.8.5.8@sha256:04f164fd6a4a5b0c5627cf7fadd79174c3b1d4c696dc481a9909266bd6a2a6aa,2760
+ - haskell-src-exts-1.22.0@sha256:f558923a9c8f57402c33a8cc871b934027a5c65414404c87239f6cbd7357d54e,4541
+ - ghc-exactprint-0.6.3.3@sha256:384e1066c192ed60dc12443b7aca75a4a4adcc47f829336c21ed007596fe683f,9446
+
+# Override default flag values for local packages and extra-deps
+# flags: {}
+
+# Extra package databases containing global packages
+# extra-package-dbs: []
+
+# Control whether we use the GHC we find on the path
+# system-ghc: true
+#
+# Require a specific version of stack, using version ranges
+# require-stack-version: -any # Default
+# require-stack-version: ">=2.5"
+#
+# Override the architecture used by stack, especially useful on Windows
+# arch: i386
+# arch: x86_64
+#
+# Extra directories used by stack for building
+# extra-include-dirs: [/path/to/dir]
+# extra-lib-dirs: [/path/to/dir]
+#
+# Allow a newer minor version of GHC than the snapshot specifies
+# compiler-check: newer-minor
diff --git a/stack.yaml.lock b/stack.yaml.lock
new file mode 100644
index 0000000..5ee3cef
--- /dev/null
+++ b/stack.yaml.lock
@@ -0,0 +1,104 @@
+# This file was autogenerated by Stack.
+# You should not edit this file by hand.
+# For more information, please see the documentation at:
+# https://docs.haskellstack.org/en/stable/lock_files
+
+packages:
+- completed:
+ hackage: sqlite-simple-0.4.18.0@sha256:3ceea56375c0a3590c814e411a4eb86943f8d31b93b110ca159c90689b6b39e5,3002
+ pantry-tree:
+ size: 1930
+ sha256: e58b9955e483d51ee0966f8ba4384305d871480e2a38b32ee0fcd4573d74cf95
+ original:
+ hackage: sqlite-simple-0.4.18.0@sha256:3ceea56375c0a3590c814e411a4eb86943f8d31b93b110ca159c90689b6b39e5,3002
+- completed:
+ hackage: direct-sqlite-2.3.26@sha256:04e835402f1508abca383182023e4e2b9b86297b8533afbd4e57d1a5652e0c23,3718
+ pantry-tree:
+ size: 770
+ sha256: 11874ab21e10c5b54cd1e02a037b677dc1e2ee9986f38c599612c56654dc01c3
+ original:
+ hackage: direct-sqlite-2.3.26@sha256:04e835402f1508abca383182023e4e2b9b86297b8533afbd4e57d1a5652e0c23,3718
+- completed:
+ hackage: random-1.2.0@sha256:1e8140229d21489228aa79b820c23259f3c3a1b86e13e6f9c2ad0c48d86d1912,6094
+ pantry-tree:
+ size: 1259
+ sha256: 20fadca2f3ea21eafc87f0d516045a18c19348ef85303f5a5e85662a55975170
+ original:
+ hackage: random-1.2.0@sha256:1e8140229d21489228aa79b820c23259f3c3a1b86e13e6f9c2ad0c48d86d1912,6094
+- completed:
+ hackage: splitmix-0.1.0.3@sha256:fc3aae74c467f4b608050bef53aec17904a618731df9407e655d8f3bf8c32d5c,6049
+ pantry-tree:
+ size: 1400
+ sha256: 8290f921f41c3628a6c9871502e57fd1d25f5954967afbf4ed16717fd8d3656f
+ original:
+ hackage: splitmix-0.1.0.3
+- completed:
+ hackage: QuickCheck-2.14.2@sha256:4ce29211223d5e6620ebceba34a3ca9ccf1c10c0cf387d48aea45599222ee5aa,7736
+ pantry-tree:
+ size: 2315
+ sha256: 2fe423d0ed7cd64f0f165d708779f48814e66c4f181c568468134af55d86a5f8
+ original:
+ hackage: QuickCheck-2.14.2
+- completed:
+ hackage: servant-0.18.2@sha256:f8c9f0e9891a3ada1337a3c0b369333a3b5a2d0909dd3cd09d79bc26adeaca44,5298
+ pantry-tree:
+ size: 2662
+ sha256: e930e814de1aa4d24274bdf18341a50b7ed38604ae4734f730e09238ac5bf7e2
+ original:
+ hackage: servant-0.18.2
+- completed:
+ hackage: servant-lucid-0.9.0.2@sha256:693278d574dba7313e931200118424762c02682bbc654e8866be4e6d1c73d816,1803
+ pantry-tree:
+ size: 392
+ sha256: c5635bc53887b81087c3430341790d45cd4063340a0baa62bedd2e77ed4aa84d
+ original:
+ hackage: servant-lucid-0.9.0.2
+- completed:
+ hackage: servant-server-0.18.2@sha256:56679af62ab8820a2108da6153d9ae9dde37199e62172365bdaea1458c3f7c2d,5482
+ pantry-tree:
+ size: 2614
+ sha256: 3ac7430134439e4b67f0f5333f63b89d0cb7de5e2e07f0af7801c8e223942b9c
+ original:
+ hackage: servant-server-0.18.2
+- completed:
+ hackage: hlint-2.2.11@sha256:f4eef0d718264824254bf375a85a91a8756b20c4f7d2a4854ffe4e69e8bd1679,4069
+ pantry-tree:
+ size: 5014
+ sha256: f75f1e4185337aa32610ec7710d12e5d2b9c79292fa8a08348580861c99c6826
+ original:
+ hackage: hlint-2.2.11@sha256:f4eef0d718264824254bf375a85a91a8756b20c4f7d2a4854ffe4e69e8bd1679,4069
+- completed:
+ hackage: stylish-haskell-0.9.4.4@sha256:ea514922e47ea05a924355a841abd26d18101037c46fbb90e201ae83582a8728,4953
+ pantry-tree:
+ size: 2863
+ sha256: 90316b02f585d82d84f90a393d838e9ae1603fd5c0a01f216459ab56f7dc8cfb
+ original:
+ hackage: stylish-haskell-0.9.4.4@sha256:ea514922e47ea05a924355a841abd26d18101037c46fbb90e201ae83582a8728,4953
+- completed:
+ hackage: ghc-lib-parser-ex-8.8.5.8@sha256:04f164fd6a4a5b0c5627cf7fadd79174c3b1d4c696dc481a9909266bd6a2a6aa,2760
+ pantry-tree:
+ size: 1453
+ sha256: 7b861387a0e0d668b77f1019ed57728d9d3136e489158716fc22077034a0d3d3
+ original:
+ hackage: ghc-lib-parser-ex-8.8.5.8@sha256:04f164fd6a4a5b0c5627cf7fadd79174c3b1d4c696dc481a9909266bd6a2a6aa,2760
+- completed:
+ hackage: haskell-src-exts-1.22.0@sha256:f558923a9c8f57402c33a8cc871b934027a5c65414404c87239f6cbd7357d54e,4541
+ pantry-tree:
+ size: 96940
+ sha256: 597b6f48bd409a4d0da013c4e356945c42e0d098966035d3aa68cd4a3ccd66c9
+ original:
+ hackage: haskell-src-exts-1.22.0@sha256:f558923a9c8f57402c33a8cc871b934027a5c65414404c87239f6cbd7357d54e,4541
+- completed:
+ hackage: ghc-exactprint-0.6.3.3@sha256:384e1066c192ed60dc12443b7aca75a4a4adcc47f829336c21ed007596fe683f,9446
+ pantry-tree:
+ size: 86248
+ sha256: c43b6e600634f5d5df2feb69e27e745fff25fe60503a30d3e5c86428882b686f
+ original:
+ hackage: ghc-exactprint-0.6.3.3@sha256:384e1066c192ed60dc12443b7aca75a4a4adcc47f829336c21ed007596fe683f,9446
+snapshots:
+- completed:
+ size: 532832
+ url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/16/23.yaml
+ sha256: fbb2a0519008533924c7753bd7164ddd1009f09504eb06674acad6049b46db09
+ original:
+ url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/16/23.yaml
diff --git a/static/EBGaramond-Italic-VariableFont_wght.ttf b/static/EBGaramond-Italic-VariableFont_wght.ttf
new file mode 100644
index 0000000..fa31b71
--- /dev/null
+++ b/static/EBGaramond-Italic-VariableFont_wght.ttf
Binary files differ
diff --git a/static/EBGaramond-VariableFont_wght.ttf b/static/EBGaramond-VariableFont_wght.ttf
new file mode 100644
index 0000000..123d5dd
--- /dev/null
+++ b/static/EBGaramond-VariableFont_wght.ttf
Binary files differ
diff --git a/static/style.css b/static/style.css
new file mode 100644
index 0000000..6355b03
--- /dev/null
+++ b/static/style.css
@@ -0,0 +1,119 @@
+@font-face {
+ font-family: EBGaramond;
+ src: url(/static/EBGaramond-VariableFont_wght.ttf) format('woff2-variations');
+ font-style: normal;
+}
+
+@font-face {
+ font-family: EBGaramond;
+ src: url(/static/EBGaramond-Italic-VariableFont_wght.ttf) format('woff2-variations');
+ font-style: italic;
+}
+
+body {
+ background: #fdf3f3;
+ color: DarkSlateGrey;
+ font-family: EBGaramond, serif;
+}
+
+a {
+ color: #1eaedb;
+}
+
+a:hover {
+ color: #0e99c4;
+}
+
+button[type="submit"] {
+ color: DarkSlateGrey;
+}
+
+@media (max-width: 800px) {
+ .container {
+ margin-left: 0.5em;
+ margin-right: 0.5em;
+ }
+
+ .navbar {
+ margin-top: 0.5em;
+ }
+}
+@media (min-width: 800px) {
+ .container {
+ margin-left: 3em;
+ margin-right: 3em;
+ }
+
+ .navbar {
+ margin-top: 3em;
+ }
+
+ body {
+ font-size: large;
+ }
+}
+
+.row {
+ margin-bottom: 2em;
+}
+
+.verse {
+ list-style: none;
+ padding-left: 0;
+ margin: 0;
+}
+
+.verse > li {
+ margin-bottom: 0;
+}
+
+p {
+ margin-top: 0;
+}
+
+.neighbors {
+ margin-bottom: 1.5em;
+}
+
+form > div {
+ margin-bottom: 8px;
+}
+
+label {
+ margin-right: 4px;
+}
+
+.focus {
+ font-weight: bold;
+}
+
+.outline {
+ background: black;
+}
+
+.domain-name, .title {
+ letter-spacing: -1.5px;
+}
+
+input[type="text"] {
+ width: 75%;
+ max-width: 50em;
+}
+
+.nonbreaking {
+ white-space: nowrap;
+}
+
+.manage-box {
+ display: inline-block;
+ border: 1px crimson dotted;
+ padding: .5em;
+}
+
+.manage-btn {
+ margin: .5em;
+}
+
+.manage-form {
+ display: inline-block;
+}
diff --git a/test/Spec.hs b/test/Spec.hs
new file mode 100644
index 0000000..483dd2a
--- /dev/null
+++ b/test/Spec.hs
@@ -0,0 +1,8 @@
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE OverloadedStrings #-}
+module Main (main) where
+
+import Lib (app)
+
+main :: IO ()
+main = return ()
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-24 17:15:15 +0000