devforms-0.1.0.0: src/Server.hs

{-# 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 {forms :: [Form]} deriving (Show)
type ServerBuilder = Writer (Endo Server)

staticFiles :: Map FilePath ByteString
staticFiles = fromList $(embedDir "static")

runServer :: Int -> ServerBuilder () -> IO ()
runServer port serverBuilder = do
    let Server{forms} = appEndo (execWriter serverBuilder) $ Server{forms = []}
    Scotty.scottyOpts (serverOptions port) $ do
        Scotty.get "/static/:asset" $ do
            asset <- Scotty.pathParam "asset"
            when (takeExtension asset == ".svg") $ do
                Scotty.addHeader "Content-Type" "image/svg+xml"
            case Map.lookup asset staticFiles of
                Just content -> Scotty.raw $ toLazy content
                Nothing -> Scotty.throw $ Scotty.QueryParameterNotFound $ toText asset
        forM_
            forms
            ( \form@Form{formId} -> do
                Scotty.get (getFormUrl form) $ do
                    Scotty.html $ renderText $ page $ renderForm form
                Scotty.post (getSubmitUrl form) $ do
                    params <- Scotty.formParams
                    case parseAnswers (questions form) (fromList params) of
                        Left err -> do
                            Scotty.status status400
                            Scotty.text $ toLazy err
                        Right answerPairs -> do
                            let encoded = JSON.encode $ JSON.object answerPairs
                            appendFileLBS ("answers-" <> toString formId <> ".jsonl") ("\n" <> encoded)
                            Scotty.html $ renderText $ p_ "Form submitted"
            )

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

logServer :: (Request -> Status -> Maybe Integer -> IO ())
logServer req stat _ = do
    time <- getCurrentTime
    putLBSLn $ JSON.encode $ ServerLog{timestamp = time, request = req, status = stat}

data ServerLog = ServerLog
    { timestamp :: UTCTime
    , request :: Request
    , status :: Status
    }
    deriving (Generic, Show)

instance JSON.ToJSON Status where
    toJSON (Status{statusMessage, statusCode}) =
        JSON.object ["statusCode" .= statusCode, "statusMessage" .= (decodeUtf8 statusMessage :: Text)]

instance JSON.ToJSON Request where
    toJSON req =
        JSON.object ["requestMethod" .= (decodeUtf8 $ requestMethod req :: Text), "rawPathInfo" .= (decodeUtf8 $ rawPathInfo req :: Text), "remoteHost" .= (show $ remoteHost req :: Text)]

instance JSON.ToJSON ServerLog

page :: Html () -> Html ()
page mainContent =
    html_
        ( do
            head_
                ( do
                    script_ [src_ "static/htmx.min.js"] ("" :: String)
                    script_ [src_ "static/_hyperscript.min.js"] ("" :: String)
                    link_ [rel_ "stylesheet", href_ "static/pico.classless.green.min.css"]
                    link_ [rel_ "stylesheet", href_ "https://cdnjs.cloudflare.com/ajax/libs/font-awesome/6.4.0/css/all.min.css"]
                )
            body_
                ( do
                    main_
                        ( do
                            nav_ $ pure ()
                            mainContent
                        )
                )
        )