{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}

module Server (Server (..), ServerBuilder, runServer) where

import Control.Monad.Writer
import Data.Aeson ((.=))
import Data.Aeson qualified as JSON
import Data.FileEmbed (embedDir)
import Data.Map qualified as Map
import Data.Time (UTCTime, getCurrentTime)
import Form (Form (..), getFormUrl, getSubmitUrl, renderForm)
import Lucid
import Network.HTTP.Types.Status (Status (..), status400)
import Network.Wai (Request (remoteHost), rawPathInfo, requestMethod)
import Network.Wai.Handler.Warp (defaultSettings, setFdCacheDuration, setLogger, setPort)
import Question (parseAnswers)
import System.FilePath (takeExtension)
import Web.Scotty qualified as Scotty

data Server = Server {Server -> [Form]
forms :: [Form]} deriving (Int -> Server -> ShowS
[Server] -> ShowS
Server -> String
(Int -> Server -> ShowS)
-> (Server -> String) -> ([Server] -> ShowS) -> Show Server
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Server -> ShowS
showsPrec :: Int -> Server -> ShowS
$cshow :: Server -> String
show :: Server -> String
$cshowList :: [Server] -> ShowS
showList :: [Server] -> ShowS
Show)

-- | A builder monad for configuring the devforms server. Use 'form' to add forms.
type ServerBuilder = Writer (Endo Server)

staticFiles :: Map FilePath ByteString
staticFiles :: Map String ByteString
staticFiles = [Item (Map String ByteString)] -> Map String ByteString
forall l. IsList l => [Item l] -> l
fromList $(embedDir "static")

runServer :: Int -> ServerBuilder () -> IO ()
runServer :: Int -> ServerBuilder () -> IO ()
runServer Int
port ServerBuilder ()
serverBuilder = do
    let Server{[Form]
forms :: Server -> [Form]
forms :: [Form]
forms} = Endo Server -> Server -> Server
forall a. Endo a -> a -> a
appEndo (ServerBuilder () -> Endo Server
forall w a. Writer w a -> w
execWriter ServerBuilder ()
serverBuilder) (Server -> Server) -> Server -> Server
forall a b. (a -> b) -> a -> b
$ Server{forms :: [Form]
forms = []}
    Options -> ScottyM () -> IO ()
Scotty.scottyOpts (Int -> Options
serverOptions Int
port) (ScottyM () -> IO ()) -> ScottyM () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        RoutePattern -> ActionM () -> ScottyM ()
Scotty.get RoutePattern
"/static/:asset" (ActionM () -> ScottyM ()) -> ActionM () -> ScottyM ()
forall a b. (a -> b) -> a -> b
$ do
            String
asset <- Text -> ActionM String
forall a. Parsable a => Text -> ActionM a
Scotty.pathParam Text
"asset"
            Bool -> ActionM () -> ActionM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ShowS
takeExtension String
asset String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
".svg") (ActionM () -> ActionM ()) -> ActionM () -> ActionM ()
forall a b. (a -> b) -> a -> b
$ do
                Text -> Text -> ActionM ()
Scotty.addHeader Text
"Content-Type" Text
"image/svg+xml"
            case String -> Map String ByteString -> Maybe ByteString
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup String
asset Map String ByteString
staticFiles of
                Just ByteString
content -> ByteString -> ActionM ()
Scotty.raw (ByteString -> ActionM ()) -> ByteString -> ActionM ()
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
forall l s. LazyStrict l s => s -> l
toLazy ByteString
content
                Maybe ByteString
Nothing -> ScottyException -> ActionM ()
forall e a. Exception e => e -> ActionM a
Scotty.throw (ScottyException -> ActionM ()) -> ScottyException -> ActionM ()
forall a b. (a -> b) -> a -> b
$ Text -> ScottyException
Scotty.QueryParameterNotFound (Text -> ScottyException) -> Text -> ScottyException
forall a b. (a -> b) -> a -> b
$ String -> Text
forall a. ToText a => a -> Text
toText String
asset
        [Form] -> (Form -> ScottyM ()) -> ScottyM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_
            [Form]
