fig-utils: Guile FFI

5 files changed, 141 insertions, 0 deletions

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"