From a421eb9bdddfa7e2765456f756833d8941ac7a08 Mon Sep 17 00:00:00 2001 From: LLLL Colonq Date: Mon, 16 Jun 2025 05:42:58 -0400 Subject: fig-web: Initial puzzle site --- fig-web/src/Fig/Web/Module/Gizmo.hs | 2 +- fig-web/src/Fig/Web/Module/Puzzle.hs | 116 +++++++++++++++++++++++++++++------ fig-web/src/Fig/Web/Utils.hs | 16 ++++- 3 files changed, 111 insertions(+), 23 deletions(-) (limited to 'fig-web/src') diff --git a/fig-web/src/Fig/Web/Module/Gizmo.hs b/fig-web/src/Fig/Web/Module/Gizmo.hs index 0267ab6..bca23d5 100644 --- a/fig-web/src/Fig/Web/Module/Gizmo.hs +++ b/fig-web/src/Fig/Web/Module/Gizmo.hs @@ -24,7 +24,7 @@ public a = do Nothing -> do status status404 respondText "gizmo does not exist" - Just html -> respondHTML $ decodeUtf8 html + Just html -> respondHTMLText $ decodeUtf8 html onGet "/api/gizmo/list" do gizmos <- maybe [] (fmap decodeUtf8) <$> DB.hkeys a.db "gizmos" respondText $ Text.unlines gizmos diff --git a/fig-web/src/Fig/Web/Module/Puzzle.hs b/fig-web/src/Fig/Web/Module/Puzzle.hs index ff441eb..b8e469b 100644 --- a/fig-web/src/Fig/Web/Module/Puzzle.hs +++ b/fig-web/src/Fig/Web/Module/Puzzle.hs @@ -9,6 +9,11 @@ import qualified Data.Aeson as Aeson import qualified Data.UUID as UUID import qualified Data.UUID.V4 as UUID +import qualified Web.Scotty as Sc +import qualified Lucid as L +import Text.HTML.SanitizeXSS (sanitize) + +import Fig.Utils.FFI (checkAnswer) import Fig.Web.Utils import Fig.Web.Types import Fig.Web.Auth @@ -68,34 +73,107 @@ deletePuzzle db p = do srem db "puzzleids" [encodeUtf8 p] del db [puzzlePidKey p] -allPuzzles :: MonadIO m => DB -> m [Text] -allPuzzles db = smembers db "puzzleids" >>= \case +allPuzzlePids :: MonadIO m => DB -> m [Text] +allPuzzlePids db = smembers db "puzzleids" >>= \case Nothing -> pure [] Just xs -> pure $ decodeUtf8 <$> xs +allPuzzles :: MonadIO m => DB -> m [Puzzle] +allPuzzles db = do + pids <- allPuzzlePids db + catMaybes <$> forM pids \pid -> do + loadPuzzle db pid + +puzzleUrl :: Puzzle -> Text +puzzleUrl p = "/2d2p/" <> p.pid + +authorUrl :: Text -> Text +authorUrl a = "/2d2p/author/" <> a + +puzzleNameAuthorLinks :: Puzzle -> L.Html () +puzzleNameAuthorLinks p = do + a_ [href_ $ puzzleUrl p] $ L.toHtml p.name + " by " + a_ [href_ $ authorUrl p.author] $ L.toHtml p.author + +page :: L.Html () -> Sc.ActionM () +page b = do + respondHTML do + head_ do + title_ "today: to puzzle!" + body_ do + h1_ "today: to puzzle!" + b + secure :: SecureModule secure a = do - onGet "/api/puzzle" do + onGet "/2d2p" $ authed a \creds -> do puzzles <- allPuzzles a.db - respondJSON puzzles - onGet "/api/puzzle/:pid" do - pid <- pathParam "pid" - loadPuzzle a.db pid >>= \case - Nothing -> do - status status404 - respondText "no such puzzle" - Just p -> respondJSON p - onDelete "/api/puzzle/:pid" do - pid <- pathParam "pid" - deletePuzzle a.db pid - onPost "/api/puzzle" $ authed a \creds -> do - log "Creating puzzle" + page do + h2_ "all puzzles" + ul_ $ forM_ puzzles \p -> do + li_ do + puzzleNameAuthorLinks p + when (creds.twitchId == p.authorid) $ input_ + [ type_ "button" + , value_ "delete" + , onclick_ $ mconcat + [ "fetch('", puzzleUrl p + , "', { method: 'DELETE' }).then(() => window.location.reload());" + ] + ] + h2_ "create new puzzle" + form_ [method_ "post"] do + label_ "name: " + input_ [type_ "text", name_ "name"] + br_ [] + label_ "body: " + textarea_ [name_ "body"] $ pure () + br_ [] + label_ "checker: " + textarea_ [name_ "checker"] $ pure () + br_ [] + input_ [type_ "submit", value_ "submit"] + onPost "/2d2p" $ authed a \creds -> do let author = creds.user let authorid = creds.twitchId pid <- newPuzzlePid - log $ "pid: " <> tshow pid + log $ "Creating new puzzle with PID: " <> tshow pid name <- formParam "name" body <- formParam "body" checker <- formParam "checker" - savePuzzle a.db Puzzle {..} - respondText pid + let p = Puzzle {..} + savePuzzle a.db p + redirect $ puzzleUrl p + onGet "/2d2p/:pid" do + pid <- pathParam "pid" + loadPuzzle a.db pid >>= \case + Nothing -> do + status status404 + page $ h2_ "no such puzzle!" + Just p -> page do + h2_ $ puzzleNameAuthorLinks p + p_ $ L.toHtmlRaw $ sanitize p.body + form_ [method_ "post"] do + input_ [type_ "text", name_ "answer"] + input_ [type_ "submit", value_ "answer"] + onPost "/2d2p/:pid" do + pid <- pathParam "pid" + answer <- formParam "answer" + loadPuzzle a.db pid >>= \case + Nothing -> do + status status404 + page $ h2_ "no such puzzle!" + Just p -> do + checkAnswer p.checker answer >>= \case + Left err -> do + status status500 + page do + h2_ "error running checker:" + pre_ $ L.toHtml err + Right res -> page do + h2_ $ if res then "congratulations! that's right!" else "sorry, wrong answer!" + onDelete "/2d2p/:pid" do + pid <- pathParam "pid" + log $ "Deleting puzzle with PID: " <> tshow pid + deletePuzzle a.db pid diff --git a/fig-web/src/Fig/Web/Utils.hs b/fig-web/src/Fig/Web/Utils.hs index fbe17bf..521e781 100644 --- a/fig-web/src/Fig/Web/Utils.hs +++ b/fig-web/src/Fig/Web/Utils.hs @@ -11,13 +11,14 @@ module Fig.Web.Utils , status , queryParam, queryParamMaybe, formParam, formParamMaybe, pathParam , header - , respondText, respondJSON, respondHTML + , respondText, respondJSON, respondHTMLText, respondHTML, redirect , WebsocketHandler , websocket , BusEventHandler, BusEventHandlers , busEvents , handleBusEvent , subscribeBusEvents + , module Lucid.Html5 ) where import Fig.Prelude @@ -38,6 +39,9 @@ import qualified Network.WebSockets as WS import qualified Web.Scotty as Sc +import qualified Lucid as L +import Lucid.Html5 + import qualified Toml import Fig.Bus.Binary.Client @@ -146,8 +150,14 @@ respondText = Sc.text . Text.L.fromStrict respondJSON :: Aeson.ToJSON a => a -> Sc.ActionM () respondJSON = Sc.json -respondHTML :: Text -> Sc.ActionM () -respondHTML = Sc.html . Text.L.fromStrict +respondHTMLText :: Text -> Sc.ActionM () +respondHTMLText = Sc.html . Text.L.fromStrict + +respondHTML :: L.Html () -> Sc.ActionM () +respondHTML = Sc.html . L.renderText . html_ + +redirect :: Text -> Sc.ActionM () +redirect = Sc.redirect . Text.L.fromStrict type WebsocketHandler = (ByteString, WS.Connection -> IO ()) websocket :: [WebsocketHandler] -> Sc.ScottyM () -- cgit v1.2.3