From a8eaa15e20779320eafc2e70093a3dd632da01ac Mon Sep 17 00:00:00 2001 From: LLLL Colonq Date: Wed, 30 Apr 2025 16:42:57 -0400 Subject: Rename Fig.Web --- fig-web/fig-web.cabal | 2 +- fig-web/main/Main.hs | 2 +- fig-web/src/Fig/Web.hs | 261 ------------------------------------------ fig-web/src/Fig/Web/Public.hs | 261 ++++++++++++++++++++++++++++++++++++++++++ 4 files changed, 263 insertions(+), 263 deletions(-) delete mode 100644 fig-web/src/Fig/Web.hs create mode 100644 fig-web/src/Fig/Web/Public.hs (limited to 'fig-web') diff --git a/fig-web/fig-web.cabal b/fig-web/fig-web.cabal index 8782593..b9eade6 100644 --- a/fig-web/fig-web.cabal +++ b/fig-web/fig-web.cabal @@ -56,7 +56,7 @@ library import: deps hs-source-dirs: src exposed-modules: - Fig.Web + Fig.Web.Public Fig.Web.Secure Fig.Web.Utils Fig.Web.Auth diff --git a/fig-web/main/Main.hs b/fig-web/main/Main.hs index 3567529..1ab93f0 100644 --- a/fig-web/main/Main.hs +++ b/fig-web/main/Main.hs @@ -7,7 +7,7 @@ import Fig.Prelude import Options.Applicative import Fig.Web.Utils -import qualified Fig.Web as Public +import qualified Fig.Web.Public as Public import qualified Fig.Web.Secure as Secure data Command diff --git a/fig-web/src/Fig/Web.hs b/fig-web/src/Fig/Web.hs deleted file mode 100644 index b0a0f51..0000000 --- a/fig-web/src/Fig/Web.hs +++ /dev/null @@ -1,261 +0,0 @@ -{-# Language QuasiQuotes #-} - -module Fig.Web where - -import Fig.Prelude - -import System.Random (randomRIO) - -import Control.Monad (unless) -import Control.Lens (use, (^?), Ixed (..)) -import qualified Control.Concurrent.Chan as Chan -import qualified Control.Concurrent.MVar as MVar - -import Data.Maybe (mapMaybe) -import qualified Data.Text as Text -import qualified Data.Text.Lazy as Text.L -import qualified Data.ByteString.Base64 as BS.Base64 -import qualified Data.Set as Set - -import qualified Network.Wai as Wai -import qualified Network.Wai.Middleware.Static as Wai.Static -import qualified Network.Wai.Handler.Warp as Warp -import qualified Network.WebSockets as WS - -import qualified Web.Scotty as Sc - -import Fig.Utils.SExpr -import Fig.Bus.Client -import Fig.Web.Utils -import Fig.Web.Auth -import Fig.Web.State -import qualified Fig.Web.DB as DB -import qualified Fig.Web.LDAP as LDAP -import qualified Fig.Web.Exchange as Exchange - -data LiveEvent - = LiveEventOnline !(Set.Set Text) - | LiveEventOffline !(Set.Set Text) - deriving (Show, Eq, Ord) - -data Channels = Channels - { live :: !(Chan.Chan LiveEvent) - , gizmo :: !(Chan.Chan Text) - } - -newChannels :: IO Channels -newChannels = do - live <- Chan.newChan - gizmo <- Chan.newChan - pure Channels {..} - -data Globals = Globals - { currentlyLive :: !(MVar.MVar (Set.Set Text)) - } - -newGlobals :: IO Globals -newGlobals = do - currentlyLive <- MVar.newMVar Set.empty - pure Globals {..} - -server :: Config -> (Text, Text) -> IO () -server cfg busAddr = do - log $ "Web server running on port " <> tshow cfg.port - chans <- newChannels - globs <- newGlobals - busClient busAddr - (\cmds -> do - log "Connected to bus!" - cmds.subscribe [sexp|(monitor twitch stream online)|] - cmds.subscribe [sexp|(gizmo buffer update)|] - Warp.run cfg.port =<< app cfg cmds chans globs.currentlyLive - ) - (\_cmds d -> do - case d of - SExprList (ev:rest) - | ev == [sexp|(monitor twitch stream online)|] -> do - let live = mapMaybe (\case SExprString s -> Just s; _other -> Nothing) rest - let new = Set.fromList live - old <- MVar.swapMVar globs.currentlyLive new - let online = Set.difference new old - let offline = Set.difference old new - log $ "Newly online: " <> Text.intercalate " " (Set.toList online) <> ", newly offline: " <> Text.intercalate " " (Set.toList offline) - unless (Set.null online) . Chan.writeChan chans.live $ LiveEventOnline online - unless (Set.null offline) . Chan.writeChan chans.live $ LiveEventOnline offline - | ev == [sexp|(gizmo buffer update)|] -> do - let updates = mapMaybe (\case SExprString s -> Just s; _other -> Nothing) rest - forM_ updates $ Chan.writeChan chans.gizmo - _other -> log $ "Invalid event: " <> tshow d - ) - (pure ()) - -sexprStr :: Text -> SExpr -sexprStr = SExprString . BS.Base64.encodeBase64 . encodeUtf8 - -app :: Config -> Commands IO -> Channels -> MVar.MVar (Set.Set Text) -> IO Wai.Application -app cfg _cmds chans currentlyLive = do - log "Connecting to database..." - db <- DB.connect cfg - log "Connected! Server active." - st <- stateRef - Sc.scottyApp do - Sc.middleware . Wai.Static.staticPolicy $ mconcat - [ Wai.Static.isNotAbsolute - , Wai.Static.only - [ ("register", "register.html") - , ("gizmo", "gizmo.html") - , ("main.css", "main.css") - , ("main.js", "main.js") - ] Wai.Static.<|> Wai.Static.hasPrefix "assets" - , Wai.Static.addBase cfg.assetPath - ] - -- Sc.get "/register" do - -- Sc.redirect "/register.html" - Sc.get "/unauthorized" do - Sc.status status401 - Sc.text $ mconcat - [ "your request was rejected because that endpoint requires authentication\n" - , "you can log in by POSTing your credentials to https://auth.colonq.computer/api/firstfactor\n" - , "for example:\n" - , " curl https://auth.colonq.computer/api/firstfactor \\\n" - , " --header \"Content-Type: application/json\" \\\n" - , " --request POST \\\n" - , " --data '{\"username\":\"AzureDiamond\",\"password\":\"hunter2\"}' \\\n" - , " --cookie-jar cookies.txt\n" - , "this will write a cookie called \"authelia_session\" to cookies.txt\n" - , "send this cookie along with your requests to use the secure endpoints\n" - , "for example:\n" - , " curl https://secure.colonq.computer --cookie cookies.txt\n" - ] - Sc.get "/api/register" $ authed cfg \auth -> do - log "Authenticated with Twitch, trying to register..." - let user = Text.toLower auth.name - LDAP.resetUserPassword cfg user auth.id >>= \case - Nothing -> do - log "Failed to register user" - Sc.status status500 - Sc.text "failed to register" - Just pass -> do - log "Successfully registered user, responding..." - Sc.text . Text.L.fromStrict $ user <> " " <> pass - Sc.get "/api/check" $ authed cfg \auth -> do - Sc.json @[Text] [auth.id, auth.name] - Sc.put "/api/buffer" do - buf <- withState st $ use buffer - Sc.text $ Text.L.fromStrict buf - Sc.get "/api/motd" do - DB.get db "motd" >>= \case - Nothing -> Sc.text "" - Just val -> Sc.text . Text.L.fromStrict $ decodeUtf8 val - Sc.get "/api/catchphrase" do - let catchphrases = - [ "vtuber (male)" - , "man of letters" - , "cool guy, online" - , "internet clown man" - , "professional emacs fan" - , "web freak" - , "guy who really likes programming" - , "i use nixos btw" - , "(are these funny or cringe or both?)" - , "haha yay" - , "Joel" - ] :: [Text] - i <- randomRIO (0, length catchphrases - 1) - case catchphrases ^? ix i of - Nothing -> Sc.text "man of letters" - Just val -> Sc.text $ Text.L.fromStrict val - Sc.get "/api/user/:name" do - name <- Text.toLower <$> Sc.pathParam "name" - DB.get db ("user:" <> encodeUtf8 name) >>= \case - Nothing -> do - Sc.status status404 - Sc.text "user not found" - Just val -> Sc.text . Text.L.fromStrict $ decodeUtf8 val - Sc.get "/api/songs" do - DB.hvals db "songnames" >>= \case - Nothing -> do - Sc.status status404 - Sc.text "no sounds found :(" - Just songs -> Sc.text . Text.L.fromStrict . pretty . SExprList @Void $ SExprString . decodeUtf8 <$> songs - Sc.get "/api/song/:hash" do - hash <- Sc.pathParam "hash" - DB.hget db "songnotes" hash >>= \case - Nothing -> do - Sc.status status404 - Sc.text "song not found" - Just val -> Sc.text . Text.L.fromStrict $ decodeUtf8 val - Sc.get "/api/poke/:name" do - target <- encodeUtf8 . Text.toLower <$> Sc.pathParam "name" - inbox <- fromMaybe [] <$> DB.smembers db ("pokeinbox:" <> target) - Sc.text . Text.L.fromStrict . pretty . SExprList @Void $ sexprStr . decodeUtf8 <$> inbox - Sc.post "/api/poke/:name" do - me <- encodeUtf8 . Text.toLower <$> Sc.formParam "ayem" - target <- encodeUtf8 . Text.toLower <$> Sc.pathParam "name" - DB.sismember db ("pokeinbox:" <> me) target >>= \case - True -> do - log . tshow $ "handshake between " <> me <> " and " <> target <> " complete!" - DB.srem db ("pokeinbox:" <> target) [me] - DB.srem db ("pokeinbox:" <> me) [target] - Sc.text "complete" - False -> do - log . tshow $ "partial handshake from " <> me <> " to " <> target - DB.sadd db ("pokeinbox:" <> target) [me] - Sc.text "partial" - Sc.get "/api/sentiment" do - s <- DB.get db "sentiment" >>= \case - Nothing -> pure "0" - Just x -> pure x - Sc.text . Text.L.fromStrict . decodeUtf8 $ s - Sc.post "/api/sentiment/green" do - DB.incr db "sentiment" - Sc.post "/api/sentiment/red" do - DB.decr db "sentiment" - Sc.get "/api/shader" do - DB.get db "shader" >>= \case - Nothing -> do - Sc.status status404 - Sc.text "no shader present" - Just sh -> Sc.text . Text.L.fromStrict $ decodeUtf8 sh - Sc.get "/api/exchange" do - listings <- Exchange.getOrders db - Sc.json listings - Sc.get "/api/gizmo" do - buf <- Sc.queryParam "buf" - DB.hget db "gizmos" buf >>= \case - Nothing -> do - Sc.status status404 - Sc.text "gizmo does not exist" - Just html -> Sc.html . Text.L.fromStrict $ decodeUtf8 html - Sc.get "/api/gizmo/list" do - gizmos <- maybe [] (fmap decodeUtf8) <$> DB.hkeys db "gizmos" - Sc.text $ Text.L.fromStrict $ Text.unlines gizmos - Sc.get "/api/circle" do - live <- liftIO $ MVar.readMVar currentlyLive - Sc.text . Text.L.fromStrict . pretty . SExprList @Void $ SExprString <$> Set.toList live - websocket - [ ( "/api/circle/events", \conn -> do - c <- Chan.dupChan chans.live - forever do - ev <- liftIO $ Chan.readChan c - WS.sendTextData conn $ case ev of - LiveEventOnline online -> - pretty $ SExprList @Void - [ SExprString "online" - , SExprList $ SExprString <$> Set.toList online - ] - LiveEventOffline offline -> - pretty $ SExprList @Void - [ SExprString "offline" - , SExprList $ SExprString <$> Set.toList offline - ] - ) - , ( "/api/gizmo/events", \conn -> do - c <- Chan.dupChan chans.gizmo - forever do - ev <- liftIO $ Chan.readChan c - WS.sendTextData conn ev - ) - ] - Sc.notFound do - Sc.text "not found" diff --git a/fig-web/src/Fig/Web/Public.hs b/fig-web/src/Fig/Web/Public.hs new file mode 100644 index 0000000..258c870 --- /dev/null +++ b/fig-web/src/Fig/Web/Public.hs @@ -0,0 +1,261 @@ +{-# Language QuasiQuotes #-} + +module Fig.Web.Public where + +import Fig.Prelude + +import System.Random (randomRIO) + +import Control.Monad (unless) +import Control.Lens (use, (^?), Ixed (..)) +import qualified Control.Concurrent.Chan as Chan +import qualified Control.Concurrent.MVar as MVar + +import Data.Maybe (mapMaybe) +import qualified Data.Text as Text +import qualified Data.Text.Lazy as Text.L +import qualified Data.ByteString.Base64 as BS.Base64 +import qualified Data.Set as Set + +import qualified Network.Wai as Wai +import qualified Network.Wai.Middleware.Static as Wai.Static +import qualified Network.Wai.Handler.Warp as Warp +import qualified Network.WebSockets as WS + +import qualified Web.Scotty as Sc + +import Fig.Utils.SExpr +import Fig.Bus.Client +import Fig.Web.Utils +import Fig.Web.Auth +import Fig.Web.State +import qualified Fig.Web.DB as DB +import qualified Fig.Web.LDAP as LDAP +import qualified Fig.Web.Exchange as Exchange + +data LiveEvent + = LiveEventOnline !(Set.Set Text) + | LiveEventOffline !(Set.Set Text) + deriving (Show, Eq, Ord) + +data Channels = Channels + { live :: !(Chan.Chan LiveEvent) + , gizmo :: !(Chan.Chan Text) + } + +newChannels :: IO Channels +newChannels = do + live <- Chan.newChan + gizmo <- Chan.newChan + pure Channels {..} + +data Globals = Globals + { currentlyLive :: !(MVar.MVar (Set.Set Text)) + } + +newGlobals :: IO Globals +newGlobals = do + currentlyLive <- MVar.newMVar Set.empty + pure Globals {..} + +server :: Config -> (Text, Text) -> IO () +server cfg busAddr = do + log $ "Web server running on port " <> tshow cfg.port + chans <- newChannels + globs <- newGlobals + busClient busAddr + (\cmds -> do + log "Connected to bus!" + cmds.subscribe [sexp|(monitor twitch stream online)|] + cmds.subscribe [sexp|(gizmo buffer update)|] + Warp.run cfg.port =<< app cfg cmds chans globs.currentlyLive + ) + (\_cmds d -> do + case d of + SExprList (ev:rest) + | ev == [sexp|(monitor twitch stream online)|] -> do + let live = mapMaybe (\case SExprString s -> Just s; _other -> Nothing) rest + let new = Set.fromList live + old <- MVar.swapMVar globs.currentlyLive new + let online = Set.difference new old + let offline = Set.difference old new + log $ "Newly online: " <> Text.intercalate " " (Set.toList online) <> ", newly offline: " <> Text.intercalate " " (Set.toList offline) + unless (Set.null online) . Chan.writeChan chans.live $ LiveEventOnline online + unless (Set.null offline) . Chan.writeChan chans.live $ LiveEventOnline offline + | ev == [sexp|(gizmo buffer update)|] -> do + let updates = mapMaybe (\case SExprString s -> Just s; _other -> Nothing) rest + forM_ updates $ Chan.writeChan chans.gizmo + _other -> log $ "Invalid event: " <> tshow d + ) + (pure ()) + +sexprStr :: Text -> SExpr +sexprStr = SExprString . BS.Base64.encodeBase64 . encodeUtf8 + +app :: Config -> Commands IO -> Channels -> MVar.MVar (Set.Set Text) -> IO Wai.Application +app cfg _cmds chans currentlyLive = do + log "Connecting to database..." + db <- DB.connect cfg + log "Connected! Server active." + st <- stateRef + Sc.scottyApp do + Sc.middleware . Wai.Static.staticPolicy $ mconcat + [ Wai.Static.isNotAbsolute + , Wai.Static.only + [ ("register", "register.html") + , ("gizmo", "gizmo.html") + , ("main.css", "main.css") + , ("main.js", "main.js") + ] Wai.Static.<|> Wai.Static.hasPrefix "assets" + , Wai.Static.addBase cfg.assetPath + ] + -- Sc.get "/register" do + -- Sc.redirect "/register.html" + Sc.get "/unauthorized" do + Sc.status status401 + Sc.text $ mconcat + [ "your request was rejected because that endpoint requires authentication\n" + , "you can log in by POSTing your credentials to https://auth.colonq.computer/api/firstfactor\n" + , "for example:\n" + , " curl https://auth.colonq.computer/api/firstfactor \\\n" + , " --header \"Content-Type: application/json\" \\\n" + , " --request POST \\\n" + , " --data '{\"username\":\"AzureDiamond\",\"password\":\"hunter2\"}' \\\n" + , " --cookie-jar cookies.txt\n" + , "this will write a cookie called \"authelia_session\" to cookies.txt\n" + , "send this cookie along with your requests to use the secure endpoints\n" + , "for example:\n" + , " curl https://secure.colonq.computer --cookie cookies.txt\n" + ] + Sc.get "/api/register" $ authed cfg \auth -> do + log "Authenticated with Twitch, trying to register..." + let user = Text.toLower auth.name + LDAP.resetUserPassword cfg user auth.id >>= \case + Nothing -> do + log "Failed to register user" + Sc.status status500 + Sc.text "failed to register" + Just pass -> do + log "Successfully registered user, responding..." + Sc.text . Text.L.fromStrict $ user <> " " <> pass + Sc.get "/api/check" $ authed cfg \auth -> do + Sc.json @[Text] [auth.id, auth.name] + Sc.put "/api/buffer" do + buf <- withState st $ use buffer + Sc.text $ Text.L.fromStrict buf + Sc.get "/api/motd" do + DB.get db "motd" >>= \case + Nothing -> Sc.text "" + Just val -> Sc.text . Text.L.fromStrict $ decodeUtf8 val + Sc.get "/api/catchphrase" do + let catchphrases = + [ "vtuber (male)" + , "man of letters" + , "cool guy, online" + , "internet clown man" + , "professional emacs fan" + , "web freak" + , "guy who really likes programming" + , "i use nixos btw" + , "(are these funny or cringe or both?)" + , "haha yay" + , "Joel" + ] :: [Text] + i <- randomRIO (0, length catchphrases - 1) + case catchphrases ^? ix i of + Nothing -> Sc.text "man of letters" + Just val -> Sc.text $ Text.L.fromStrict val + Sc.get "/api/user/:name" do + name <- Text.toLower <$> Sc.pathParam "name" + DB.get db ("user:" <> encodeUtf8 name) >>= \case + Nothing -> do + Sc.status status404 + Sc.text "user not found" + Just val -> Sc.text . Text.L.fromStrict $ decodeUtf8 val + Sc.get "/api/songs" do + DB.hvals db "songnames" >>= \case + Nothing -> do + Sc.status status404 + Sc.text "no sounds found :(" + Just songs -> Sc.text . Text.L.fromStrict . pretty . SExprList @Void $ SExprString . decodeUtf8 <$> songs + Sc.get "/api/song/:hash" do + hash <- Sc.pathParam "hash" + DB.hget db "songnotes" hash >>= \case + Nothing -> do + Sc.status status404 + Sc.text "song not found" + Just val -> Sc.text . Text.L.fromStrict $ decodeUtf8 val + Sc.get "/api/poke/:name" do + target <- encodeUtf8 . Text.toLower <$> Sc.pathParam "name" + inbox <- fromMaybe [] <$> DB.smembers db ("pokeinbox:" <> target) + Sc.text . Text.L.fromStrict . pretty . SExprList @Void $ sexprStr . decodeUtf8 <$> inbox + Sc.post "/api/poke/:name" do + me <- encodeUtf8 . Text.toLower <$> Sc.formParam "ayem" + target <- encodeUtf8 . Text.toLower <$> Sc.pathParam "name" + DB.sismember db ("pokeinbox:" <> me) target >>= \case + True -> do + log . tshow $ "handshake between " <> me <> " and " <> target <> " complete!" + DB.srem db ("pokeinbox:" <> target) [me] + DB.srem db ("pokeinbox:" <> me) [target] + Sc.text "complete" + False -> do + log . tshow $ "partial handshake from " <> me <> " to " <> target + DB.sadd db ("pokeinbox:" <> target) [me] + Sc.text "partial" + Sc.get "/api/sentiment" do + s <- DB.get db "sentiment" >>= \case + Nothing -> pure "0" + Just x -> pure x + Sc.text . Text.L.fromStrict . decodeUtf8 $ s + Sc.post "/api/sentiment/green" do + DB.incr db "sentiment" + Sc.post "/api/sentiment/red" do + DB.decr db "sentiment" + Sc.get "/api/shader" do + DB.get db "shader" >>= \case + Nothing -> do + Sc.status status404 + Sc.text "no shader present" + Just sh -> Sc.text . Text.L.fromStrict $ decodeUtf8 sh + Sc.get "/api/exchange" do + listings <- Exchange.getOrders db + Sc.json listings + Sc.get "/api/gizmo" do + buf <- Sc.queryParam "buf" + DB.hget db "gizmos" buf >>= \case + Nothing -> do + Sc.status status404 + Sc.text "gizmo does not exist" + Just html -> Sc.html . Text.L.fromStrict $ decodeUtf8 html + Sc.get "/api/gizmo/list" do + gizmos <- maybe [] (fmap decodeUtf8) <$> DB.hkeys db "gizmos" + Sc.text $ Text.L.fromStrict $ Text.unlines gizmos + Sc.get "/api/circle" do + live <- liftIO $ MVar.readMVar currentlyLive + Sc.text . Text.L.fromStrict . pretty . SExprList @Void $ SExprString <$> Set.toList live + websocket + [ ( "/api/circle/events", \conn -> do + c <- Chan.dupChan chans.live + forever do + ev <- liftIO $ Chan.readChan c + WS.sendTextData conn $ case ev of + LiveEventOnline online -> + pretty $ SExprList @Void + [ SExprString "online" + , SExprList $ SExprString <$> Set.toList online + ] + LiveEventOffline offline -> + pretty $ SExprList @Void + [ SExprString "offline" + , SExprList $ SExprString <$> Set.toList offline + ] + ) + , ( "/api/gizmo/events", \conn -> do + c <- Chan.dupChan chans.gizmo + forever do + ev <- liftIO $ Chan.readChan c + WS.sendTextData conn ev + ) + ] + Sc.notFound do + Sc.text "not found" -- cgit v1.2.3