forms
            ( \form :: Form
form@Form{Text
formId :: Text
formId :: Form -> Text
formId} -> do
                RoutePattern -> ActionM () -> ScottyM ()
Scotty.get (Form -> RoutePattern
forall a. IsString a => Form -> a
getFormUrl Form
form) (ActionM () -> ScottyM ()) -> ActionM () -> ScottyM ()
forall a b. (a -> b) -> a -> b
$ do
                    Text -> ActionM ()
Scotty.html (Text -> ActionM ()) -> Text -> ActionM ()
forall a b. (a -> b) -> a -> b
$ HtmlT Identity () -> Text
forall a. Html a -> Text
renderText (HtmlT Identity () -> Text) -> HtmlT Identity () -> Text
forall a b. (a -> b) -> a -> b
$ HtmlT Identity () -> HtmlT Identity ()
page (HtmlT Identity () -> HtmlT Identity ())
-> HtmlT Identity () -> HtmlT Identity ()
forall a b. (a -> b) -> a -> b
$ Form -> HtmlT Identity ()
renderForm Form
form
                RoutePattern -> ActionM () -> ScottyM ()
Scotty.post (Form -> RoutePattern
forall a. IsString a => Form -> a
getSubmitUrl Form
form) (ActionM () -> ScottyM ()) -> ActionM () -> ScottyM ()
forall a b. (a -> b) -> a -> b
$ do
                    [Param]
params <- ActionM [Param]
Scotty.formParams
                    case [Question] -> Map Text Text -> Either Text [(Key, Value)]
parseAnswers (Form -> [Question]
questions Form
form) ([Item (Map Text Text)] -> Map Text Text
forall l. IsList l => [Item l] -> l
fromList [Param]
[Item (Map Text Text)]
params) of
                        Left Text
err -> do
                            Status -> ActionM ()
Scotty.status Status
status400
                            Text -> ActionM ()
Scotty.text (Text -> ActionM ()) -> Text -> ActionM ()
forall a b. (a -> b) -> a -> b
$ Text -> Text
forall l s. LazyStrict l s => s -> l
toLazy Text
err
                        Right [(Key, Value)]
answerPairs -> do
                            let encoded :: ByteString
encoded = Value -> ByteString
forall a. ToJSON a => a -> ByteString
JSON.encode (Value -> ByteString) -> Value -> ByteString
forall a b. (a -> b) -> a -> b
$ [(Key, Value)] -> Value
JSON.object [(Key, Value)]
answerPairs
                            String -> ByteString -> ActionM ()
forall (m :: * -> *). MonadIO m => String -> ByteString -> m ()
appendFileLBS (String
"answers-" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
forall a. ToString a => a -> String
toString Text
formId String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
".jsonl") (ByteString
"\n" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
encoded)
                            Text -> ActionM ()
Scotty.html (Text -> ActionM ()) -> Text -> ActionM ()
forall a b. (a -> b) -> a -> b
$ HtmlT Identity () -> Text
forall a. Html a -> Text
renderText (HtmlT Identity () -> Text) -> HtmlT Identity () -> Text
forall a b. (a -> b) -> a -> b
$ HtmlT Identity () -> HtmlT Identity ()
forall arg result. Term arg result => arg -> result
p_ HtmlT Identity ()
"Form submitted"
            )

serverOptions :: Int -> Scotty.Options
serverOptions :: Int -> Options
serverOptions Int
port = Options
Scotty.defaultOptions{Scotty.settings = setLogger logServer . setPort port . setFdCacheDuration 10 $ defaultSettings}

logServer :: (Request -> Status -> Maybe Integer -> IO ())
logServer :: Request -> Status -> Maybe Integer -> IO ()
logServer Request
req Status
stat Maybe Integer
_ = do
    UTCTime
time <- IO UTCTime
getCurrentTime
    ByteString -> IO ()
