Add TCG

4 files changed, 46 insertions, 1 deletions

diff --git a/fig-web/src/Fig/Web/DB.hs b/fig-web/src/Fig/Web/DB.hs
index 0f600c6..4408d6b 100644
--- a/fig-web/src/Fig/Web/DB.hs
+++ b/fig-web/src/Fig/Web/DB.hs
@@ -97,6 +97,10 @@ rpush (DB c) key val = liftIO $ Redis.runRedis c do
   _ <- Redis.rpush key [val]
   pure ()
 
+lrange :: MonadIO m => DB -> ByteString -> Integer -> Integer -> m [ByteString]
+lrange (DB c) key start end = liftIO $ Redis.runRedis c do
+  fromMaybe [] . hush <$> Redis.lrange key start end
+
 llen :: MonadIO m => DB -> ByteString -> m (Maybe Integer)
 llen (DB c) key = liftIO $ Redis.runRedis c do
   hush <$> Redis.llen key
diff --git a/fig-web/src/Fig/Web/Module/TCG.hs b/fig-web/src/Fig/Web/Module/TCG.hs
new file mode 100644
index 0000000..0636ad7
--- /dev/null
+++ b/fig-web/src/Fig/Web/Module/TCG.hs
@@ -0,0 +1,36 @@
+module Fig.Web.Module.TCG
+  ( public
+  ) where
+
+import Fig.Prelude
+
+import qualified Data.Text as Text
+
+import Fig.Web.Utils
+import Fig.Web.Types
+import qualified Fig.Web.DB as DB
+
+public :: PublicModule
+public a = do
+  onGet "/api/tcg/card/:uuid.png" do
+    uuidpng <- pathParam "uuid.png"
+    case Text.stripSuffix ".png" uuidpng of
+      Nothing -> do
+        status status400
+        respondText "malformed card path"
+      Just uuid -> DB.hget a.db "tcg:cards" (encodeUtf8 uuid) >>= \case
+        Nothing -> do
+          status status404
+          respondText "card does not exist"
+        Just image -> do
+          addHeader "Content-Type" "image/png"
+          respondBytes image
+  onGet "/api/tcg/binder/:userid" do
+    userid <- pathParam "userid"
+    cards <- DB.lrange a.db ("tcg-inventory:" <> userid) 0 (-1)
+    respondHTML do
+      head_ do
+        title_ "LCOLONQ: The Game"
+      body_ do
+        forM_ cards $ \c -> do
+          img_ [src_ $ mconcat ["/api/tcg/card/", decodeUtf8 c, ".png"]]
diff --git a/fig-web/src/Fig/Web/Public.hs b/fig-web/src/Fig/Web/Public.hs
index dafe039..56a9925 100644
--- a/fig-web/src/Fig/Web/Public.hs
+++ b/fig-web/src/Fig/Web/Public.hs
@@ -25,6 +25,7 @@ import qualified Fig.Web.Module.Bells as Bells
 import qualified Fig.Web.Module.User as User
 import qualified Fig.Web.Module.Shader as Shader
 import qualified Fig.Web.Module.HLS as HLS
+import qualified Fig.Web.Module.TCG as TCG
 
 allBusEvents :: PublicModuleArgs -> BusEventHandlers
 allBusEvents args = busEvents . mconcat $ fmap ($ args)
@@ -92,6 +93,7 @@ app args = do
     User.public args
     Shader.public args
     HLS.public args
+    TCG.public args
     websocket $ mconcat
       [ Gizmo.publicWebsockets args
       , Circle.publicWebsockets args
diff --git a/fig-web/src/Fig/Web/Utils.hs b/fig-web/src/Fig/Web/Utils.hs
index 72782d9..9337b12 100644
--- a/fig-web/src/Fig/Web/Utils.hs
+++ b/fig-web/src/Fig/Web/Utils.hs
@@ -10,7 +10,7 @@ module Fig.Web.Utils
   , onGet, onPost, onPut, onDelete
   , status
   , queryParam, queryParamMaybe, formParam, formParamMaybe, pathParam
-  , header
+  , header, addHeader
   , respondBytes, respondText, respondJSON, respondHTMLText, respondHTML, redirect
   , WebsocketHandler
   , websocket
@@ -145,6 +145,9 @@ header h = Sc.header (Text.L.fromStrict h) >>= \case
   Nothing -> pure Nothing
   Just t -> pure . Just $ Text.L.toStrict t
 
+addHeader :: Text -> Text -> Sc.ActionM ()
+addHeader h v = Sc.addHeader (Text.L.fromStrict h) (Text.L.fromStrict v)
+
 respondBytes :: ByteString -> Sc.ActionM ()
 respondBytes = Sc.raw . BS.L.fromStrict