fig-utils: Guile FFI

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 = {