From 2a21b457d71e8cace0db0e3b4913234d25f38aec Mon Sep 17 00:00:00 2001 From: LLLL Colonq Date: Tue, 2 Dec 2025 14:26:48 -0500 Subject: Advent --- fig-utils/csrc/fig.c | 101 +++++++++++++++++++++++++++++-- fig-utils/src/Fig/Utils/FFI.hs | 31 ++++++++-- fig-web/fig-web.cabal | 2 +- fig-web/main/Main.hs | 5 +- fig-web/src/Fig/Web/Module/Advent.hs | 113 +++++++++++++++++++++++++++++++++++ fig-web/src/Fig/Web/Public.hs | 1 + fig-web/src/Fig/Web/Secure.hs | 5 +- 7 files changed, 243 insertions(+), 15 deletions(-) create mode 100644 fig-web/src/Fig/Web/Module/Advent.hs 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 #include +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" -- cgit v1.2.3