From 624f7ba8b2fcda6675951dd8d41dcc99017484cf Mon Sep 17 00:00:00 2001 From: LLLL Colonq Date: Thu, 7 Nov 2024 22:37:32 -0500 Subject: Rename fig-frontend to fig-web (It was the backend anyway :3) --- fig-frontend/src/Fig/Frontend/Auth.hs | 93 ---------------------------------- fig-frontend/src/Fig/Frontend/DB.hs | 64 ----------------------- fig-frontend/src/Fig/Frontend/State.hs | 41 --------------- fig-frontend/src/Fig/Frontend/Utils.hs | 53 ------------------- 4 files changed, 251 deletions(-) delete mode 100644 fig-frontend/src/Fig/Frontend/Auth.hs delete mode 100644 fig-frontend/src/Fig/Frontend/DB.hs delete mode 100644 fig-frontend/src/Fig/Frontend/State.hs delete mode 100644 fig-frontend/src/Fig/Frontend/Utils.hs (limited to 'fig-frontend/src/Fig/Frontend') 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 "" -- cgit v1.2.3