summaryrefslogtreecommitdiff
path: root/fig-web
diff options
context:
space:
mode:
Diffstat (limited to 'fig-web')
-rw-r--r--fig-web/fig-web.cabal2
-rw-r--r--fig-web/src/Fig/Web/DB.hs99
-rw-r--r--fig-web/src/Fig/Web/Module/Advent.hs27
-rw-r--r--fig-web/src/Fig/Web/Module/Bells.hs4
-rw-r--r--fig-web/src/Fig/Web/Module/Debt.hs2
-rw-r--r--fig-web/src/Fig/Web/Module/Gizmo.hs4
-rw-r--r--fig-web/src/Fig/Web/Module/HLS.hs9
-rw-r--r--fig-web/src/Fig/Web/Module/Misc.hs2
-rw-r--r--fig-web/src/Fig/Web/Module/Sentiment.hs6
-rw-r--r--fig-web/src/Fig/Web/Module/Shader.hs2
-rw-r--r--fig-web/src/Fig/Web/Module/TCG.hs6
-rw-r--r--fig-web/src/Fig/Web/Module/User.hs99
12 files changed, 161 insertions, 101 deletions
diff --git a/fig-web/fig-web.cabal b/fig-web/fig-web.cabal
index 47f41b1..7a1f54c 100644
--- a/fig-web/fig-web.cabal
+++ b/fig-web/fig-web.cabal
@@ -3,7 +3,7 @@ name: fig-web
version: 0.1.0.0
common defaults
- ghc-options: -Wall
+ ghc-options: -Wall -threaded
default-language: GHC2021
default-extensions: NoImplicitPrelude PackageImports LambdaCase MultiWayIf OverloadedStrings OverloadedLists OverloadedRecordDot DuplicateRecordFields RecordWildCards NoFieldSelectors BlockArguments ViewPatterns TypeFamilies DataKinds GADTs
diff --git a/fig-web/src/Fig/Web/DB.hs b/fig-web/src/Fig/Web/DB.hs
index fc3e2fb..fb5a98c 100644
--- a/fig-web/src/Fig/Web/DB.hs
+++ b/fig-web/src/Fig/Web/DB.hs
@@ -17,99 +17,98 @@ connect cfg = liftIO $ DB <$> Redis.checkedConnect Redis.defaultConnectInfo
{ Redis.connectHost = unpack cfg.dbHost
}
-get :: MonadIO m => DB -> ByteString -> m (Maybe ByteString)
-get (DB c) key = liftIO $ Redis.runRedis c do
+run :: MonadIO m => DB -> Redis.Redis a -> m a
+run (DB c) f = liftIO $ Redis.runRedis c f
+
+get :: ByteString -> Redis.Redis (Maybe ByteString)
+get key = do
v <- Redis.get key
pure . join $ hush v
-del :: MonadIO m => DB -> [ByteString] -> m ()
-del (DB c) keys = liftIO $ Redis.runRedis c do
+del :: [ByteString] -> Redis.Redis ()
+del keys = do
void $ Redis.del keys
-incr :: MonadIO m => DB -> ByteString -> m ()
-incr (DB c) key = liftIO $ Redis.runRedis c do
+incr :: ByteString -> Redis.Redis ()
+incr key = do
void $ Redis.incr key
-decr :: MonadIO m => DB -> ByteString -> m ()
-decr (DB c) key = liftIO $ Redis.runRedis c do
+decr :: ByteString -> Redis.Redis ()
+decr key = do
void $ Redis.decr key
-hset :: MonadIO m => DB -> ByteString -> ByteString -> ByteString -> m ()
-hset (DB c) key hkey val = liftIO $ Redis.runRedis c do
+hset :: ByteString -> ByteString -> ByteString -> Redis.Redis ()
+hset key hkey val = 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
+hget :: ByteString -> ByteString -> Redis.Redis (Maybe ByteString)
+hget key hkey = do
v <- Redis.hget key hkey
pure . join $ hush v
-hdel :: MonadIO m => DB -> ByteString -> ByteString -> m ()
-hdel (DB c) key hkey = liftIO $ Redis.runRedis c do
- _ <- Redis.hdel key [hkey]
- pure ()
+hdel :: ByteString -> ByteString -> Redis.Redis ()
+hdel key hkey = do
+ void $ Redis.hdel key [hkey]
-hmset :: MonadIO m => DB -> ByteString -> [(ByteString, ByteString)] -> m ()
-hmset (DB c) key m = liftIO $ Redis.runRedis c do
+hmset :: ByteString -> [(ByteString, ByteString)] -> Redis.Redis ()
+hmset key m = 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
+hmget :: ByteString -> [ByteString] -> Redis.Redis (Map ByteString ByteString)
+hmget key hk = 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
+hgetall :: ByteString -> Redis.Redis (Map ByteString ByteString)
+hgetall key = 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
+hkeys :: ByteString -> Redis.Redis (Maybe [ByteString])
+hkeys key = do
hush <$> Redis.hkeys key
-hvals :: MonadIO m => DB -> ByteString -> m (Maybe [ByteString])
-hvals (DB c) key = liftIO $ Redis.runRedis c do
+hvals :: ByteString -> Redis.Redis (Maybe [ByteString])
+hvals key = do
hush <$> Redis.hvals key
-sadd :: MonadIO m => DB -> ByteString -> [ByteString] -> m ()
-sadd (DB c) key skeys = liftIO $ Redis.runRedis c do
- _ <- Redis.sadd key skeys
- pure ()
+sadd :: ByteString -> [ByteString] -> Redis.Redis ()
+sadd key skeys = do
+ void $ Redis.sadd key skeys
-srem :: MonadIO m => DB -> ByteString -> [ByteString] -> m ()
-srem (DB c) key skeys = liftIO $ Redis.runRedis c do
- _ <- Redis.srem key skeys
- pure ()
+srem :: ByteString -> [ByteString] -> Redis.Redis ()
+srem key skeys = do
+ void $ Redis.srem key skeys
-smembers :: MonadIO m => DB -> ByteString -> m (Maybe [ByteString])
-smembers (DB c) key = liftIO $ Redis.runRedis c do
+smembers :: ByteString -> Redis.Redis (Maybe [ByteString])
+smembers key = do
hush <$> Redis.smembers key
-sismember :: MonadIO m => DB -> ByteString -> ByteString -> m Bool
-sismember (DB c) key skey = liftIO $ Redis.runRedis c do
+sismember :: ByteString -> ByteString -> Redis.Redis Bool
+sismember key skey = do
Redis.sismember key skey >>= hush >>> \case
Just x -> pure x
Nothing -> pure False
-lpop :: MonadIO m => DB -> ByteString -> m (Maybe ByteString)
-lpop (DB c) key = liftIO $ Redis.runRedis c do
+lpop :: ByteString -> Redis.Redis (Maybe ByteString)
+lpop key = do
join . hush <$> Redis.lpop key
-rpush :: MonadIO m => DB -> ByteString -> ByteString -> m ()
-rpush (DB c) key val = liftIO $ Redis.runRedis c do
- _ <- Redis.rpush key [val]
- pure ()
+rpush :: ByteString -> ByteString -> Redis.Redis ()
+rpush key val = do
+ void $ Redis.rpush key [val]
-lrange :: MonadIO m => DB -> ByteString -> Integer -> Integer -> m [ByteString]
-lrange (DB c) key start end = liftIO $ Redis.runRedis c do
+lrange :: ByteString -> Integer -> Integer -> Redis.Redis [ByteString]
+lrange key start end = 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
+llen :: ByteString -> Redis.Redis (Maybe Integer)
+llen key = do
hush <$> Redis.llen key
-lindex :: MonadIO m => DB -> ByteString -> Integer -> m (Maybe ByteString)
-lindex (DB c) key idx = liftIO $ Redis.runRedis c do
+lindex :: ByteString -> Integer -> Redis.Redis (Maybe ByteString)
+lindex key idx = do
join . hush <$> Redis.lindex key idx
diff --git a/fig-web/src/Fig/Web/Module/Advent.hs b/fig-web/src/Fig/Web/Module/Advent.hs
index 4b73ba0..f46cc6c 100644
--- a/fig-web/src/Fig/Web/Module/Advent.hs
+++ b/fig-web/src/Fig/Web/Module/Advent.hs
@@ -19,10 +19,12 @@ secure :: SecureModule
secure a = do
onGet "/advent/puzzle/:pid" $ authed a \creds -> do
pid :: Integer <- pathParam "pid"
- mpart1body <- fmap decodeUtf8 <$> DB.get a.db (keybase pid "part1" "body")
- part1solved <- DB.sismember a.db (keybase pid "part1" "solvers") (encodeUtf8 creds.twitchId)
- mpart2body <- fmap decodeUtf8 <$> DB.get a.db (keybase pid "part2" "body")
- part2solved <- DB.sismember a.db (keybase pid "part2" "solvers") (encodeUtf8 creds.twitchId)
+ (mpart1body, part1solved, mpart2body, part2solved) <- DB.run a.db do
+ mpart1body <- fmap decodeUtf8 <$> DB.get (keybase pid "part1" "body")
+ part1solved <- DB.sismember (keybase pid "part1" "solvers") (encodeUtf8 creds.twitchId)
+ mpart2body <- fmap decodeUtf8 <$> DB.get (keybase pid "part2" "body")
+ part2solved <- DB.sismember (keybase pid "part2" "solvers") (encodeUtf8 creds.twitchId)
+ pure (mpart1body, part1solved, mpart2body, part2solved)
case (mpart1body, mpart2body) of
(Just part1body, Just part2body) -> do
respondHTML do
@@ -63,11 +65,11 @@ secure a = do
pid :: Integer <- pathParam "pid"
part <- pathParam "part"
let bstid = encodeUtf8 creds.twitchId
- DB.hget a.db (keybase pid part "inputs") bstid >>= \case
+ DB.run a.db (DB.hget (keybase pid part "inputs") bstid) >>= \case
Just inp ->
respondText $ decodeUtf8 inp
Nothing -> do
- DB.get a.db (keybase pid part "generator") >>= \case
+ DB.run a.db (DB.get (keybase pid part "generator")) >>= \case
Nothing -> do
status status404
respondText "the puzzle has no generator associated with it. tell clonk please!"
@@ -81,16 +83,19 @@ secure a = do
, err
]
Right (inp, ans) -> do
- DB.hset a.db (keybase pid part "inputs") bstid $ encodeUtf8 inp
- DB.hset a.db (keybase pid part "answers") bstid $ encodeUtf8 ans
+ DB.run a.db do
+ DB.hset (keybase pid part "inputs") bstid $ encodeUtf8 inp
+ DB.hset (keybase pid part "answers") bstid $ encodeUtf8 ans
respondText inp
onPost "/advent/puzzle/:pid/:part/submit" $ authed a \creds -> do
pid :: Integer <- pathParam "pid"
part <- pathParam "part"
let bstid = encodeUtf8 creds.twitchId
actual <- formParam "answer"
- mcheck <- fmap decodeUtf8 <$> DB.get a.db (keybase pid part "checker")
- manswer <- DB.hget a.db (keybase pid part "answers") bstid
+ (mcheck, manswer) <- DB.run a.db do
+ mcheck <- fmap decodeUtf8 <$> DB.get (keybase pid part "checker")
+ manswer <- DB.hget (keybase pid part "answers") bstid
+ pure (mcheck, manswer)
case (mcheck, manswer) of
(Just check, Just expected) -> do
FFI.checkAnswer check actual (decodeUtf8 expected) >>= \case
@@ -103,7 +108,7 @@ secure a = do
Right False -> do
respondText "that's the wrong answer, try again!"
Right True -> do
- DB.sadd a.db (keybase pid part "solvers") [encodeUtf8 creds.twitchId]
+ DB.run a.db $ DB.sadd (keybase pid part "solvers") [encodeUtf8 creds.twitchId]
respondText "that's the right answer! nice work!"
(Nothing, _) -> do
status status500
diff --git a/fig-web/src/Fig/Web/Module/Bells.hs b/fig-web/src/Fig/Web/Module/Bells.hs
index 1ae6dce..f4f8112 100644
--- a/fig-web/src/Fig/Web/Module/Bells.hs
+++ b/fig-web/src/Fig/Web/Module/Bells.hs
@@ -12,14 +12,14 @@ import qualified Fig.Web.DB as DB
public :: PublicModule
public a = do
onGet "/api/songs" do
- DB.hvals a.db "songnames" >>= \case
+ DB.run a.db (DB.hvals "songnames") >>= \case
Nothing -> do
status status404
respondText "no sounds found :("
Just songs -> respondText . pretty . SExprList @Void $ SExprString . decodeUtf8 <$> songs
onGet "/api/song/:hash" do
hash <- pathParam "hash"
- DB.hget a.db "songnotes" hash >>= \case
+ DB.run a.db (DB.hget "songnotes" hash) >>= \case
Nothing -> do
status status404
respondText "song not found"
diff --git a/fig-web/src/Fig/Web/Module/Debt.hs b/fig-web/src/Fig/Web/Module/Debt.hs
index 883a394..643f99f 100644
--- a/fig-web/src/Fig/Web/Module/Debt.hs
+++ b/fig-web/src/Fig/Web/Module/Debt.hs
@@ -14,7 +14,7 @@ import qualified Fig.Web.DB as DB
public :: PublicModule
public a = do
onGet "/api/debt" do
- debts <- DB.hgetall a.db "debt"
+ debts <- DB.run a.db $ DB.hgetall "debt"
respondJSON
$ Map.fromList
$ mapMaybe (\(k, v) -> (decodeUtf8 k,) <$> readMaybe @Double (unpack $ decodeUtf8 v))
diff --git a/fig-web/src/Fig/Web/Module/Gizmo.hs b/fig-web/src/Fig/Web/Module/Gizmo.hs
index bca23d5..70078fb 100644
--- a/fig-web/src/Fig/Web/Module/Gizmo.hs
+++ b/fig-web/src/Fig/Web/Module/Gizmo.hs
@@ -20,13 +20,13 @@ public :: PublicModule
public a = do
onGet "/api/gizmo" do
buf <- queryParam "buf"
- DB.hget a.db "gizmos" buf >>= \case
+ DB.run a.db (DB.hget "gizmos" buf) >>= \case
Nothing -> do
status status404
respondText "gizmo does not exist"
Just html -> respondHTMLText $ decodeUtf8 html
onGet "/api/gizmo/list" do
- gizmos <- maybe [] (fmap decodeUtf8) <$> DB.hkeys a.db "gizmos"
+ gizmos <- maybe [] (fmap decodeUtf8) <$> DB.run a.db (DB.hkeys "gizmos")
respondText $ Text.unlines gizmos
publicWebsockets :: PublicWebsockets
diff --git a/fig-web/src/Fig/Web/Module/HLS.hs b/fig-web/src/Fig/Web/Module/HLS.hs
index 0eb479f..66242e5 100644
--- a/fig-web/src/Fig/Web/Module/HLS.hs
+++ b/fig-web/src/Fig/Web/Module/HLS.hs
@@ -13,8 +13,11 @@ import qualified Fig.Web.DB as DB
public :: PublicModule
public a = do
onGet "/api/hls.m3u8" do
- mseq :: Maybe Integer <- ((readMaybe . unpack . decodeUtf8)=<<) <$> DB.get a.db "hlssequence"
- mlen <- DB.llen a.db "hlssamples"
+ (mseq, mlen) <- DB.run a.db do
+ mseq :: Maybe Integer <- ((readMaybe . unpack . decodeUtf8)=<<)
+ <$> DB.get "hlssequence"
+ mlen <- DB.llen "hlssamples"
+ pure (mseq, mlen)
case (mseq, mlen) of
(Just seq, Just len) -> do
let startingSeq = seq - (len - 1)
@@ -34,7 +37,7 @@ public a = do
pure ()
onGet "/api/hls/:num/sample.aac" do
num <- pathParam "num"
- DB.lindex a.db "hlssamples" num >>= \case
+ DB.run a.db (DB.lindex "hlssamples" num) >>= \case
Nothing -> do
status status404
respondText "sample not found"
diff --git a/fig-web/src/Fig/Web/Module/Misc.hs b/fig-web/src/Fig/Web/Module/Misc.hs
index 1bbb2ba..c7ca250 100644
--- a/fig-web/src/Fig/Web/Module/Misc.hs
+++ b/fig-web/src/Fig/Web/Module/Misc.hs
@@ -16,7 +16,7 @@ public :: PublicModule
public a = do
onGet "/api/motd" do
log "getting motd"
- DB.get a.db "motd" >>= \case
+ DB.run a.db (DB.get "motd") >>= \case
Nothing -> respondText ""
Just val -> respondText $ decodeUtf8 val
onGet "/api/catchphrase" do
diff --git a/fig-web/src/Fig/Web/Module/Sentiment.hs b/fig-web/src/Fig/Web/Module/Sentiment.hs
index 6b99873..41f90f3 100644
--- a/fig-web/src/Fig/Web/Module/Sentiment.hs
+++ b/fig-web/src/Fig/Web/Module/Sentiment.hs
@@ -11,11 +11,11 @@ import qualified Fig.Web.DB as DB
public :: PublicModule
public a = do
onGet "/api/sentiment" do
- s <- DB.get a.db "sentiment" >>= \case
+ s <- DB.run a.db (DB.get "sentiment") >>= \case
Nothing -> pure "0"
Just x -> pure x
respondText $ decodeUtf8 s
onPost "/api/sentiment/green" do
- DB.incr a.db "sentiment"
+ DB.run a.db $ DB.incr "sentiment"
onPost "/api/sentiment/red" do
- DB.decr a.db "sentiment"
+ DB.run a.db $ DB.decr "sentiment"
diff --git a/fig-web/src/Fig/Web/Module/Shader.hs b/fig-web/src/Fig/Web/Module/Shader.hs
index cb21d30..e5dfc95 100644
--- a/fig-web/src/Fig/Web/Module/Shader.hs
+++ b/fig-web/src/Fig/Web/Module/Shader.hs
@@ -11,7 +11,7 @@ import qualified Fig.Web.DB as DB
public :: PublicModule
public a = do
onGet "/api/shader" do
- DB.get a.db "shader" >>= \case
+ DB.run a.db (DB.get "shader") >>= \case
Nothing -> do
status status404
respondText "no shader present"
diff --git a/fig-web/src/Fig/Web/Module/TCG.hs b/fig-web/src/Fig/Web/Module/TCG.hs
index 274fd4b..e57cb28 100644
--- a/fig-web/src/Fig/Web/Module/TCG.hs
+++ b/fig-web/src/Fig/Web/Module/TCG.hs
@@ -26,7 +26,7 @@ public a = do
-- liftIO $ Dir.createDirectoryIfMissing True cardDir
let cardPath = cardDir <> unpack uuid <> ".png"
liftIO (Dir.doesFileExist cardPath) >>= \case
- False -> DB.hget a.db "tcg:cards" (encodeUtf8 uuid) >>= \case
+ False -> DB.run a.db (DB.hget "tcg:cards" $ encodeUtf8 uuid) >>= \case
Nothing -> do
status status404
respondText "card does not exist"
@@ -34,7 +34,7 @@ public a = do
liftIO $ Dir.createDirectoryIfMissing True cardDir
liftIO $ BS.writeFile cardPath image
log $ "Deleting card from Redis: " <> uuid
- DB.hdel a.db "tcg:cards" $ encodeUtf8 uuid
+ DB.run a.db $ DB.hdel "tcg:cards" $ encodeUtf8 uuid
addHeader "Content-Type" "image/png"
respondBytes image
True -> do
@@ -43,7 +43,7 @@ public a = do
respondBytes image
onGet "/api/tcg/binder/:userid" do
userid <- pathParam "userid"
- cards <- take 20 <$> DB.lrange a.db ("tcg-inventory:" <> userid) 0 (-1)
+ cards <- take 20 <$> DB.run a.db (DB.lrange ("tcg-inventory:" <> userid) 0 (-1))
respondHTML do
head_ do
title_ "LCOLONQ: The Game"
diff --git a/fig-web/src/Fig/Web/Module/User.hs b/fig-web/src/Fig/Web/Module/User.hs
index 62cbdd6..e695aeb 100644
--- a/fig-web/src/Fig/Web/Module/User.hs
+++ b/fig-web/src/Fig/Web/Module/User.hs
@@ -10,24 +10,27 @@ import qualified Data.ByteString.Char8 as BS.C8
import qualified Data.Map.Strict as Map
import qualified Data.Aeson as Aeson
+import qualified Database.Redis as Redis
+
import Fig.Web.Utils
import Fig.Web.Types
import qualified Fig.Web.DB as DB
getText :: MonadIO m => DB -> ByteString -> m (Maybe Text)
getText db key = do
- DB.get db key >>= \case
+ DB.run db (DB.get key) >>= \case
Nothing -> pure Nothing
Just v -> pure . eitherToMaybe $ decodeUtf8' v
getTextList :: MonadIO m => DB -> ByteString -> m [Text]
getTextList db key = do
- xs <- DB.lrange db key 0 (-1)
- pure $ mapMaybe (eitherToMaybe . decodeUtf8') xs
+ DB.run db $ DB.smembers key >>= \case
+ Nothing -> pure []
+ Just xs -> pure $ mapMaybe (eitherToMaybe . decodeUtf8') xs
getTextValuedMap :: MonadIO m => DB -> ByteString -> m (Map.Map Text Text)
getTextValuedMap db key = do
- vs <- Map.toList <$> DB.hgetall db key
+ vs <- Map.toList <$> DB.run db (DB.hgetall key)
pure . Map.fromList $ flip mapMaybe vs \(k, v) -> do
tk <- eitherToMaybe $ decodeUtf8' k
tv <- eitherToMaybe $ decodeUtf8' v
@@ -35,7 +38,7 @@ getTextValuedMap db key = do
getIntegerValuedMap :: MonadIO m => DB -> ByteString -> m (Map.Map Text Integer)
getIntegerValuedMap db key = do
- vs <- Map.toList <$> DB.hgetall db key
+ vs <- Map.toList <$> DB.run db (DB.hgetall key)
pure . Map.fromList $ flip mapMaybe vs \(k, v) -> do
tk <- eitherToMaybe $ decodeUtf8' k
(iv, _) <- BS.C8.readInteger v
@@ -48,7 +51,6 @@ data UserInfo = UserInfo
, badges :: [Text]
} deriving Generic
instance Aeson.ToJSON UserInfo
-
getUserInfo :: MonadIO m => DB -> ByteString -> m UserInfo
getUserInfo db uid = do
stats <- getIntegerValuedMap db $ "user:stats:" <> uid
@@ -63,24 +65,53 @@ data TalentInfo = TalentInfo
, desc :: Text
} deriving Generic
instance Aeson.ToJSON TalentInfo
-
getTalentInfo :: MonadIO m => DB -> Text -> m (Maybe TalentInfo)
getTalentInfo db tid = do
- mnm <- DB.hget db "talent:name" $ encodeUtf8 tid
- mdesc <- DB.hget db "talent:desc" $ encodeUtf8 tid
- let mres = (,)
- <$> (eitherToMaybe . decodeUtf8' =<< mnm)
- <*> (eitherToMaybe . decodeUtf8' =<< mdesc)
+ let eid = encodeUtf8 tid
+ mres <- DB.run db do
+ mnm <- (eitherToMaybe . decodeUtf8' =<<)
+ <$> DB.hget "talent:name" eid
+ mres <- (eitherToMaybe . decodeUtf8' =<<)
+ <$> DB.hget "talent:desc" eid
+ pure (mnm, mres)
case mres of
- Just (name, desc) -> pure $ Just TalentInfo{..}
- Nothing -> pure Nothing
+ (Just name, Just desc) -> pure $ Just TalentInfo{..}
+ _ -> pure Nothing
+
+data BadgeInfo = BadgeInfo
+ { bid :: Text
+ , name :: Text
+ , desc :: Text
+ , mode :: Text -- either "text" or "icon"
+ , text :: Maybe Text -- if mode is text, the text to display
+ } deriving (Show, Generic)
+instance Aeson.ToJSON BadgeInfo
+getBadgeInfoInner :: Text -> Redis.Redis (Maybe BadgeInfo)
+getBadgeInfoInner bid = do
+ let eid = encodeUtf8 bid
+ mres <- do
+ mnm <- (eitherToMaybe . decodeUtf8' =<<) <$> DB.hget "badge:name" eid
+ mdesc <- (eitherToMaybe . decodeUtf8' =<<) <$> DB.hget "badge:desc" eid
+ mmode <- (eitherToMaybe . decodeUtf8' =<<) <$> DB.hget "badge:mode" eid
+ pure (mnm, mdesc, mmode)
+ case mres of
+ (Just name, Just desc, Just mode@"icon") ->
+ let text = Nothing in pure $ Just BadgeInfo{..}
+ (Just name, Just desc, Just mode) -> do
+ text <- (eitherToMaybe . decodeUtf8' =<<) <$> DB.hget "badge:text" eid
+ case text of
+ Just _ -> pure $ Just BadgeInfo{..}
+ _ -> pure Nothing
+ _ -> pure Nothing
+getBadgeInfo :: MonadIO m => DB -> Text -> m (Maybe BadgeInfo)
+getBadgeInfo db bid = DB.run db $ getBadgeInfoInner bid
public :: PublicModule
public a = do
-- legacy user API
onGet "/api/user/:name" do
name <- Text.toLower <$> pathParam "name"
- DB.get a.db ("user:" <> encodeUtf8 name) >>= \case
+ DB.run a.db (DB.get $ "user:" <> encodeUtf8 name) >>= \case
Nothing -> do
status status404
respondText "user not found"
@@ -113,14 +144,18 @@ public a = do
respondJSON =<< getTextValuedMap a.db ("user:properties:" <> uid)
onGet "/api/user/badges/:uid" do
uid <- pathParam "uid"
- respondJSON =<< getTextList a.db ("user:badges:" <> uid)
+ bids <- getTextList a.db ("user:badges:" <> uid)
+ log $ tshow bids
+ binfo <- DB.run a.db $ catMaybes <$> mapM getBadgeInfoInner bids
+ log $ tshow binfo
+ respondJSON binfo
onGet "/api/user/avatar/:uid.png" do
uuidpng <- pathParam "uid.png"
case Text.stripSuffix ".png" uuidpng of
Nothing -> do
status status400
respondText "malformed user avatar path"
- Just uid -> DB.get a.db ("user:avatar:" <> encodeUtf8 uid) >>= \case
+ Just uid -> DB.run a.db (DB.get $ "user:avatar:" <> encodeUtf8 uid) >>= \case
Nothing -> do
addHeader "Content-Type" "image/png"
respondBytes "\137PNG\r\n\SUB\n\NUL\NUL\NUL\rIHDR\NUL\NUL\NUL\STX\NUL\NUL\NUL\STX\b\ACK\NUL\NUL\NULr\182\r$\NUL\NUL\NUL\SOHsRGB\NUL\174\206\FS\233\NUL\NUL\NUL\SUBIDAT\b\153cd``\248\207T)\206\192\192T)\254\159\129\129\225?\NUL\RS\188\EOT#\137b%\ACK\NUL\NUL\NUL\NULIEND\174B`\130"
@@ -129,8 +164,9 @@ public a = do
respondBytes img
-- talents
onGet "/api/talents" do
- names <- DB.hgetall a.db "talent:name"
- descs <- DB.hgetall a.db "talent:desc"
+ (names, descs) <- DB.run a.db $ (,)
+ <$> DB.hgetall "talent:name"
+ <*> DB.hgetall "talent:desc"
respondJSON $ Map.intersectionWithKey
(\tid name desc -> TalentInfo{..})
(Map.fromList $ bimap decodeUtf8 decodeUtf8 <$> Map.toList names)
@@ -148,7 +184,7 @@ public a = do
Nothing -> do
status status400
respondText "malformed talent icon path"
- Just tid -> DB.hget a.db "talent:icon" (encodeUtf8 tid) >>= \case
+ Just tid -> DB.run a.db (DB.hget "talent:icon" $ encodeUtf8 tid) >>= \case
Nothing -> do
status status404
respondText "talent not found"
@@ -156,6 +192,23 @@ public a = do
addHeader "Content-Type" "image/png"
respondBytes img
-- badges
- onGet "/api/badge/:uuid" do
- uuid <- pathParam "uuid"
- respondJSON =<< getTextList a.db ("badge:" <> uuid)
+ onGet "/api/badge/:bid" do
+ bid <- pathParam "bid"
+ getBadgeInfo a.db bid >>= \case
+ Nothing -> do
+ status status404
+ respondText "badge not found"
+ Just b -> respondJSON b
+ onGet "/api/badge/icon/:bid.png" do
+ bidpng <- pathParam "bid.png"
+ case Text.stripSuffix ".png" bidpng of
+ Nothing -> do
+ status status400
+ respondText "malformed badge icon path"
+ Just bid -> DB.run a.db (DB.hget "badge:icon" $ encodeUtf8 bid) >>= \case
+ Nothing -> do
+ status status404
+ respondText "badge does not have an icon"
+ Just img -> do
+ addHeader "Content-Type" "image/png"
+ respondBytes img
generated by cgit v1.2.3 (git 2.25.1) at 2026-05-09 07:42:06 +0000