summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--fig-utils/csrc/fig.c43
-rw-r--r--fig-utils/fig-utils.cabal3
-rw-r--r--fig-utils/src/Fig/Utils/FFI.hs23
-rw-r--r--fig-web/fig-web.cabal1
-rw-r--r--fig-web/main/Main.hs8
-rw-r--r--fig-web/src/Fig/Web/DB.hs29
-rw-r--r--fig-web/src/Fig/Web/Module/Puzzle.hs101
-rw-r--r--fig-web/src/Fig/Web/Secure.hs2
-rw-r--r--flake.nix2
9 files changed, 212 insertions, 0 deletions
diff --git a/fig-utils/csrc/fig.c b/fig-utils/csrc/fig.c
new file mode 100644
index 0000000..e828e71
--- /dev/null
+++ b/fig-utils/csrc/fig.c
@@ -0,0 +1,43 @@
+#include <stdio.h>
+#include <libguile.h>
+
+typedef struct check_answer_args {
+ char *code;
+ char *data;
+} check_answer_args;
+SCM check_answer_catch_body(void *data) {
+ check_answer_args *args = (check_answer_args *) data;
+ // SCM handler = scm_c_eval_string(args->code);
+ // 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 check_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);
+}
+
+int check_answer(char **failure, char *code, char *data) {
+ scm_init_guile();
+ check_answer_args args = { .code = code, .data = data };
+ SCM res = scm_c_catch(
+ SCM_BOOL_T,
+ check_answer_catch_body, &args,
+ check_answer_catch_handler, NULL,
+ check_answer_catch_handler, NULL);
+ if (scm_is_integer(res)) {
+ *failure = NULL;
+ return scm_to_int(res);
+ } else {
+ *failure = scm_to_utf8_stringn(res, NULL);
+ return 0;
+ }
+}
diff --git a/fig-utils/fig-utils.cabal b/fig-utils/fig-utils.cabal
index e5bc2c9..e2fc86c 100644
--- a/fig-utils/fig-utils.cabal
+++ b/fig-utils/fig-utils.cabal
@@ -10,11 +10,14 @@ common defaults
library
import: defaults
hs-source-dirs: src
+ c-sources: csrc/fig.c
+ pkgconfig-depends: guile-3.0
exposed-modules:
Fig.Prelude
Fig.Utils
Fig.Utils.Net
Fig.Utils.SExpr
+ Fig.Utils.FFI
build-depends:
base
, aeson
diff --git a/fig-utils/src/Fig/Utils/FFI.hs b/fig-utils/src/Fig/Utils/FFI.hs
new file mode 100644
index 0000000..b5ee80e
--- /dev/null
+++ b/fig-utils/src/Fig/Utils/FFI.hs
@@ -0,0 +1,23 @@
+module Fig.Utils.FFI where
+
+import Fig.Prelude
+
+import Foreign.Ptr (Ptr, nullPtr)
+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
+
+checkAnswer :: Text -> Text -> IO (Either Text Bool)
+checkAnswer tcode tanswer =
+ withCString (unpack tcode) $ \code ->
+ withCString (unpack tanswer) $ \answer ->
+ alloca $ \rerr -> do
+ res <- c_check_answer rerr code answer
+ err <- peek rerr
+ if err == nullPtr
+ then pure . Right $ res /= 0
+ else do
+ msg <- peekCString err
+ pure . Left $ pack msg
diff --git a/fig-web/fig-web.cabal b/fig-web/fig-web.cabal
index 876d47f..4401427 100644
--- a/fig-web/fig-web.cabal
+++ b/fig-web/fig-web.cabal
@@ -73,6 +73,7 @@ library
Fig.Web.Module.User
Fig.Web.Module.Shader
Fig.Web.Module.Redeem
+ Fig.Web.Module.Puzzle
executable fig-web
import: defaults
diff --git a/fig-web/main/Main.hs b/fig-web/main/Main.hs
index 909127e..b1cc006 100644
--- a/fig-web/main/Main.hs
+++ b/fig-web/main/Main.hs
@@ -8,6 +8,7 @@ import Options.Applicative
import Fig.Web.Types
import Fig.Web.Utils
+import qualified Fig.Utils.FFI as FFI
import qualified Fig.Web.Public as Public
import qualified Fig.Web.Secure as Secure
@@ -23,11 +24,13 @@ parseSecureOptions = do
data Command
= Public PublicOptions
| Secure SecureOptions
+ | TestFFI
parseCommand :: Parser Command
parseCommand = hsubparser $ mconcat
[ command "public" $ info (Public <$> parsePublicOptions) (progDesc "Launch the public web server")
, command "secure" $ info (Secure <$> parseSecureOptions) (progDesc "Launch the private web server (intended to be run behind authentication proxy)")
+ , command "testffi" $ info (pure TestFFI) (progDesc "Test the FFI")
]
data Opts = Opts
@@ -55,3 +58,8 @@ main = do
case opts.cmd of
Public o -> Public.server o cfg (opts.busHost, opts.busPort)
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"
+ log $ "result: " <> tshow res
diff --git a/fig-web/src/Fig/Web/DB.hs b/fig-web/src/Fig/Web/DB.hs
index 5a51560..9b1728c 100644
--- a/fig-web/src/Fig/Web/DB.hs
+++ b/fig-web/src/Fig/Web/DB.hs
@@ -2,6 +2,10 @@ module Fig.Web.DB where
import Control.Error.Util (hush)
+import Data.Maybe (mapMaybe)
+import Data.Map.Strict (Map)
+import qualified Data.Map.Strict as Map
+
import qualified Database.Redis as Redis
import Fig.Prelude
@@ -18,6 +22,10 @@ get (DB c) key = liftIO $ Redis.runRedis c do
v <- Redis.get key
pure . join $ hush v
+del :: MonadIO m => DB -> [ByteString] -> m ()
+del (DB c) keys = liftIO $ Redis.runRedis c do
+ void $ Redis.del keys
+
incr :: MonadIO m => DB -> ByteString -> m ()
incr (DB c) key = liftIO $ Redis.runRedis c do
void $ Redis.incr key
@@ -26,11 +34,32 @@ decr :: MonadIO m => DB -> ByteString -> m ()
decr (DB c) key = liftIO $ Redis.runRedis c do
void $ Redis.decr key
+hset :: MonadIO m => DB -> ByteString -> ByteString -> ByteString -> m ()
+hset (DB c) key hkey val = liftIO $ Redis.runRedis c do
+ void $ Redis.hset key hkey val
+
hget :: MonadIO m => DB -> ByteString -> ByteString -> m (Maybe ByteString)
hget (DB c) key hkey = liftIO $ Redis.runRedis c do
v <- Redis.hget key hkey
pure . join $ hush v
+hmset :: MonadIO m => DB -> ByteString -> [(ByteString, ByteString)] -> m ()
+hmset (DB c) key m = liftIO $ Redis.runRedis c do
+ void $ Redis.hmset key m
+
+hmget :: MonadIO m => DB -> ByteString -> [ByteString] -> m (Map ByteString ByteString)
+hmget (DB c) key hk = liftIO $ Redis.runRedis c do
+ Redis.hmget key hk >>= \case
+ Left _ -> pure Map.empty
+ Right vals -> do
+ pure . Map.fromList . mapMaybe (\(a, mb) -> mb >>= \b -> Just (a, b)) $ zip hk vals
+
+hgetall :: MonadIO m => DB -> ByteString -> m (Map ByteString ByteString)
+hgetall (DB c) key = liftIO $ Redis.runRedis c do
+ Redis.hgetall key >>= \case
+ Left _ -> pure Map.empty
+ Right m -> pure $ Map.fromList m
+
hkeys :: MonadIO m => DB -> ByteString -> m (Maybe [ByteString])
hkeys (DB c) key = liftIO $ Redis.runRedis c do
hush <$> Redis.hkeys key
diff --git a/fig-web/src/Fig/Web/Module/Puzzle.hs b/fig-web/src/Fig/Web/Module/Puzzle.hs
new file mode 100644
index 0000000..ff441eb
--- /dev/null
+++ b/fig-web/src/Fig/Web/Module/Puzzle.hs
@@ -0,0 +1,101 @@
+module Fig.Web.Module.Puzzle
+ ( secure
+ ) where
+
+import Fig.Prelude
+
+import qualified Data.Map.Strict as Map
+import qualified Data.Aeson as Aeson
+import qualified Data.UUID as UUID
+import qualified Data.UUID.V4 as UUID
+
+import Fig.Web.Utils
+import Fig.Web.Types
+import Fig.Web.Auth
+import Fig.Web.DB
+
+data Puzzle = Puzzle
+ { pid :: Text
+ , name :: Text
+ , author :: Text
+ , authorid :: Text
+ , body :: Text
+ , checker :: Text
+ } deriving (Show, Generic)
+instance Aeson.ToJSON Puzzle
+
+newPuzzlePid :: forall m. (MonadIO m, MonadCatch m) => m Text
+newPuzzlePid = do
+ uuid <- liftIO UUID.nextRandom
+ pure $ UUID.toText uuid
+
+puzzlePidKey :: Text -> ByteString
+puzzlePidKey pid = "puzzle:" <> encodeUtf8 pid
+
+puzzleKey :: Puzzle -> ByteString
+puzzleKey p = puzzlePidKey p.pid
+
+savePuzzle :: MonadIO m => DB -> Puzzle -> m ()
+savePuzzle db p = do
+ sadd db "puzzleids" [encodeUtf8 p.pid]
+ hmset db (puzzleKey p)
+ [ ("pid", encodeUtf8 p.pid)
+ , ("name", encodeUtf8 p.name)
+ , ("author", encodeUtf8 p.author)
+ , ("authorid", encodeUtf8 p.authorid)
+ , ("body", encodeUtf8 p.body)
+ , ("checker", encodeUtf8 p.checker)
+ ]
+
+loadPuzzle :: MonadIO m => DB -> Text -> m (Maybe Puzzle)
+loadPuzzle db p = do
+ m <- hgetall db $ puzzlePidKey p
+ pure $ do
+ let field nm = decodeUtf8 <$> Map.lookup nm m
+ pid <- field "pid"
+ if pid == p
+ then do
+ name <- field "name"
+ author <- field "author"
+ authorid <- field "authorid"
+ body <- field "body"
+ checker <- field "checker"
+ Just Puzzle {..}
+ else Nothing
+
+deletePuzzle :: MonadIO m => DB -> Text -> m ()
+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
+ Nothing -> pure []
+ Just xs -> pure $ decodeUtf8 <$> xs
+
+secure :: SecureModule
+secure a = do
+ onGet "/api/puzzle" 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"
+ let author = creds.user
+ let authorid = creds.twitchId
+ pid <- newPuzzlePid
+ log $ "pid: " <> tshow pid
+ name <- formParam "name"
+ body <- formParam "body"
+ checker <- formParam "checker"
+ savePuzzle a.db Puzzle {..}
+ respondText pid
diff --git a/fig-web/src/Fig/Web/Secure.hs b/fig-web/src/Fig/Web/Secure.hs
index 303089b..20b16c5 100644
--- a/fig-web/src/Fig/Web/Secure.hs
+++ b/fig-web/src/Fig/Web/Secure.hs
@@ -17,6 +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
allBusEvents :: SecureModuleArgs -> BusEventHandlers
allBusEvents args = busEvents . mconcat $ fmap ($ args)
@@ -68,5 +69,6 @@ app args = do
respondText $ creds.user <> " " <> creds.twitchId
Exchange.secure args
Redeem.secure args
+ Puzzle.secure args
Sc.notFound do
respondText "not found"
diff --git a/flake.nix b/flake.nix
index 7515ee4..eb2fa94 100644
--- a/flake.nix
+++ b/flake.nix
@@ -414,6 +414,8 @@
haskellPackages.cabal-install
haskellPackages.haskell-language-server
pkgs.nodejs
+ pkgs.guile
+ pkgs.pkg-config
];
};
packages.x86_64-linux = {
generated by cgit v1.2.3 (git 2.25.1) at 2026-05-09 12:52:30 +0000