fig-web: Add leaderboardsHEADmaster

6 files changed, 53 insertions, 1 deletions

diff --git a/Makefile b/Makefile
new file mode 100644
index 0000000..ecf6e37
--- /dev/null
+++ b/Makefile
@@ -0,0 +1,5 @@
+.PHONY: web
+
+web:
+	cabal build all
+	cabal exec fig-web -- --bus-host=shiro --bus-port=32051 public
diff --git a/fig-utils/src/Fig/Utils/DB.hs b/fig-utils/src/Fig/Utils/DB.hs
index e8d4955..16d7c0f 100644
--- a/fig-utils/src/Fig/Utils/DB.hs
+++ b/fig-utils/src/Fig/Utils/DB.hs
@@ -113,3 +113,11 @@ llen key = do
 lindex :: ByteString -> Integer -> Redis.Redis (Maybe ByteString)
 lindex key idx = do
   join . hush <$> Redis.lindex key idx
+
+zadd :: ByteString -> [(Double, ByteString)] -> Redis.Redis ()
+zadd key vals = do
+  void $ Redis.zadd key vals
+
+zrevrange :: ByteString -> Integer -> Integer -> Redis.Redis [(ByteString, Double)]
+zrevrange key start end = do
+  fromMaybe [] . hush <$> Redis.zrevrangeWithscores key start end
diff --git a/fig-web/fig-web.cabal b/fig-web/fig-web.cabal
index e565459..8864679 100644
--- a/fig-web/fig-web.cabal
+++ b/fig-web/fig-web.cabal
@@ -79,6 +79,7 @@ library
     Fig.Web.Module.Debt
     Fig.Web.Module.ShindigsSorting
     Fig.Web.Module.Claim
+    Fig.Web.Module.Leaderboard
 
 executable fig-web
   import: defaults
diff --git a/fig-web/src/Fig/Web/MaudeCode.hs b/fig-web/src/Fig/Web/MaudeCode.hs
index 306ffa7..0eac748 100644
--- a/fig-web/src/Fig/Web/MaudeCode.hs
+++ b/fig-web/src/Fig/Web/MaudeCode.hs
@@ -36,7 +36,7 @@ newtype RequestChatCompletions = RequestChatCompletions
 instance Aeson.FromJSON RequestChatCompletions where
   parseJSON = Aeson.withObject "RequestChatCompletions" \o -> do
     messages :: [Aeson.Object] <- o Aeson..: "messages"
-    msg <- maybe (pure "") (Aeson..: "content") $ lastMaybe messages
+    msg <- maybe (pure "") (Aeson..: "content") $ lastMay messages
     let message = Text.replace "\n" " " msg
     pure RequestChatCompletions{..}
 
diff --git a/fig-web/src/Fig/Web/Module/Leaderboard.hs b/fig-web/src/Fig/Web/Module/Leaderboard.hs
new file mode 100644
index 0000000..1b093a1
--- /dev/null
+++ b/fig-web/src/Fig/Web/Module/Leaderboard.hs
@@ -0,0 +1,36 @@
+module Fig.Web.Module.Leaderboard
+  ( public
+  ) where
+
+import Fig.Prelude
+
+import qualified Lucid as L
+
+import Fig.Web.Utils
+import Fig.Web.Types
+import Fig.Utils.DB (DB)
+import qualified Fig.Utils.DB as DB
+
+leaderboardKey :: ByteString -> ByteString
+leaderboardKey = ("leaderboard:"<>)
+
+fetchLeaderboard :: MonadIO m => DB -> ByteString -> m [(Text, Text, Double)]
+fetchLeaderboard db lid = DB.run db do
+  top <- DB.zrevrange (leaderboardKey lid) 0 (-1)
+  forM top $ \(uid, score) -> do
+    name <- fromMaybe uid <$> DB.hget ("user:properties:" <> uid) "name"
+    pure (decodeUtf8 uid, decodeUtf8 name, score)
+
+public :: PublicModule
+public a = do
+  onGet "/leaderboard/:lid" do
+    lid <- pathParam "lid"
+    top10 <- fetchLeaderboard a.db lid
+    respondHTML do
+      head_ . title_ . L.toHtml $ "LCOLONQ Leaderboard: " <> decodeUtf8 lid
+      body_ do
+        ol_ $ forM_ top10 $ \(_, key, score) -> do
+          li_ . L.toHtml $ key <> ": " <> tshow score
+  onGet "/api/leaderboard/:lid" do
+    lid <- pathParam "lid"
+    respondJSON =<< fetchLeaderboard a.db lid
diff --git a/fig-web/src/Fig/Web/Public.hs b/fig-web/src/Fig/Web/Public.hs
index 8263d90..4d2e05a 100644
--- a/fig-web/src/Fig/Web/Public.hs
+++ b/fig-web/src/Fig/Web/Public.hs
@@ -28,6 +28,7 @@ import qualified Fig.Web.Module.HLS as HLS
 import qualified Fig.Web.Module.TCG as TCG
 import qualified Fig.Web.Module.Debt as Debt
 import qualified Fig.Web.Module.ShindigsSorting as ShindigsSorting
+import qualified Fig.Web.Module.Leaderboard as Leaderboard
 
 allBusEvents :: PublicModuleArgs -> BusEventHandlers
 allBusEvents args = busEvents . mconcat $ fmap ($ args)
@@ -103,6 +104,7 @@ app args = do
     TCG.public args
     Debt.public args
     ShindigsSorting.public args
+    Leaderboard.public args
     websocket $ mconcat
       [ Gizmo.publicWebsockets args
       , Circle.publicWebsockets args