From 38b8e7047b944a8f6ed41bea6bda1e7e3fe00259 Mon Sep 17 00:00:00 2001 From: quidtum Date: Mon, 30 Nov 2020 20:23:16 -0500 Subject: init --- .gitignore | 2 + LICENSE | 16 + README.md | 3 + Setup.hs | 2 + app/Main.hs | 8 + dbreset/Main.hs | 25 + package.yaml | 75 +++ spectralrenga.cabal | 124 ++++ src/Lib.hs | 829 +++++++++++++++++++++++++ stack.yaml | 80 +++ stack.yaml.lock | 104 ++++ static/EBGaramond-Italic-VariableFont_wght.ttf | Bin 0 -> 829752 bytes static/EBGaramond-VariableFont_wght.ttf | Bin 0 -> 897728 bytes static/style.css | 119 ++++ test/Spec.hs | 8 + 15 files changed, 1395 insertions(+) create mode 100644 .gitignore create mode 100644 LICENSE create mode 100644 README.md create mode 100644 Setup.hs create mode 100644 app/Main.hs create mode 100644 dbreset/Main.hs create mode 100644 package.yaml create mode 100644 spectralrenga.cabal create mode 100644 src/Lib.hs create mode 100644 stack.yaml create mode 100644 stack.yaml.lock create mode 100644 static/EBGaramond-Italic-VariableFont_wght.ttf create mode 100644 static/EBGaramond-VariableFont_wght.ttf create mode 100644 static/style.css create mode 100644 test/Spec.hs 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 . + 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 · ") + 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_ "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 " → "))) + (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 Binary files /dev/null and b/static/EBGaramond-Italic-VariableFont_wght.ttf differ diff --git a/static/EBGaramond-VariableFont_wght.ttf b/static/EBGaramond-VariableFont_wght.ttf new file mode 100644 index 0000000..123d5dd Binary files /dev/null and b/static/EBGaramond-VariableFont_wght.ttf 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 () -- cgit v1.2.3