diff options
| -rw-r--r-- | fig-frontend/main/Main.hs | 17 | ||||
| -rw-r--r-- | fig-frontend/src/Fig/Frontend.hs | 58 | ||||
| -rw-r--r-- | fig-frontend/src/Fig/Frontend/DB.hs | 9 | ||||
| -rw-r--r-- | flake.nix | 12 |
4 files changed, 63 insertions, 33 deletions
diff --git a/fig-frontend/main/Main.hs b/fig-frontend/main/Main.hs index 47d10ab..7db5efe 100644 --- a/fig-frontend/main/Main.hs +++ b/fig-frontend/main/Main.hs @@ -1,3 +1,5 @@ +{-# Language ApplicativeDo #-} + module Main where import Fig.Prelude @@ -7,13 +9,18 @@ import Options.Applicative import Fig.Frontend import Fig.Frontend.Utils -newtype Opts = Opts - { config :: FilePath +data Opts = Opts + { busHost :: Text + , busPort :: Text + , config :: FilePath } parseOpts :: Parser Opts -parseOpts = Opts - <$> strOption (long "config" <> metavar "PATH" <> help "Path to config file" <> showDefault <> value "fig-frontend.toml") +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") + config <- strOption (long "config" <> metavar "PATH" <> help "Path to config file" <> showDefault <> value "fig-frontend.toml") + pure Opts{..} main :: IO () main = do @@ -22,4 +29,4 @@ main = do <> header "fig-frontend - public-facing web applications" ) cfg <- loadConfig opts.config - server cfg + server cfg (opts.busHost, opts.busPort) diff --git a/fig-frontend/src/Fig/Frontend.hs b/fig-frontend/src/Fig/Frontend.hs index fd2754c..a6ec8dd 100644 --- a/fig-frontend/src/Fig/Frontend.hs +++ b/fig-frontend/src/Fig/Frontend.hs @@ -1,10 +1,12 @@ +{-# Language QuasiQuotes #-} + module Fig.Frontend where import Fig.Prelude import Control.Lens (use) -import Data.Text (toLower) +import qualified Data.Text as Text import qualified Network.Wai.Middleware.Static as Wai.Static import qualified Network.Wai.Handler.Warp as Warp @@ -15,50 +17,52 @@ import qualified Lucid as L import qualified Lucid.Base as L import Fig.Utils.SExpr +import Fig.Bus.Client import Fig.Frontend.Utils import Fig.Frontend.Auth import Fig.Frontend.State import qualified Fig.Frontend.DB as DB -server :: Config -> IO () -server cfg = do +server :: Config -> (Text, Text) -> IO () +server cfg busAddr = do log $ "Frontend server running on port " <> tshow cfg.port - Warp.run cfg.port =<< app cfg - -window :: Text -> Text -> L.Html () -> L.Html () -window id_ title body = - L.term "fig-window" [L.id_ id_, L.makeAttributes "title" title] do - body + busClient busAddr + (\cmds -> do + log "Connected to bus!" + Warp.run cfg.port =<< app cfg cmds + ) + (\_ _ -> pure ()) + (pure ()) -app :: Config -> IO Tw.Application -app cfg = do +app :: Config -> Commands IO -> IO Tw.Application +app cfg cmds = do db <- DB.connect st <- stateRef pure $ foldr' @[] ($) (Tw.notFound . Tw.send $ Tw.text "not found") [ Wai.Static.staticPolicy $ Wai.Static.addBase cfg.assetPath - -- , Tw.get "/" - -- . Tw.send . Tw.html - -- . L.renderBS - -- $ L.doctypehtml_ do - -- L.head_ do - -- L.title_ "clonk zone api home page" - -- L.link_ [L.rel_ "icon", L.href_ "data:;base64,iVBORw0KGgo="] - -- L.link_ [L.rel_ "stylesheet", L.href_ "main.css"] - -- L.script_ [L.type_ "module", L.src_ "main.js"] ("" :: L.Html ()) - -- L.body_ do - -- L.button_ [L.id_ "foo"] do - -- "hello" , Tw.get "/api/check" $ authed cfg \auth -> do Tw.send $ Tw.json @[Text] [auth.id, auth.name] , Tw.put "/api/buffer" do buf <- withState st $ use buffer Tw.send $ Tw.text buf , Tw.get "/api/user/:name" do - name <- toLower <$> Tw.param "name" + name <- Text.toLower <$> Tw.param "name" DB.get db ("user:" <> encodeUtf8 name) >>= \case Nothing -> Tw.send . Tw.status Tw.status404 $ Tw.text "user not found" Just val -> Tw.send . Tw.text $ decodeUtf8 val + , Tw.post "/api/redeem/:name" do + me <- Text.toLower <$> Tw.param "ayem" + name <- Text.toLower <$> Tw.param "name" + input <- Tw.paramMaybe "input" + liftIO $ cmds.publish [sexp|(frontend redeem incoming)|] + $ mconcat + [ [ SExprString me + , SExprString name + ] + , maybe [] ((:[]) . SExprString) input + ] + Tw.send $ Tw.text "it worked" , Tw.get "/api/songs" do DB.hvals db "songnames" >>= \case Nothing -> Tw.send . Tw.status Tw.status404 $ Tw.text "no sounds found :(" @@ -69,12 +73,12 @@ app cfg = do Nothing -> Tw.send . Tw.status Tw.status404 $ Tw.text "song not found" Just val -> Tw.send . Tw.text $ decodeUtf8 val , Tw.get "/api/poke/:name" do - target <- encodeUtf8 . toLower <$> Tw.param "name" + target <- encodeUtf8 . Text.toLower <$> Tw.param "name" inbox <- fromMaybe [] <$> DB.smembers db ("pokeinbox:" <> target) Tw.send . Tw.text . pretty . SExprList @Void $ SExprString . decodeUtf8 <$> inbox , Tw.post "/api/poke/:name" do - me <- encodeUtf8 . toLower <$> Tw.param "ayem" - target <- encodeUtf8 . toLower <$> Tw.param "name" + me <- encodeUtf8 . Text.toLower <$> Tw.param "ayem" + target <- encodeUtf8 . Text.toLower <$> Tw.param "name" DB.sismember db ("pokeinbox:" <> me) target >>= \case True -> do log . tshow $ "handshake between " <> me <> " and " <> target <> " complete!" diff --git a/fig-frontend/src/Fig/Frontend/DB.hs b/fig-frontend/src/Fig/Frontend/DB.hs index 5ca8772..bcf00f2 100644 --- a/fig-frontend/src/Fig/Frontend/DB.hs +++ b/fig-frontend/src/Fig/Frontend/DB.hs @@ -44,3 +44,12 @@ sismember c key skey = liftIO $ Redis.runRedis c do Redis.sismember key skey >>= hush >>> \case Just x -> pure x Nothing -> pure False + +lpop :: MonadIO m => Redis.Connection -> ByteString -> m (Maybe ByteString) +lpop c key = liftIO $ Redis.runRedis c do + join . hush <$> Redis.lpop key + +rpush :: MonadIO m => Redis.Connection -> ByteString -> ByteString -> m () +rpush c key val = liftIO $ Redis.runRedis c do + _ <- Redis.rpush key [val] + pure () @@ -213,6 +213,16 @@ in { options.colonq.services.fig-frontend = { enable = lib.mkEnableOption "Enable the fig web frontend"; + busHost = lib.mkOption { + type = lib.types.str; + default = "127.0.0.1"; + description = "Message bus port"; + }; + busPort = lib.mkOption { + type = lib.types.port; + default = 32050; + description = "Address of message bus"; + }; configFile = lib.mkOption { type = lib.types.path; description = "Path to config file"; @@ -229,7 +239,7 @@ wantedBy = ["multi-user.target"]; serviceConfig = { Restart = "on-failure"; - ExecStart = "${haskellPackages.fig-frontend}/bin/fig-frontend --config ${cfg.configFile}"; + ExecStart = "${haskellPackages.fig-frontend}/bin/fig-frontend --bus-host ${cfg.busHost} --bus-port ${toString cfg.busPort} --config ${cfg.configFile}"; DynamicUser = "yes"; RuntimeDirectory = "colonq.fig-frontend"; RuntimeDirectoryMode = "0755"; |