summaryrefslogtreecommitdiff
path: root/fig-frontend
diff options
context:
space:
mode:
Diffstat (limited to 'fig-frontend')
-rw-r--r--fig-frontend/fig-frontend.cabal2
-rw-r--r--fig-frontend/src/Fig/Frontend.hs162
-rw-r--r--fig-frontend/src/Fig/Frontend/Auth.hs43
3 files changed, 110 insertions, 97 deletions
diff --git a/fig-frontend/fig-frontend.cabal b/fig-frontend/fig-frontend.cabal
index 855683b..f3c4f2e 100644
--- a/fig-frontend/fig-frontend.cabal
+++ b/fig-frontend/fig-frontend.cabal
@@ -32,11 +32,11 @@ common deps
, random
, req
, safe-exceptions
+ , scotty
, text
, time
, tomland
, transformers
- , twain
, unordered-containers
, vector
, wai
diff --git a/fig-frontend/src/Fig/Frontend.hs b/fig-frontend/src/Fig/Frontend.hs
index 92a9d04..51938dc 100644
--- a/fig-frontend/src/Fig/Frontend.hs
+++ b/fig-frontend/src/Fig/Frontend.hs
@@ -9,12 +9,14 @@ import System.Random (randomRIO)
import Control.Lens (use, (^?), Ixed (..))
import qualified Data.Text as Text
+import qualified Data.Text.Lazy as Text.L
import qualified Data.ByteString.Base64 as BS.Base64
+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 Web.Twain as Tw
+import qualified Web.Scotty as Sc
import Fig.Utils.SExpr
import Fig.Bus.Client
@@ -37,83 +39,93 @@ server cfg busAddr = do
sexprStr :: Text -> SExpr
sexprStr = SExprString . BS.Base64.encodeBase64 . encodeUtf8
-app :: Config -> Commands IO -> IO Tw.Application
+app :: Config -> Commands IO -> IO Wai.Application
app cfg cmds = do
log "Connecting to database..."
db <- DB.connect cfg
log "Connected! Server active."
st <- stateRef
- pure $ foldr' @[] ($)
- (Tw.notFound . Tw.send $ Tw.text "not found")
- [ Wai.Static.staticPolicy $ Wai.Static.addBase cfg.assetPath
- , 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/motd" do
- DB.get db "motd" >>= \case
- Nothing -> Tw.send $ Tw.text ""
- Just val -> Tw.send . Tw.text $ decodeUtf8 val
- , Tw.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 -> Tw.send $ Tw.text "man of letters"
- Just val -> Tw.send $ Tw.text val
- , Tw.get "/api/user/:name" do
- 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" do
- me <- Text.toLower <$> Tw.param "ayem"
- name <- Tw.param "name"
- input <- Tw.paramMaybe "input"
- liftIO $ cmds.publish [sexp|(frontend redeem incoming)|]
- $ mconcat
- [ [ sexprStr me
- , sexprStr name
- ]
- , maybe [] ((:[]) . sexprStr) input
+ Sc.scottyApp do
+ Sc.middleware $ Wai.Static.staticPolicy $ Wai.Static.addBase cfg.assetPath
+ 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/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.post "/api/redeem" do
+ me <- Text.toLower <$> Sc.formParam "ayem"
+ name <- Sc.formParam "name"
+ input <- Sc.formParamMaybe "input"
+ liftIO $ cmds.publish [sexp|(frontend redeem incoming)|]
+ $ mconcat
+ [ [ sexprStr me
+ , sexprStr name
]
- 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 :("
- Just songs -> Tw.send . Tw.text . pretty . SExprList @Void $ SExprString . decodeUtf8 <$> songs
- , Tw.get "/api/song/:hash" do
- hash <- Tw.param "hash"
- DB.hget db "songnotes" hash >>= \case
- 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 . Text.toLower <$> Tw.param "name"
- inbox <- fromMaybe [] <$> DB.smembers db ("pokeinbox:" <> target)
- Tw.send . Tw.text . pretty . SExprList @Void $ sexprStr . decodeUtf8 <$> inbox
- , Tw.post "/api/poke/:name" do
- 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!"
- DB.srem db ("pokeinbox:" <> target) [me]
- DB.srem db ("pokeinbox:" <> me) [target]
- Tw.send $ Tw.text "complete"
- False -> do
- log . tshow $ "partial handshake from " <> me <> " to " <> target
- DB.sadd db ("pokeinbox:" <> target) [me]
- Tw.send $ Tw.text "partial"
- ]
+ , maybe [] ((:[]) . sexprStr) input
+ ]
+ Sc.text "it worked"
+ 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.notFound do
+ Sc.text "not found"
diff --git a/fig-frontend/src/Fig/Frontend/Auth.hs b/fig-frontend/src/Fig/Frontend/Auth.hs
index 72eac0d..e9fe233 100644
--- a/fig-frontend/src/Fig/Frontend/Auth.hs
+++ b/fig-frontend/src/Fig/Frontend/Auth.hs
@@ -2,29 +2,28 @@ module Fig.Frontend.Auth where
import Fig.Prelude
-import GHC.Generics (Generic)
-
import qualified Network.HTTP.Req as R
import qualified Data.Aeson as Aeson
import qualified Data.Aeson.Types as Aeson
-import qualified Web.Twain as Tw
-
import qualified Jose.Jwk as Jwk
import qualified Jose.Jwt as Jwt
+import qualified Web.Scotty as Sc
+import qualified Web.Scotty.Cookie as Sc.C
+
import Fig.Frontend.Utils
data TokenContents = TokenContents
- { aud :: Text
- , exp :: Int
- , iat :: Int
- , iss :: Text
- , sub :: Text
- , azp :: Text
- , nonce :: Text
- , preferred_username :: Text
+ { aud :: !Text
+ , exp :: !Int
+ , iat :: !Int
+ , iss :: !Text
+ , sub :: !Text
+ , azp :: !Text
+ , nonce :: !Text
+ , preferred_username :: !Text
} deriving (Show, Eq, Generic)
instance Aeson.FromJSON TokenContents
@@ -52,14 +51,14 @@ validateToken encodedToken = fetchJwk >>= \case
log $ tshow contents
pure $ Aeson.decodeStrict contents
-data Auth = Auth { id :: Text, name :: Text } deriving Show
-checkAuth :: Config -> Tw.ResponderM (Maybe Auth)
+data Auth = Auth { id :: !Text, name :: !Text } deriving Show
+checkAuth :: Config -> Sc.ActionM (Maybe Auth)
checkAuth cfg = (,)
- <$> Tw.cookieParamMaybe "id_token"
- <*> Tw.cookieParamMaybe "authnonce"
+ <$> Sc.C.getCookie "id_token"
+ <*> Sc.C.getCookie "authnonce"
>>= \case
(Just token, Just nonce) -> do
- validateToken token >>= \case
+ validateToken (encodeUtf8 token) >>= \case
Just tc
| tc.aud == cfg.clientId
, tc.nonce == nonce
@@ -69,10 +68,12 @@ checkAuth cfg = (,)
{ name = tc.preferred_username
, id = tc.sub
}
- _ -> pure Nothing
- _ -> pure Nothing
+ _else -> pure Nothing
+ _else -> pure Nothing
-authed :: Config -> (Auth -> Tw.ResponderM a) -> Tw.ResponderM a
+authed :: Config -> (Auth -> Sc.ActionM ()) -> Sc.ActionM ()
authed cfg f = checkAuth cfg >>= \case
- Nothing -> Tw.send . Tw.status Tw.status401 $ Tw.text "unauthorized"
+ Nothing -> do
+ Sc.status status401
+ Sc.text "unauthorized"
Just auth -> f auth
generated by cgit v1.2.3 (git 2.25.1) at 2026-05-09 12:15:09 +0000