path: root/src/Lib.hs

{-# LANGUAGE DataKinds                  #-}
{-# LANGUAGE DeriveGeneric              #-}
{-# LANGUAGE FlexibleContexts           #-}
{-# LANGUAGE FlexibleInstances          #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase                 #-}
{-# LANGUAGE MultiParamTypeClasses      #-}
{-# LANGUAGE NamedFieldPuns             #-}
{-# LANGUAGE OverloadedStrings          #-}
{-# LANGUAGE RankNTypes                 #-}
{-# LANGUAGE ScopedTypeVariables        #-}
{-# LANGUAGE TypeOperators              #-}
{-# LANGUAGE UndecidableInstances       #-}

module Lib
    ( startApp
    , app
    , createDomain
    , withTx
    , makeDefaultGraphSpec
    , DomainName(..)
    ) where

import           Control.Exception                (throw)
import qualified Control.Exception                as E
import qualified Control.Exception.Safe           as CES
import           Control.Monad
import           Control.Monad.IO.Class
import           Data.Bits
import           Data.Char
import           Data.List
import qualified Data.Map.Strict                  as M
import           Data.Maybe
import qualified Data.Set                         as S
import           Data.String.Conversions          (cs)
import qualified Data.Text                        as T
import           Database.SQLite.Simple
import           Database.SQLite.Simple.FromField
import           Database.SQLite.Simple.ToField
import           GHC.Generics
import           Lucid
import           Network.Wai.Handler.Warp
import           Numeric
import           Servant                          hiding ((:.))
import           Servant.HTML.Lucid
import           System.Random.Stateful
import           Web.FormUrlEncoded

newtype DomainIden = DomainIden Integer deriving (FromField, FromHttpApiData, ToHttpApiData, ToField)
newtype LineIden = LineIden Integer deriving (Eq, Ord, FromField, FromHttpApiData, ToHttpApiData, ToField, Generic, Num)
newtype Color = Color T.Text deriving (FromField, ToHttpApiData, ToField)

hexDigits :: T.Text
hexDigits = "0123456789abcdef"

instance Uniform Color where
    uniformM g = do
        indices <- replicateM 6 (uniformRM (0, 15) g)
        return $ Color $ T.pack $ fmap (T.index hexDigits) indices

sampleColor :: StatefulGen g m => g -> m Color
sampleColor g = iterateUntil (not . isLight) (uniformM g) -- unbounded loop OK in expectation
    where iterateUntil f m = m >>= (\x -> if f x then return x else iterateUntil f m)

instance FromHttpApiData Color where
    parseUrlPiece "" = Left "color is empty"
    parseUrlPiece s
        | 6 /= T.length t = Left "color not 6 characters"
        | not $ T.all isHexDigit t = Left "color not hex"
        | otherwise = Right (Color t)
        where t = T.drop 1 s

newtype LineText = LineText T.Text deriving (FromField, ToHtml, ToHttpApiData, ToField)
instance FromHttpApiData LineText where
    parseUrlPiece s
        | T.length s < 1 = Left "line text empty"
        | T.length s > 120 = Left "line text over 120 characters"
        | not $ T.all isPrint s = Left "line text not printable"
        | otherwise = Right $ LineText s

newtype DomainName = DomainName T.Text deriving (Eq, FromField, ToHttpApiData, ToHtml, ToField)
instance FromHttpApiData DomainName where
    parseUrlPiece s
        | T.length s < 1 = Left "subgraph name empty"
        | T.length s > 120 = Left "subgraph name over 120 characters"
        | not $ T.all isAscii s = Left "subgraph name not ASCII"
        | not $ T.all (\c -> isAlphaNum c || T.isInfixOf (T.singleton c) "-_.") s =
            Left "subgraph name not in [A-Za-z0-9] or -, _, ."
        | otherwise = Right (DomainName s)

data DomainNamePart
  = Oxbow | Limber | Steadfast | Regicide | Swarm | Weave | Bough | Canopy | Herald | Scorn |
    Alder | Aerial | Welkin | Acrid | Kindling | Rapture | Myrtle | Envy | Solstice |
    Juniper | Cleaving | Stream | Reaper | Sluice | Conduit | Disdain | Sylvan | Ravish | Atrium |
    Thresh | Harvest | Water | Renewal | Rosy | Frieze | Portal | Vespers | Litany | Serpent |
    Primate | Incite | Canon | Acquiese | Mirror | Script | Seal | Privy |
    Piercing | Heresy | Subduct | Sceptre | Arrogance | Ivory | Accrete | Cluster |
    Sepulchre | Summon | Pleading | Myriad | Exalted | Sentry | Shriven | River | Threshold
    deriving (Enum, Show, Bounded)

randomDomainName :: StatefulGen g m => g -> m DomainName
randomDomainName g = do
    parts <- replicateM 8 (randomPart g)
    return $ DomainName $ T.intercalate "-" (fmap (T.pack . show) parts)
    where
        randomPart :: StatefulGen g m => g -> m DomainNamePart
        randomPart g' = uniformRM (0, length [(minBound :: DomainNamePart)..maxBound] - 1) g' >>= (return . toEnum)

data Line = Line LineIden Color LineText
instance FromRow Line where
    fromRow = Line <$> field <*> field <*> field
data DomainedLine = DomainedLine DomainName Line
data Domain = Domain DomainIden DomainName
data DomainInfo = DomainInfo { numNodes :: Integer, numEdges :: Integer }

-- a Verse is a list of lines that form a path in the graph
newtype Verse = Verse [Line]
newtype VerseSpec = VerseSpec [LineIden]
instance ToHttpApiData VerseSpec where
    toUrlPiece (VerseSpec lineIdens) = T.intercalate "-" $ fmap toUrlPiece lineIdens
instance FromHttpApiData VerseSpec where
    parseUrlPiece s = VerseSpec <$> mapM parseUrlPiece (T.splitOn "-" s)

data WriteSubmitForm = WriteSubmitForm { src   :: Maybe LineIden
                                       , dst   :: Maybe LineIden
                                       , txt   :: LineText
                                       , color :: Color } deriving (Generic)
instance FromForm WriteSubmitForm

data HomeView = HomeView
data DomainView = DomainView Domain DomainInfo Bool
data DomainReadView = DomainReadView DomainName (Maybe Verse)
data DomainWriteView = DomainWriteView DomainName (Maybe Line) (Maybe Line) Color
data DomainWalkView = DomainWalkView DomainName (Maybe (Line, [Line], [Line]))

type HomeAPI = 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, 3) :: Handler Integer
    let srcLineIden = if r <= 2 then getLineIden <$> src else Nothing
    let dstLineIden = if r <= 1 || r == 3 then getLineIden <$> dst else Nothing
    let initFlag = if isNothing srcLineIden && isNothing dstLineIden then Just () else Nothing
    redirectTo $ domainWriteURI domainName srcLineIden dstLineIden initFlag
    where
        getLineIden (Line lineIden _ _) = lineIden
        dbFn domainName' = withTx $ \conn -> do
            domain <- mustResolveDomainName conn domainName'
            (,) <$> randomLine conn domain <*> randomLine conn domain
handleDomainWrite domainName msrcLineIden mdstLineIden _ = do
    (src, dst) <- liftIO $ dbFn domainName msrcLineIden mdstLineIden
    color <- liftIO $ newStdGen >>= newIOGenM >>= sampleColor
    return $ DomainWriteView domainName src dst color
    where
        dbFn domainName' msrcLineIden' mdstLineIden' = withTx $ \conn -> do
            domain <- mustResolveDomainName conn domainName'
            src <- mapMaybeM msrcLineIden' (getLineById conn domain)
            dst <- mapMaybeM mdstLineIden' (getLineById conn domain)
            return (src, dst)

handleDomainWriteSubmit :: DomainName -> WriteSubmitForm -> Handler NoContent
handleDomainWriteSubmit domainName form = do
    (Line newLineIden _ _) <- liftIO $ dbFn domainName form
    redirectTo $ domainWalkURI domainName (Just newLineIden)
    where
        dbFn domainName' WriteSubmitForm{src=srcLineIden, dst=dstLineIden, txt, color} = withTx $ \conn -> do
            domain <- mustResolveDomainName conn domainName'
            when (isNothing srcLineIden && isNothing dstLineIden) $ do
                c <- numLinesInDomain conn domain
                -- an orphaned node can only be inserted into an empty domain
                when (c > 0) $ throw IllegalOrphanException
            newLine <- addLine conn domain txt color
            case srcLineIden of
              Nothing -> return ()
              Just srcLineIden' -> getLineById conn domain srcLineIden' >>= (\x -> addArrow conn domain x newLine)
            case dstLineIden of
              Nothing -> return ()
              Just dstLineIden' -> getLineById conn domain dstLineIden' >>= addArrow conn domain newLine
            return newLine

handleDomainWalk :: DomainName -> Maybe LineIden -> Handler DomainWalkView
handleDomainWalk domainName Nothing =
    liftIO (dbFn domainName) >>= \case
      Nothing -> return $ DomainWalkView domainName Nothing
      Just (Line lineIden _ _) -> redirectTo $ domainWalkURI domainName (Just lineIden)
    where
        dbFn domainName' = withTx $ \conn -> do
            domain <- mustResolveDomainName conn domainName'
            randomLine conn domain
handleDomainWalk domainName (Just lineIden) =
    DomainWalkView domainName . Just <$> liftIO (dbFn domainName lineIden)
    where
        dbFn domainName' lineIden' = withTx $ \conn -> do
            domain <- mustResolveDomainName conn domainName'
            line <- getLineById conn domain lineIden'
            prevs <- getPrevs conn domain line
            nexts <- getNexts conn domain line
            return (line, prevs, nexts)

handleDomainClear :: DomainName -> Handler NoContent
handleDomainClear domainName = managingHandler clearDomain (domainURI domainName) domainName

handleDomainReset :: DomainName -> Handler NoContent
handleDomainReset domainName = do
    g <- liftIO $ newStdGen >>= newIOGenM
    graphSpec <- liftIO $ makeDefaultGraphSpec g
    managingHandler (\c d -> resetDomain c d graphSpec) (domainURI domainName) domainName

handleDomainDelete :: DomainName -> Handler NoContent
handleDomainDelete = managingHandler deleteDomain homeURI

managingHandler :: (Connection -> Domain -> IO ()) -> T.Text -> DomainName -> Handler NoContent
managingHandler f uri = \domainName -> do
    liftIO $ rejectOnPublicDomain domainName
    liftIO (dbFn domainName)
    redirectTo uri
        where
            dbFn domainName' = withTx $ \conn -> do
                domain <- mustResolveDomainName conn domainName'
                f conn domain

-------------------------

resolveDomainName :: Connection -> DomainName -> IO (Maybe Domain)
resolveDomainName conn domainName = do
    ret <- headMay <$> query conn "SELECT iden \
                                  \FROM domains \
                                  \WHERE name=?" (Only domainName)
    case ret of
        Nothing -> return Nothing
        Just (Only domainIden) -> return . Just $ Domain domainIden domainName

mustResolveDomainName :: Connection -> DomainName -> IO Domain
mustResolveDomainName conn domainName =
    resolveDomainName conn domainName >>= \case
      Nothing     -> throw NotFoundException
      Just domain -> return domain

createDomain :: Connection -> DomainName -> GraphSpec -> IO Domain
createDomain conn domainName graphSpec = do
    execute conn "INSERT INTO domains (name) VALUES(?)" (Only domainName)
    domainIden <- DomainIden . fromIntegral <$> lastInsertRowId conn
    let domain = Domain domainIden domainName
    insertGraphSpec conn domain graphSpec
    return domain

getDomainInfo :: Connection -> Domain -> IO DomainInfo
getDomainInfo conn (Domain domainIden _) = do
    (Only numNodes) <- query conn "SELECT COUNT(*) \
                                   \FROM lines \
                                   \WHERE domain_iden=?" (Only domainIden) >>= mustHead
    (Only numEdges) <- query conn "SELECT COUNT(*) \
                                   \FROM arrows \
                                   \WHERE domain_iden=?" (Only domainIden) >>= mustHead
    return $ DomainInfo { numNodes=numNodes, numEdges=numEdges }

getLineById :: Connection -> Domain -> LineIden -> IO Line
getLineById conn (Domain domainIden _) lineIden =
    headMay <$> query conn "SELECT lines.iden, color, txt \
                           \FROM lines \
                           \WHERE domain_iden=? AND lines.iden=?" (domainIden, lineIden) >>= \case
      Nothing -> throw NotFoundException
      Just line -> return line

siblingPairs :: [a] -> [(a, a)]
siblingPairs []         = []
siblingPairs [_]        = []
siblingPairs (x:y:rest) = (x, y):siblingPairs (y:rest)

resolveVerseSpec :: Connection -> Domain -> VerseSpec -> IO Verse
resolveVerseSpec _ _ (VerseSpec []) = throw EmptyVerseException
resolveVerseSpec conn domain (VerseSpec [x]) = Verse . (: []) <$> getLineById conn domain x
resolveVerseSpec conn (Domain domainIden _) (VerseSpec lineIdens) = do
    let spairs = siblingPairs lineIdens
        spairsFlat = concatMap (\(a, b) -> [a, b]) spairs
        queryFragment = "(" <>
                T.intercalate " OR " (replicate (length spairs) "(a.iden=? AND b.iden=?)") <>
            ")"
    rows <- query conn (Query $ "SELECT a.iden, a.color, a.txt, b.iden, b.color, b.txt \
                                \FROM lines a \
                                \INNER JOIN lines b USING(domain_iden) \
                                \INNER JOIN arrows USING(domain_iden) \
                                \WHERE arrows.src=a.iden AND arrows.dst=b.iden \
                                \AND domain_iden=? AND " <> queryFragment)
                       (toField domainIden : fmap toField spairsFlat)
    let linePairs = fmap (\(x :. y) -> (x, y)) rows
        lineIdenPairs = fmap (\(Line aIden _ _, Line bIden _ _) -> (aIden, bIden)) linePairs
        m = M.fromList $ zip lineIdenPairs linePairs
    case mapM (`M.lookup` m) spairs of
        Just versePairs -> return . Verse $ fmap fst versePairs ++ [snd (last versePairs)]
        Nothing -> throw BrokenVerseException

randomLine :: Connection -> Domain -> IO (Maybe Line)
randomLine conn (Domain domainIden _) = headMay <$>
    query conn "SELECT lines.iden, color, txt \
               \FROM lines \
               \WHERE domain_iden=? \
               \ORDER BY RANDOM() LIMIT 1" (Only domainIden)

getRandomSuccessor :: Connection -> Domain -> Line -> IO (Maybe Line)
getRandomSuccessor conn (Domain domainIden _) (Line lineIden _ _) = headMay <$>
    query conn "SELECT lines.iden, color, txt FROM lines \
               \INNER JOIN arrows USING (domain_iden) \
               \WHERE domain_iden=? AND arrows.src=? AND lines.iden=arrows.dst \
               \ORDER BY RANDOM() LIMIT 1" (domainIden, lineIden)

numLinesInDomain :: Connection -> Domain -> IO Integer
numLinesInDomain conn (Domain domainIden _) = do
    (Only c) <- query conn "SELECT COUNT(*) FROM lines WHERE domain_iden=?" (Only domainIden) >>= mustHead
    return c

addLine :: Connection -> Domain -> LineText -> Color -> IO Line
addLine conn (Domain domainIden _) txt color = do
    execute conn "INSERT INTO lines (domain_iden, txt, color) VALUES(?, ?, ?)" (domainIden, txt, color)
    newLineIden <- fromIntegral <$> lastInsertRowId conn
    return $ Line newLineIden color txt

addArrow :: Connection -> Domain -> Line -> Line -> IO ()
addArrow conn (Domain domainIden _) (Line srcIden _ _) (Line dstIden _ _) =
    execute conn "INSERT INTO arrows (domain_iden, src, dst) VALUES(?, ?, ?)" (domainIden, srcIden, dstIden)

getPrevs :: Connection -> Domain -> Line -> IO [Line]
getPrevs conn (Domain domainIden _) (Line lineIden _ _) = query conn
    "SELECT lines.iden, color, txt FROM lines \
    \INNER JOIN arrows USING (domain_iden) \
    \WHERE domain_iden=? AND arrows.src=iden AND arrows.dst=?" (domainIden, lineIden)

getNexts :: Connection -> Domain -> Line -> IO [Line]
getNexts conn (Domain domainIden _) (Line lineIden _ _) = query conn
    "SELECT lines.iden, color, txt FROM lines \
    \INNER JOIN arrows USING (domain_iden) \
    \WHERE domain_iden=? AND arrows.dst=iden AND arrows.src=?" (domainIden, lineIden)

insertGraphSpec :: Connection -> Domain -> GraphSpec -> IO ()
insertGraphSpec conn domain (GraphSpec lineSpecs arrowSpecs) = do
    newLines <- mapM (uncurry (addLine conn domain)) lineSpecs
    mapM_ (\(a, b) -> addArrow conn domain (newLines !! a) (newLines !! b)) arrowSpecs

clearDomain :: Connection -> Domain -> IO ()
clearDomain conn (Domain domainIden _) = do
    execute conn "DELETE FROM lines WHERE domain_iden=?" (Only domainIden)
    execute conn "DELETE FROM arrows WHERE domain_iden=?" (Only domainIden)

resetDomain :: Connection -> Domain -> GraphSpec -> IO ()
resetDomain conn domain graphSpec = do
    clearDomain conn domain
    insertGraphSpec conn domain graphSpec

deleteDomain :: Connection -> Domain -> IO ()
deleteDomain conn domain@(Domain domainIden _) = do
    clearDomain conn domain
    execute conn "DELETE FROM domains WHERE iden=?" (Only domainIden)

-------------------------------

homeURI :: T.Text
homeURI = "/" <> toUrlPiece (safeLink api (Proxy :: Proxy HomeAPI) :: Link)

newDomainURI :: T.Text
newDomainURI = "/" <> toUrlPiece (safeLink api (Proxy :: Proxy NewDomainAPI) :: Link)

domainURI :: DomainName -> T.Text
domainURI domainName = "/" <> toUrlPiece (safeLink api (Proxy :: Proxy DomainAPI) domainName :: Link)

domainReadURI :: DomainName -> Maybe VerseSpec -> T.Text
domainReadURI domainName verseSpec = "/" <> toUrlPiece (safeLink api (Proxy :: Proxy DomainReadAPI) domainName verseSpec :: Link)

domainWriteURI :: DomainName -> Maybe LineIden -> Maybe LineIden -> Maybe () -> T.Text
domainWriteURI domainName src dst initFlag = "/" <> toUrlPiece (safeLink api (Proxy :: Proxy DomainWriteAPI) domainName src dst initFlag :: Link)

domainWriteSubmitURI :: DomainName -> T.Text
domainWriteSubmitURI domainName = "/" <> toUrlPiece (safeLink api (Proxy :: Proxy DomainWriteSubmitAPI) domainName :: Link)

domainWalkURI :: DomainName -> Maybe LineIden -> T.Text
domainWalkURI domainName lineIden = "/" <> toUrlPiece (safeLink api (Proxy :: Proxy DomainWalkAPI) domainName lineIden :: Link)

domainClearURI :: DomainName -> T.Text
domainClearURI domainName = "/" <> toUrlPiece (safeLink api (Proxy :: Proxy DomainClearAPI) domainName :: Link)

domainResetURI :: DomainName -> T.Text
domainResetURI domainName = "/" <> toUrlPiece (safeLink api (Proxy :: Proxy DomainResetAPI) domainName :: Link)

domainDeleteURI :: DomainName -> T.Text
domainDeleteURI domainName = "/" <> toUrlPiece (safeLink api (Proxy :: Proxy DomainDeleteAPI) domainName :: Link)

-------------------------------

instance ToHtml HomeView where
    toHtml HomeView = pageTemplate
        Nothing
        []
        homeBody
            where
                homeBody = div_ $ do
                    p_ $ do
                        strong_ [class_ "title"] "Spectral Renga"
                        span_ " is a collaborative graph of poetry."
                    p_ $ em_ $ do
                        a_ [href_ (domainURI (DomainName "piazza"))] "Join the public piazza"
                        span_ ", or "
                        a_ [href_ newDomainURI] "create a private subgraph"
                        span_ "."
                    p_ $ small_ $ do
                        a_ [href_ "https://git.cyfraeviolae.org/spectral-renga"] "source code"
                        span_ $ toHtmlRaw (T.pack " &middot; ")
                        a_ [href_ "https://cyfraeviolae.org/"] "cyfraeviolae.org"
                        span_ $ toHtmlRaw (T.pack " &middot; ")
                        a_ [href_ "https://www.nlsun.com"] "nlsun.com"

    toHtmlRaw = toHtml

instance ToHtml DomainView where
    toHtml (DomainView (Domain _ domainName) DomainInfo {numNodes, numEdges} showControls) = pageTemplate
        (Just domainName)
        [domainCrumb domainName, domainActionsCrumb domainName None]
        domainBody
        where
            domainBody = do
                div_ [class_ "row"] $ do
                    p_ $ do
                        span_ (toHtmlRaw (T.pack "Welcome to "))
                        strong_ [class_ "domain-name"] (toHtml domainName)
                        span_ $ toHtml $ ". This subgraph contains " <> show numNodes <> " nodes and " <> show numEdges <> " edges."
                    p_ $ em_ $ do
                        a_ [href_ (domainReadURI domainName Nothing)] "Read a poem"
                        span_ ", "
                        a_ [href_ (domainWriteURI domainName Nothing Nothing Nothing)] "write a line"
                        span_ ", "
                        a_ [href_ (domainWalkURI domainName Nothing)] "walk the graph"
                        span_ "."
                when showControls $ div_ [class_ "row manage-box"] $ do
                    form_ [action_ (domainClearURI domainName), method_ "post", class_ "manage-form"] $
                        button_ [type_ "submit", class_ "manage-btn"] "Clear"
                    form_ [action_ (domainResetURI domainName), method_ "post", class_ "manage-form"] $
                        button_ [type_ "submit", class_ "manage-btn"] "Reset"
                    form_ [action_ (domainDeleteURI domainName), method_ "post", class_ "manage-form"] $
                        button_ [type_ "submit", class_ "manage-btn"] "Delete"

    toHtmlRaw = toHtml

initialWritePrompt :: Monad m => DomainName -> HtmlT m ()
initialWritePrompt domainName = p_ $ do
    span_ "Nothing here yet. "
    a_ [href_ (domainWriteURI domainName Nothing Nothing Nothing)] "Write a line"
    span_ "."

instance ToHtml DomainReadView where
    toHtml (DomainReadView domainName verse) = pageTemplate
        (Just domainName)
        [domainCrumb domainName, domainActionsCrumb domainName Read]
        (case verse of
           Nothing -> initialWritePrompt domainName
           Just (Verse lines') -> ul_ [class_ "verse"] $ mapM_ (li_ . toHtml . DomainedLine domainName) lines')
    toHtmlRaw = toHtml

instance ToHtml DomainWriteView where
    toHtml (DomainWriteView domainName msrc mdst (Color color)) = pageTemplate
        (Just domainName)
        [domainCrumb domainName, domainActionsCrumb domainName Write]
        (div_ [class_ "row"] $ form_ [action_ (domainWriteSubmitURI domainName), method_ "post"] $ do
            case msrc of
              Just src@(Line (LineIden lineIdenInt) _ _) -> div_ $ do
                  label_ [] "previous line: "
                  span_ $ toHtml (DomainedLine domainName src)
                  input_ [type_ "text", name_ "src", value_ (T.pack $ show lineIdenInt), hidden_ "1"]
              Nothing -> div_ ""
            div_ $ do
                label_ [for_ "txt", class_ "focus"] "your line: "
                input_ [type_ "text", name_ "txt", id_ "txt", value_ "", maxlength_ "120", required_ "1"]
            div_ $ do
                label_ [for_ "color", class_ "focus"] "your color: "
                input_ [type_ "color", name_ "color", id_ "color", value_ ("#" <> color)]
            case mdst of
              Just dst@(Line (LineIden lineIdenInt) _ _) -> div_ $ do
                  input_ [type_ "text", name_ "dst", value_ (T.pack $ show lineIdenInt), hidden_ "1"]
                  label_ [] "next line: "
                  span_ $ toHtml (DomainedLine domainName dst)
              Nothing -> div_ ""
            div_ $
                input_ [type_ "submit", value_ "Submit"]
            )
    toHtmlRaw = toHtml

instance ToHtml DomainWalkView where
    toHtml (DomainWalkView domainName info) = pageTemplate
        (Just domainName)
        [domainCrumb domainName, domainActionsCrumb domainName Walk]
        (case info of
            Nothing -> initialWritePrompt domainName
            Just (line@(Line lineIden _ _), prevs, nexts) -> div_ [class_ "row"] $ do
                div_ [class_ "neighbors"] $ do
                    small_ $ do
                        em_ $ toHtmlRaw (T.pack "predecessors &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_ "shortcut icon", type_ "image/x-icon", href_ "/static/favicon.ico"]
        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 7 (length sampleLines)

numExtraArrowsInDefault :: Int
numExtraArrowsInDefault = 7

makeDefaultGraphSpec :: StatefulGen g m => g -> m GraphSpec
makeDefaultGraphSpec g = do
    cutAt <- uniformRM (0, length sampleLines - 1) g
    let lineTexts = take numNodesInDefault $ drop cutAt sampleLines ++ take cutAt sampleLines
    GraphSpec lineSpecs arrowSpecs <- makeConnectedGraph g lineTexts
    newArrowSpecs <- reduceSparsity g (length lineSpecs) numExtraArrowsInDefault arrowSpecs
    return $ GraphSpec lineSpecs newArrowSpecs

--------------

mapMaybeM :: Monad m => Maybe a -> (a -> m b) -> m (Maybe b)
mapMaybeM m f = maybe (return Nothing) (fmap Just . f) m

parseHex :: Color -> Integer
parseHex (Color s) = case readHex (T.unpack s) of
                       [(n, _)] -> n
                       _ -> error "should not happen; color is well-formed"
firstByte :: Integer -> Float
firstByte n = fromIntegral $ (n .&. 0xff0000) `shiftR` 16
secondByte :: Integer -> Float
secondByte n = fromIntegral $ (n .&. 0x00ff00) `shiftR` 8
thirdByte :: Integer -> Float
thirdByte n = fromIntegral $ n .&. 0x0000ff
brightness :: Integer -> Float
brightness n = 1.17*firstByte n + 2.30*secondByte n + 0.45*thirdByte n
isLight :: Color -> Bool
isLight color = (brightness . parseHex) color >= 800

collectUntil :: Int -> (a -> IO (Maybe a)) -> a -> IO [a]
collectUntil 0 _ _ = return []
collectUntil n f src =
    f src >>= \case
      Nothing -> return [src]
      Just dst' -> (:) src <$> collectUntil (n-1) f dst'

headMay :: [a] -> Maybe a
headMay []    = Nothing
headMay (x:_) = Just x

data HeadException = HeadException deriving (Show)
instance E.Exception HeadException

mustHead :: [a] -> IO a
mustHead []    = throw HeadException
mustHead (x:_) = return x