summaryrefslogtreecommitdiff
path: root/fig-frontend/src/Fig/Frontend
diff options
context:
space:
mode:
Diffstat (limited to 'fig-frontend/src/Fig/Frontend')
-rw-r--r--fig-frontend/src/Fig/Frontend/Auth.hs93
-rw-r--r--fig-frontend/src/Fig/Frontend/DB.hs64
-rw-r--r--fig-frontend/src/Fig/Frontend/State.hs41
-rw-r--r--fig-frontend/src/Fig/Frontend/Utils.hs53
4 files changed, 0 insertions, 251 deletions
diff --git a/fig-frontend/src/Fig/Frontend/Auth.hs b/fig-frontend/src/Fig/Frontend/Auth.hs
deleted file mode 100644
index 63bf804..0000000
--- a/fig-frontend/src/Fig/Frontend/Auth.hs
+++ /dev/null
@@ -1,93 +0,0 @@
-module Fig.Frontend.Auth where
-
-import Fig.Prelude
-
-import qualified Network.HTTP.Req as R
-
-import Data.Maybe (mapMaybe)
-import qualified Data.Text as Text
-import qualified Data.Text.Lazy as Text.Lazy
-import qualified Data.Map.Strict as Map
-import qualified Data.Aeson as Aeson
-import qualified Data.Aeson.Types as Aeson
-
-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 :: !(Maybe Text)
- , nonce :: !Text
- , preferred_username :: !Text
- } deriving (Show, Eq, Generic)
-instance Aeson.FromJSON TokenContents
-
-fetchJwk :: MonadIO m => m (Maybe Jwk.Jwk)
-fetchJwk = do
- resp <- R.responseBody <$> R.runReq R.defaultHttpConfig do
- R.req R.GET (R.https "id.twitch.tv" R./: "oauth2" R./: "keys") R.NoReqBody R.jsonResponse mempty
- let mkeys = Aeson.parseMaybe (Aeson..: "keys") resp
- let mjwk = mkeys >>= headMay
- log $ tshow mjwk
- pure mjwk
-
-validateToken :: MonadIO m => ByteString -> m (Maybe TokenContents)
-validateToken encodedToken = fetchJwk >>= \case
- Nothing -> pure Nothing
- Just jwk -> liftIO (Jwt.decode [jwk] Nothing encodedToken) >>= \case
- Left err -> do
- log $ "Failed to decode token: " <> tshow err
- pure Nothing
- Right jwt -> do
- let contents = case jwt of
- Jwt.Unsecured bs -> bs
- Jwt.Jws (_, bs) -> bs
- Jwt.Jwe (_, bs) -> bs
- log $ tshow contents
- pure $ Aeson.decodeStrict contents
-
-data Auth = Auth { id :: !Text, name :: !Text } deriving Show
-checkAuth :: Config -> Sc.ActionM (Maybe Auth)
-checkAuth cfg =
- Sc.header "Authorization"
- >>= \case
- Just authstrLazy -> do
- let authstr = drop 1 $ Text.splitOn " " $ Text.Lazy.toStrict authstrLazy
- let pairs = Map.fromList $ flip mapMaybe authstr \s ->
- case Text.splitOn "=" s of
- [k, v] -> Just (k, Text.takeWhile (/='"') $ Text.drop 1 v)
- _ -> Nothing
- case (Map.lookup "token" pairs, Map.lookup "nonce" pairs) of
- (Just token, Just nonce) -> do
- log $ tshow token
- log $ tshow nonce
- validateToken (encodeUtf8 token) >>= \case
- Just tc
- | tc.aud == cfg.clientId
- , tc.nonce == nonce
- -> do
- log $ tshow tc
- pure . Just $ Auth
- { name = tc.preferred_username
- , id = tc.sub
- }
- _else -> do
- pure Nothing
- _else -> pure Nothing
- _else -> pure Nothing
-
-authed :: Config -> (Auth -> Sc.ActionM ()) -> Sc.ActionM ()
-authed cfg f = checkAuth cfg >>= \case
- Nothing -> do
- Sc.status status401
- Sc.text "unauthorized"
- Just auth -> f auth
diff --git a/fig-frontend/src/Fig/Frontend/DB.hs b/fig-frontend/src/Fig/Frontend/DB.hs
deleted file mode 100644
index 51da59e..0000000
--- a/fig-frontend/src/Fig/Frontend/DB.hs
+++ /dev/null
@@ -1,64 +0,0 @@
-module Fig.Frontend.DB where
-
-import Control.Error.Util (hush)
-
-import qualified Database.Redis as Redis
-
-import Fig.Prelude
-import Fig.Frontend.Utils
-
-connect :: MonadIO m => Config -> m Redis.Connection
-connect cfg = liftIO $ Redis.checkedConnect Redis.defaultConnectInfo
- { Redis.connectHost = unpack cfg.dbHost
- }
-
-get :: MonadIO m => Redis.Connection -> ByteString -> m (Maybe ByteString)
-get c key = liftIO $ Redis.runRedis c do
- v <- Redis.get key
- pure . join $ hush v
-
-incr :: MonadIO m => Redis.Connection -> ByteString -> m ()
-incr c key = liftIO $ Redis.runRedis c do
- void $ Redis.incr key
-
-decr :: MonadIO m => Redis.Connection -> ByteString -> m ()
-decr c key = liftIO $ Redis.runRedis c do
- void $ Redis.decr key
-
-hget :: MonadIO m => Redis.Connection -> ByteString -> ByteString -> m (Maybe ByteString)
-hget c key hkey = liftIO $ Redis.runRedis c do
- v <- Redis.hget key hkey
- pure . join $ hush v
-
-hvals :: MonadIO m => Redis.Connection -> ByteString -> m (Maybe [ByteString])
-hvals c key = liftIO $ Redis.runRedis c do
- hush <$> Redis.hvals key
-
-sadd :: MonadIO m => Redis.Connection -> ByteString -> [ByteString] -> m ()
-sadd c key skeys = liftIO $ Redis.runRedis c do
- _ <- Redis.sadd key skeys
- pure ()
-
-srem :: MonadIO m => Redis.Connection -> ByteString -> [ByteString] -> m ()
-srem c key skeys = liftIO $ Redis.runRedis c do
- _ <- Redis.srem key skeys
- pure ()
-
-smembers :: MonadIO m => Redis.Connection -> ByteString -> m (Maybe [ByteString])
-smembers c key = liftIO $ Redis.runRedis c do
- hush <$> Redis.smembers key
-
-sismember :: MonadIO m => Redis.Connection -> ByteString -> ByteString -> m Bool
-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 ()
diff --git a/fig-frontend/src/Fig/Frontend/State.hs b/fig-frontend/src/Fig/Frontend/State.hs
deleted file mode 100644
index 6053105..0000000
--- a/fig-frontend/src/Fig/Frontend/State.hs
+++ /dev/null
@@ -1,41 +0,0 @@
-{-# Language TemplateHaskell #-}
-
-module Fig.Frontend.State where
-
-import Control.Lens.TH (makeLensesFor)
-import Control.Lens ((<>=))
-import Control.Monad.State (runStateT)
-
-import Fig.Prelude
-
-import qualified Data.IORef as IORef
-
-newtype State = State
- { buffer :: Text
- }
-makeLensesFor [("buffer", "buffer")] ''State
-
-defaultState :: State
-defaultState = State
- { buffer = ""
- }
-
-type StateRef = IORef.IORef State
-
-stateRef :: IO StateRef
-stateRef = IORef.newIORef defaultState
-
-withState ::
- MonadIO m' =>
- StateRef ->
- (forall m. (MonadIO m, MonadState State m) => m a) ->
- m' a
-withState ref f = do
- s <- liftIO $ IORef.readIORef ref
- (res, s') <- liftIO $ runStateT f s
- liftIO $ IORef.writeIORef ref s'
- pure res
-
-sayHi :: StateRef -> IO ()
-sayHi ref = withState ref do
- buffer <>= "hi"
diff --git a/fig-frontend/src/Fig/Frontend/Utils.hs b/fig-frontend/src/Fig/Frontend/Utils.hs
deleted file mode 100644
index 090c6ba..0000000
--- a/fig-frontend/src/Fig/Frontend/Utils.hs
+++ /dev/null
@@ -1,53 +0,0 @@
-{-# Language RecordWildCards #-}
-{-# Language ApplicativeDo #-}
-
-module Fig.Frontend.Utils
- ( FigFrontendException(..)
- , loadConfig
- , Config(..)
- , websocket
- , module Network.HTTP.Types.Status
- ) where
-
-import Fig.Prelude
-
-import Network.HTTP.Types.Status
-import qualified Network.Wai.Handler.WebSockets as Wai.WS
-import qualified Network.WebSockets as WS
-
-import qualified Web.Scotty as Sc
-
-import qualified Toml
-
-newtype FigFrontendException = FigFrontendException Text
- deriving (Show, Eq, Ord)
-instance Exception FigFrontendException
-
-data Config = Config
- { port :: !Int
- , assetPath :: !FilePath
- , clientId :: !Text
- , authToken :: !Text
- , dbHost :: !Text
- } deriving (Show, Eq, Ord)
-
-configCodec :: Toml.TomlCodec Config
-configCodec = do
- port <- Toml.int "port" Toml..= (\a -> a.port)
- assetPath <- Toml.string "asset_path" Toml..= (\a -> a.assetPath)
- clientId <- Toml.text "client_id" Toml..= (\a -> a.clientId)
- authToken <- Toml.text "auth_token" Toml..= (\a -> a.authToken)
- dbHost <- Toml.text "db_host" Toml..= (\a -> a.dbHost)
- pure $ Config{..}
-
-loadConfig :: FilePath -> IO Config
-loadConfig path = Toml.decodeFileEither configCodec path >>= \case
- Left err -> throwM . FigFrontendException $ tshow err
- Right config -> pure config
-
-websocket :: ByteString -> (WS.Connection -> IO ()) -> Sc.ScottyM ()
-websocket pat h = Sc.middleware $ Wai.WS.websocketsOr WS.defaultConnectionOptions handler
- where
- handler pending = if WS.requestPath (WS.pendingRequest pending) == pat
- then WS.acceptRequest pending >>= h
- else WS.rejectRequest pending ""
generated by cgit v1.2.3 (git 2.25.1) at 2026-05-09 16:41:59 +0000