Advent

7 files changed, 243 insertions, 15 deletions

diff --git a/fig-utils/csrc/fig.c b/fig-utils/csrc/fig.c
index 2ad1005..0df8bae 100644
--- a/fig-utils/csrc/fig.c
+++ b/fig-utils/csrc/fig.c
@@ -1,9 +1,61 @@
 #include <stdio.h>
 #include <libguile.h>
 
+SCM default_bindings() {
+    SCM bindings = scm_c_public_ref("ice-9 sandbox", "all-pure-and-impure-bindings");
+    bindings = scm_cons(
+        scm_list_2(
+            scm_list_2(scm_from_utf8_symbol("srfi"), scm_from_utf8_symbol("srfi-9")),
+            scm_from_utf8_symbol("define-record-type")),
+        bindings
+    );
+    bindings = scm_cons(
+        scm_list_2(
+            scm_list_2(scm_from_utf8_symbol("srfi"), scm_from_utf8_symbol("srfi-1")),
+            scm_from_utf8_symbol("drop")),
+        bindings
+    );
+    bindings = scm_cons(
+        scm_list_2(
+            scm_list_1(scm_from_utf8_symbol("guile")),
+            scm_from_utf8_symbol("seed->random-state")),
+        bindings
+    );
+    bindings = scm_cons(
+        scm_list_2(
+            scm_list_1(scm_from_utf8_symbol("guile")),
+            scm_from_utf8_symbol("random")),
+        bindings
+    );
+    bindings = scm_cons(
+        scm_list_2(
+            scm_list_1(scm_from_utf8_symbol("guile")),
+            scm_from_utf8_symbol("eval")),
+        bindings
+    );
+    bindings = scm_cons(
+        scm_list_2(
+            scm_list_1(scm_from_utf8_symbol("guile")),
+            scm_from_utf8_symbol("interaction-environment")),
+        bindings
+    );
+    return bindings;
+}
+
+SCM eval_sandbox(SCM call) {
+    SCM eval = scm_c_public_ref("ice-9 sandbox", "eval-in-sandbox");
+    return scm_call_7(eval, call,
+        scm_from_utf8_keyword("time-limit"), scm_from_int64(3),
+        scm_from_utf8_keyword("allocation-limit"), scm_from_int64(1024 * 1024 * 1024),
+        scm_from_utf8_keyword("bindings"),
+        default_bindings()
+    );
+}
+
 typedef struct check_answer_args {
     char *code;
-    char *data;
+    char *actual;
+    char *expected;
 } check_answer_args;
 SCM check_answer_catch_body(void *data) {
     check_answer_args *args = (check_answer_args *) data;
@@ -11,9 +63,8 @@ SCM check_answer_catch_body(void *data) {
     // SCM res = scm_call_1(handler, scm_from_utf8_string(args->data));
     SCM readport = scm_open_input_string(scm_from_utf8_string(args->code));
     SCM func = scm_read(readport);
-    SCM call = scm_list_2(func, scm_from_utf8_string(args->data));
-    SCM eval = scm_c_public_ref("ice-9 sandbox", "eval-in-sandbox");
-    return scm_call_1(eval, call);
+    SCM call = scm_list_3(func, scm_from_utf8_string(args->actual), scm_from_utf8_string(args->expected));
+    return eval_sandbox(call);
 }
 SCM check_answer_catch_handler(void *data, SCM key, SCM args) {
     SCM format = scm_c_public_ref("ice-9 format", "format");
@@ -25,9 +76,9 @@ SCM check_answer_catch_handler(void *data, SCM key, SCM args) {
     return scm_call_5(format, SCM_BOOL_F, fmt, key, func, msg);
 }
 
-int check_answer(char **failure, char *code, char *data) {
+int check_answer(char **failure, char *code, char *actual, char *expected) {
     scm_init_guile();
-    check_answer_args args = { .code = code, .data = data };
+    check_answer_args args = { .code = code, .actual = actual, .expected = expected };
     SCM res = scm_c_catch(
         SCM_BOOL_T,
         check_answer_catch_body, &args,
@@ -41,3 +92,41 @@ int check_answer(char **failure, char *code, char *data) {
         return 0;
     }
 }
+
+typedef struct gen_input_answer_args {
+    char *code;
+    char *twitchid;
+} gen_input_answer_args;
+SCM gen_input_answer_catch_body(void *data) {
+    gen_input_answer_args *args = (gen_input_answer_args *) data;
+    SCM readport = scm_open_input_string(scm_from_utf8_string(args->code));
+    SCM func = scm_read(readport);
+    SCM call = scm_list_2(func, scm_from_utf8_string(args->twitchid));
+    return eval_sandbox(call);
+}
+SCM gen_input_answer_catch_handler(void *data, SCM key, SCM args) {
+    SCM format = scm_c_public_ref("ice-9 format", "format");
+    SCM fmt = scm_from_utf8_string("~a: ~a: ~a");
+    SCM func = scm_car(args);
+    SCM afmt = scm_cadr(args);
+    SCM aargs = scm_caddr(args);
+    SCM msg = scm_apply_2(format, SCM_BOOL_F, afmt, aargs);
+    return scm_call_5(format, SCM_BOOL_F, fmt, key, func, msg);
+}
+
+void gen_input_answer(char **failure, char **input, char **answer, char *code, char *twitchid) {
+    scm_init_guile();
+    gen_input_answer_args args = { .code = code, .twitchid = twitchid };
+    SCM res = scm_c_catch(
+        SCM_BOOL_T,
+        gen_input_answer_catch_body, &args,
+        gen_input_answer_catch_handler, NULL,
+        gen_input_answer_catch_handler, NULL);
+    if (scm_is_pair(res)) {
+        *failure = NULL;
+        *input = scm_to_utf8_stringn(scm_car(res), NULL);
+        *answer = scm_to_utf8_stringn(scm_cdr(res), NULL);
+    } else {
+        *failure = scm_to_utf8_stringn(res, NULL);
+    }
+}
diff --git a/fig-utils/src/Fig/Utils/FFI.hs b/fig-utils/src/Fig/Utils/FFI.hs
index be5e612..403bd1b 100644
--- a/fig-utils/src/Fig/Utils/FFI.hs
+++ b/fig-utils/src/Fig/Utils/FFI.hs
@@ -7,17 +7,40 @@ import Foreign.Storable (Storable(..))
 import Foreign.C.String
 import Foreign.Marshal.Alloc
 
-foreign import ccall "check_answer" c_check_answer :: Ptr CString -> CString -> CString -> IO Int
+foreign import ccall "check_answer" c_check_answer :: Ptr CString -> CString -> CString -> CString -> IO Int
 
-checkAnswer :: MonadIO m => Text -> Text -> m (Either Text Bool)
-checkAnswer tcode tanswer = liftIO $
+checkAnswer :: MonadIO m => Text -> Text -> Text -> m (Either Text Bool)
+checkAnswer tcode tanswer texpected = liftIO $
   withCString (unpack tcode) $ \code ->
   withCString (unpack tanswer) $ \answer ->
+  withCString (unpack texpected) $ \expected ->
   alloca $ \rerr -> do
-  res <- c_check_answer rerr code answer
+  res <- c_check_answer rerr code answer expected
   err <- peek rerr
   if err == nullPtr
   then pure . Right $ res /= 0
   else do
     msg <- peekCString err
+    free err
+    pure . Left $ pack msg
+
+foreign import ccall "gen_input_answer" c_gen_input_answer :: Ptr CString -> Ptr CString -> Ptr CString -> CString -> CString -> IO ()
+
+genInputAnswer :: MonadIO m => Text -> Text -> m (Either Text (Text, Text))
+genInputAnswer tcode ttwitchid = liftIO $ 
+  withCString (unpack tcode) $ \code ->
+  withCString (unpack ttwitchid) $ \twitchid ->
+  alloca $ \rerr ->
+  alloca $ \rinput ->
+  alloca $ \ranswer -> do
+  c_gen_input_answer rerr rinput ranswer code twitchid
+  err <- peek rerr
+  if err == nullPtr
+  then do
+    input <- peekCString =<< peek rinput
+    answer <- peekCString =<< peek ranswer
+    pure $ Right (pack input, pack answer)
+  else do
+    msg <- peekCString err
+    free err
     pure . Left $ pack msg
diff --git a/fig-web/fig-web.cabal b/fig-web/fig-web.cabal
index 4eee663..8317fa5 100644
--- a/fig-web/fig-web.cabal
+++ b/fig-web/fig-web.cabal
@@ -74,7 +74,7 @@ library
     Fig.Web.Module.User
     Fig.Web.Module.Shader
     Fig.Web.Module.Redeem
-    Fig.Web.Module.Puzzle
+    Fig.Web.Module.Advent
     Fig.Web.Module.HLS
     Fig.Web.Module.TCG
 
diff --git a/fig-web/main/Main.hs b/fig-web/main/Main.hs
index b1cc006..a3c798a 100644
--- a/fig-web/main/Main.hs
+++ b/fig-web/main/Main.hs
@@ -60,6 +60,7 @@ main = do
     Secure o -> Secure.server o cfg (opts.busHost, opts.busPort)
     TestFFI -> do
       log "testing FFI"
-      res <- FFI.checkAnswer "(lambda (d) (define (loop) (loop)) (loop) (string-length d))"
-        "hello computer"
+      res <- FFI.checkAnswer "(lambda (d e) (equal? d e))" "hello computer" "hello computer"
       log $ "result: " <> tshow res
+      inpa <- FFI.genInputAnswer "(lambda (x) (cons x x))" "hello computer"
+      log $ "input/answer: " <> tshow inpa
diff --git a/fig-web/src/Fig/Web/Module/Advent.hs b/fig-web/src/Fig/Web/Module/Advent.hs
new file mode 100644
index 0000000..4b73ba0
--- /dev/null
+++ b/fig-web/src/Fig/Web/Module/Advent.hs
@@ -0,0 +1,113 @@
+module Fig.Web.Module.Advent where
+
+import Fig.Prelude
+
+import qualified Lucid as L
+import Text.HTML.SanitizeXSS (sanitize)
+
+import Fig.Web.Utils
+import Fig.Web.Types
+import Fig.Web.Auth
+import Fig.Web.DB as DB
+import qualified Fig.Utils.FFI as FFI
+
+keybase :: Integer -> Text -> Text -> ByteString
+keybase pid part key = "advent:2025:" <> bspid <> ":" <> encodeUtf8 part <> ":" <> encodeUtf8 key
+  where bspid = encodeUtf8 $ tshow pid
+
+secure :: SecureModule
+secure a = do
+  onGet "/advent/puzzle/:pid" $ authed a \creds -> do
+    pid :: Integer <- pathParam "pid"
+    mpart1body <- fmap decodeUtf8 <$> DB.get a.db (keybase pid "part1" "body")
+    part1solved <- DB.sismember a.db (keybase pid "part1" "solvers") (encodeUtf8 creds.twitchId)
+    mpart2body <- fmap decodeUtf8 <$> DB.get a.db (keybase pid "part2" "body")
+    part2solved <- DB.sismember a.db (keybase pid "part2" "solvers") (encodeUtf8 creds.twitchId)
+    case (mpart1body, mpart2body) of
+      (Just part1body, Just part2body) -> do
+        respondHTML do
+          head_ do
+            title_ . L.toHtml $ "adventure of advent of code 2025: puzzle " <> tshow pid
+            link_ [rel_ "icon", href_ "/assets/mrgreen.png"]
+            link_ [rel_ "stylesheet", type_ "text/css", href_ "/main.css"]
+          body_ [id_ "lcolonq-advent"] do
+            div_ [class_ "lcolonq-advent-header"] do
+              h1_ . L.toHtml $ "puzzle " <> tshow pid <> " (part 1)"
+            div_ [class_ "lcolonq-advent-body"] do
+              L.toHtmlRaw $ sanitize part1body
+            a_ [class_ "lcolonq-advent-link", href_ $ "/advent/puzzle/" <> tshow pid <> "/part1/input.txt"]
+              "click here to see your input"
+            form_ [action_ $ "/advent/puzzle/" <> tshow pid <> "/part1/submit", method_ "post", class_ "lcolonq-advent-form"] do
+              label_ [for_ "answer"] "Enter your answer:"
+              input_ [type_ "text", name_ "answer", required_ ""]
+              input_ [type_ "submit", class_ "lcolonq-advent-submit"]
+            when part1solved do
+              div_ [class_ "lcolonq-advent-congrats"] do
+                "Congrats, you've solved Part 1! The puzzle continues below."
+              div_ [class_ "lcolonq-advent-header"] do
+                h1_ . L.toHtml $ "puzzle " <> tshow pid <> " (part 2)"
+              div_ [class_ "lcolonq-advent-body"] do
+                L.toHtmlRaw $ sanitize part2body
+              a_ [class_ "lcolonq-advent-link", href_ $ "/advent/puzzle/" <> tshow pid <> "/part2/input.txt"]
+                "click here to see your input"
+              form_ [action_ $ "/advent/puzzle/" <> tshow pid <> "/part2/submit", method_ "post", class_ "lcolonq-advent-form"] do
+                label_ [for_ "answer"] "Enter your answer:"
+                input_ [type_ "text", name_ "answer", required_ ""]
+                input_ [type_ "submit", class_ "lcolonq-advent-submit"]
+              when part2solved $ div_ [class_ "lcolonq-advent-congrats"] do
+                "Congrats, you've solved Part 2! The puzzle is complete!"
+      _ -> do
+        status status404
+        respondText "puzzle not found. ask clonk about it, unless you're messing with the url. you url-messer-wither you."
+  onGet "/advent/puzzle/:pid/:part/input.txt" $ authed a \creds -> do
+    pid :: Integer <- pathParam "pid"
+    part <- pathParam "part"
+    let bstid = encodeUtf8 creds.twitchId
+    DB.hget a.db (keybase pid part "inputs") bstid >>= \case
+      Just inp ->
+        respondText $ decodeUtf8 inp
+      Nothing -> do
+        DB.get a.db (keybase pid part "generator") >>= \case
+          Nothing -> do
+            status status404
+            respondText "the puzzle has no generator associated with it. tell clonk please!"
+          Just bsgen -> do
+            let gen = decodeUtf8 bsgen
+            FFI.genInputAnswer gen creds.twitchId >>= \case
+              Left err -> do
+                status status500
+                respondText $ mconcat
+                  [ "failed to generate an input for you. this is a problem! here's why:\n"
+                  , err
+                  ]
+              Right (inp, ans) -> do
+                DB.hset a.db (keybase pid part "inputs") bstid $ encodeUtf8 inp
+                DB.hset a.db (keybase pid part "answers") bstid $ encodeUtf8 ans
+                respondText inp
+  onPost "/advent/puzzle/:pid/:part/submit" $ authed a \creds -> do
+    pid :: Integer <- pathParam "pid"
+    part <- pathParam "part"
+    let bstid = encodeUtf8 creds.twitchId
+    actual <- formParam "answer"
+    mcheck <- fmap decodeUtf8 <$> DB.get a.db (keybase pid part "checker")
+    manswer <- DB.hget a.db (keybase pid part "answers") bstid
+    case (mcheck, manswer) of
+      (Just check, Just expected) -> do
+        FFI.checkAnswer check actual (decodeUtf8 expected) >>= \case
+          Left err -> do
+            status status500
+            respondText $ mconcat
+              [ "the checker failed to report if your answer was correct. this is probably a clonk-problem. here's the error:\n"
+              , err
+              ]
+          Right False -> do
+            respondText "that's the wrong answer, try again!"
+          Right True -> do
+            DB.sadd a.db (keybase pid part "solvers") [encodeUtf8 creds.twitchId]
+            respondText "that's the right answer! nice work!"
+      (Nothing, _) -> do
+        status status500
+        respondText "the puzzle is messed up and your solution could not be checked - ask clonk about it!"
+      _ -> do
+        status status400
+        respondText "you never even looked at the input! make sure to check that out first, or there's no way you can solve the puzzle!"
diff --git a/fig-web/src/Fig/Web/Public.hs b/fig-web/src/Fig/Web/Public.hs
index 56a9925..a5e6722 100644
--- a/fig-web/src/Fig/Web/Public.hs
+++ b/fig-web/src/Fig/Web/Public.hs
@@ -62,6 +62,7 @@ app args = do
       , Wai.Static.only
         [ ("register", "register.html")
         , ("gizmo", "gizmo.html")
+        , ("advent", "advent.html")
         , ("main.css", "main.css")
         , ("main.js", "main.js")
         ] Wai.Static.<|> Wai.Static.hasPrefix "assets"
diff --git a/fig-web/src/Fig/Web/Secure.hs b/fig-web/src/Fig/Web/Secure.hs
index 6b199c9..b2706dc 100644
--- a/fig-web/src/Fig/Web/Secure.hs
+++ b/fig-web/src/Fig/Web/Secure.hs
@@ -17,7 +17,7 @@ import Fig.Web.Auth
 import qualified Fig.Web.DB as DB
 import qualified Fig.Web.Module.Exchange as Exchange
 import qualified Fig.Web.Module.Redeem as Redeem
-import qualified Fig.Web.Module.Puzzle as Puzzle
+import qualified Fig.Web.Module.Advent as Advent
 
 allBusEvents :: SecureModuleArgs -> BusEventHandlers
 allBusEvents args = busEvents . mconcat $ fmap ($ args)
@@ -54,6 +54,7 @@ app args = do
         [ ("menu", "menu.html")
         , ("soundboard", "soundboard.html")
         , ("throwshade", "throwshade.html")
+        , ("advent", "advent.html")
         , ("main.css", "main.css")
         , ("main.js", "main.js")
         ]
@@ -70,6 +71,6 @@ app args = do
       respondText $ creds.user <> " " <> creds.twitchId
     Exchange.secure args
     Redeem.secure args
-    Puzzle.secure args
+    Advent.secure args
     Sc.notFound do
       respondText "not found"