diff options
Diffstat (limited to 'fig-web')
| -rw-r--r-- | fig-web/main/Main.hs | 7 | ||||
| -rw-r--r-- | fig-web/src/Fig/Web/Module/User.hs | 50 |
2 files changed, 55 insertions, 2 deletions
diff --git a/fig-web/main/Main.hs b/fig-web/main/Main.hs index a3c798a..7e3d509 100644 --- a/fig-web/main/Main.hs +++ b/fig-web/main/Main.hs @@ -36,6 +36,7 @@ parseCommand = hsubparser $ mconcat data Opts = Opts { busHost :: !Text , busPort :: !Text + , port :: !(Maybe Int) , config :: !FilePath , cmd :: !Command } @@ -44,6 +45,7 @@ parseOpts :: Parser Opts parseOpts = do busHost <- strOption (long "bus-host" <> metavar "HOST" <> help "Address of message bus" <> value "localhost") busPort <- strOption (long "bus-port" <> metavar "PORT" <> help "Message bus port" <> showDefault <> value "32050") + port <- optional $ option auto (long "port" <> metavar "PORT" <> help "Web server port") config <- strOption (long "config" <> metavar "PATH" <> help "Path to config file" <> showDefault <> value "fig-web.toml") cmd <- parseCommand pure Opts{..} @@ -54,7 +56,10 @@ main = do ( fullDesc <> Options.Applicative.header "fig-web - web backends" ) - cfg <- loadConfig opts.config + icfg <- loadConfig opts.config + let cfg = case opts.port of + Nothing -> icfg + Just p -> icfg { Fig.Web.Utils.port = p } case opts.cmd of Public o -> Public.server o cfg (opts.busHost, opts.busPort) Secure o -> Secure.server o cfg (opts.busHost, opts.busPort) diff --git a/fig-web/src/Fig/Web/Module/User.hs b/fig-web/src/Fig/Web/Module/User.hs index e21afcf..62cbdd6 100644 --- a/fig-web/src/Fig/Web/Module/User.hs +++ b/fig-web/src/Fig/Web/Module/User.hs @@ -57,9 +57,27 @@ getUserInfo db uid = do badges <- getTextList db $ "user:badges:" <> uid pure UserInfo{..} +data TalentInfo = TalentInfo + { tid :: Text + , name :: Text + , 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) + case mres of + Just (name, desc) -> pure $ Just TalentInfo{..} + Nothing -> pure Nothing + public :: PublicModule public a = do - -- users + -- legacy user API onGet "/api/user/:name" do name <- Text.toLower <$> pathParam "name" DB.get a.db ("user:" <> encodeUtf8 name) >>= \case @@ -67,6 +85,7 @@ public a = do status status404 respondText "user not found" Just val -> respondText $ decodeUtf8 val + -- username to id mapping onGet "/api/user-id/:name" do name <- pathParam "name" getText a.db ("user-id:" <> encodeUtf8 (Text.toLower name)) >>= \case @@ -74,6 +93,7 @@ public a = do status status404 respondText "username not found" Just val -> respondText val + -- users onGet "/api/user/info/:uid" do -- get everything bundled together uid <- pathParam "uid" info <- getUserInfo a.db uid @@ -107,6 +127,34 @@ public a = do Just img -> do addHeader "Content-Type" "image/png" respondBytes img + -- talents + onGet "/api/talents" do + names <- DB.hgetall a.db "talent:name" + descs <- DB.hgetall a.db "talent:desc" + respondJSON $ Map.intersectionWithKey + (\tid name desc -> TalentInfo{..}) + (Map.fromList $ bimap decodeUtf8 decodeUtf8 <$> Map.toList names) + (Map.fromList $ bimap decodeUtf8 decodeUtf8 <$> Map.toList descs) + onGet "/api/talent/:tid" do + tid <- pathParam "tid" + getTalentInfo a.db tid >>= \case + Nothing -> do + status status404 + respondText "talent not found" + Just t -> respondJSON t + onGet "/api/talent/icon/:tid.png" do + tidpng <- pathParam "tid.png" + case Text.stripSuffix ".png" tidpng of + Nothing -> do + status status400 + respondText "malformed talent icon path" + Just tid -> DB.hget a.db "talent:icon" (encodeUtf8 tid) >>= \case + Nothing -> do + status status404 + respondText "talent not found" + Just img -> do + addHeader "Content-Type" "image/png" + respondBytes img -- badges onGet "/api/badge/:uuid" do uuid <- pathParam "uuid" |