forall (m :: * -> *). MonadIO m => ByteString -> m ()
putLBSLn (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ ServerLog -> ByteString
forall a. ToJSON a => a -> ByteString
JSON.encode (ServerLog -> ByteString) -> ServerLog -> ByteString
forall a b. (a -> b) -> a -> b
$ ServerLog{timestamp :: UTCTime
timestamp = UTCTime
time, request :: Request
request = Request
req, status :: Status
status = Status
stat}

data ServerLog = ServerLog
    { ServerLog -> UTCTime
timestamp :: UTCTime
    , ServerLog -> Request
request :: Request
    , ServerLog -> Status
status :: Status
    }
    deriving ((forall x. ServerLog -> Rep ServerLog x)
-> (forall x. Rep ServerLog x -> ServerLog) -> Generic ServerLog
forall x. Rep ServerLog x -> ServerLog
forall x. ServerLog -> Rep ServerLog x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. ServerLog -> Rep ServerLog x
from :: forall x. ServerLog -> Rep ServerLog x
$cto :: forall x. Rep ServerLog x -> ServerLog
to :: forall x. Rep ServerLog x -> ServerLog
Generic, Int -> ServerLog -> ShowS
[ServerLog] -> ShowS
ServerLog -> String
(Int -> ServerLog -> ShowS)
-> (ServerLog -> String)
-> ([ServerLog] -> ShowS)
-> Show ServerLog
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ServerLog -> ShowS
showsPrec :: Int -> ServerLog -> ShowS
$cshow :: ServerLog -> String
show :: ServerLog -> String
$cshowList :: [ServerLog] -> ShowS
showList :: [ServerLog] -> ShowS
Show)

instance JSON.ToJSON Status where
    toJSON :: Status -> Value
toJSON (Status{ByteString
statusMessage :: ByteString
statusMessage :: Status -> ByteString
statusMessage, Int
statusCode :: Int
statusCode :: Status -> Int
statusCode}) =
        [(Key, Value)] -> Value
JSON.object [Key
"statusCode" Key -> Int -> (Key, Value)
forall v. ToJSON v => Key -> v -> (Key, Value)
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Int
statusCode, Key
"statusMessage" Key -> Text -> (Key, Value)
forall v. ToJSON v => Key -> v -> (Key, Value)
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= (ByteString -> Text
forall a b. ConvertUtf8 a b => b -> a
decodeUtf8 ByteString
statusMessage :: Text)]

instance JSON.ToJSON Request where
    toJSON :: Request -> Value
toJSON Request
req =
        [(Key, Value)] -> Value
JSON.object [Key
"requestMethod" Key -> Text -> (Key, Value)
forall v. ToJSON v => Key -> v -> (Key, Value)
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= (ByteString -> Text
forall a b. ConvertUtf8 a b => b -> a
decodeUtf8 (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ Request -> ByteString
requestMethod Request
req :: Text), Key
"rawPathInfo" Key -> Text -> (Key, Value)
forall v. ToJSON v => Key -> v -> (Key, Value)
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= (ByteString -> Text
forall a b. ConvertUtf8 a b => b -> a
decodeUtf8 (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ Request -> ByteString
rawPathInfo Request
req :: Text), Key
"remoteHost" Key -> Text -> (Key, Value)
forall v. ToJSON v => Key -> v -> (Key, Value)
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= (SockAddr -> Text
forall b a. (Show a, IsString b) => a -> b
show (SockAddr -> Text) -> SockAddr -> Text
forall a b. (a -> b) -> a -> b
$ Request -> SockAddr
remoteHost Request
req :: Text)]

instance JSON.ToJSON ServerLog

page :: Html () -> Html ()
page :: HtmlT Identity () -> HtmlT Identity ()
page HtmlT Identity ()
mainContent =
    HtmlT Identity () -> HtmlT Identity ()
forall arg result. Term arg result => arg -> result
html_
        ( do
            HtmlT Identity () -> HtmlT Identity ()
forall arg result. Term arg result => arg -> result
head_
                ( do
                    [Attributes] -> String -> HtmlT Identity ()
forall arg result. TermRaw arg result => arg -> result
script_ [Text -> Attributes
src_ Text
"static/htmx.min.js"] (String
"" :: String)
                    [Attributes] -> String -> HtmlT Identity ()
forall arg result. TermRaw arg result => arg -> result
script_ [Text -> Attributes
src_ Text
"static/_hyperscript.min.js"] (String
"" :: String)
                    [Attributes] -> HtmlT Identity ()
forall (m :: * -> *). Monad m => [Attributes] -> HtmlT m ()
link_ [Text -> Attributes
rel_ Text
"stylesheet", Text -> Attributes
href_ Text
"static/pico.classless.green.min.css"]
                    [Attributes] -> HtmlT Identity ()
forall (m :: * -> *). Monad m => [Attributes] -> HtmlT m ()
link_ [Text -> Attributes
rel_ Text
"stylesheet", Text -> Attributes
href_ Text
"https://cdnjs.cloudflare.com/ajax/libs/font-awesome/6.4.0/css/all.min.css"]
                )
            HtmlT Identity () -> HtmlT Identity ()
forall arg result. Term arg result => arg -> result
body_
                ( do
                    HtmlT Identity () -> HtmlT Identity ()
forall arg result. Term arg result => arg -> result
main_
                        ( do
                            HtmlT Identity () -> HtmlT Identity ()
forall arg result. Term arg result => arg -> result
nav_ (HtmlT Identity () -> HtmlT Identity ())
-> HtmlT Identity () -> HtmlT Identity ()
forall a b. (a -> b) -> a -> b
$ () -> HtmlT Identity ()
forall a. a -> HtmlT Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
                            HtmlT Identity ()
mainContent
                        )
                )
        )