fig-web: Initial puzzle site

7 files changed, 116 insertions, 28 deletions

diff --git a/fig-monitor-discord/src/Fig/Monitor/Discord.hs b/fig-monitor-discord/src/Fig/Monitor/Discord.hs
index b451b6e..e25a363 100644
--- a/fig-monitor-discord/src/Fig/Monitor/Discord.hs
+++ b/fig-monitor-discord/src/Fig/Monitor/Discord.hs
@@ -4,7 +4,6 @@ module Fig.Monitor.Discord where
 
 import Fig.Prelude
 
-import Control.Monad (unless)
 import Control.Monad.Reader (runReaderT)
 import qualified Control.Concurrent.Async as Async
 import qualified Control.Concurrent.Chan as Chan
diff --git a/fig-utils/csrc/fig.c b/fig-utils/csrc/fig.c
index e828e71..2ad1005 100644
--- a/fig-utils/csrc/fig.c
+++ b/fig-utils/csrc/fig.c
@@ -33,9 +33,9 @@ int check_answer(char **failure, char *code, char *data) {
         check_answer_catch_body, &args,
         check_answer_catch_handler, NULL,
         check_answer_catch_handler, NULL);
-    if (scm_is_integer(res)) {
+    if (scm_is_bool(res)) {
         *failure = NULL;
-        return scm_to_int(res);
+        return scm_to_bool(res);
     } else {
         *failure = scm_to_utf8_stringn(res, NULL);
         return 0;
diff --git a/fig-utils/src/Fig/Utils/FFI.hs b/fig-utils/src/Fig/Utils/FFI.hs
index b5ee80e..be5e612 100644
--- a/fig-utils/src/Fig/Utils/FFI.hs
+++ b/fig-utils/src/Fig/Utils/FFI.hs
@@ -9,8 +9,8 @@ import Foreign.Marshal.Alloc
 
 foreign import ccall "check_answer" c_check_answer :: Ptr CString -> CString -> CString -> IO Int
 
-checkAnswer :: Text -> Text -> IO (Either Text Bool)
-checkAnswer tcode tanswer =
+checkAnswer :: MonadIO m => Text -> Text -> m (Either Text Bool)
+checkAnswer tcode tanswer = liftIO $
   withCString (unpack tcode) $ \code ->
   withCString (unpack tanswer) $ \answer ->
   alloca $ \rerr -> do
diff --git a/fig-web/fig-web.cabal b/fig-web/fig-web.cabal
index 4401427..ce87795 100644
--- a/fig-web/fig-web.cabal
+++ b/fig-web/fig-web.cabal
@@ -48,6 +48,7 @@ common deps
     , warp
     , websockets
     , wuss
+    , xss-sanitize
     , fig-utils
     , fig-bus
 
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 ()