diff options
Diffstat (limited to 'fig-frontend/src/Fig')
| -rw-r--r-- | fig-frontend/src/Fig/Frontend.hs | 181 | ||||
| -rw-r--r-- | fig-frontend/src/Fig/Frontend/Auth.hs | 93 | ||||
| -rw-r--r-- | fig-frontend/src/Fig/Frontend/DB.hs | 64 | ||||
| -rw-r--r-- | fig-frontend/src/Fig/Frontend/State.hs | 41 | ||||
| -rw-r--r-- | fig-frontend/src/Fig/Frontend/Utils.hs | 53 |
5 files changed, 0 insertions, 432 deletions
diff --git a/fig-frontend/src/Fig/Frontend.hs b/fig-frontend/src/Fig/Frontend.hs deleted file mode 100644 index 4c32078..0000000 --- a/fig-frontend/src/Fig/Frontend.hs +++ /dev/null @@ -1,181 +0,0 @@ -{-# Language QuasiQuotes #-} - -module Fig.Frontend 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.Frontend.Utils -import Fig.Frontend.Auth -import Fig.Frontend.State -import qualified Fig.Frontend.DB as DB - -data LiveEvent - = LiveEventOnline !(Set.Set Text) - | LiveEventOffline !(Set.Set Text) - deriving (Show, Eq, Ord) - -server :: Config -> (Text, Text) -> IO () -server cfg busAddr = do - log $ "Frontend server running on port " <> tshow cfg.port - liveEvents <- Chan.newChan @LiveEvent - currentlyLive <- MVar.newMVar Set.empty - busClient busAddr - (\cmds -> do - log "Connected to bus!" - cmds.subscribe [sexp|(monitor twitch stream online)|] - Warp.run cfg.port =<< app cfg cmds liveEvents 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; _ -> Nothing) rest - let new = Set.fromList live - old <- MVar.swapMVar currentlyLive new - let online = Set.difference new old - let offline = Set.difference old new - unless (Set.null online) . Chan.writeChan liveEvents $ LiveEventOnline online - unless (Set.null offline) . Chan.writeChan liveEvents $ LiveEventOnline offline - _ -> log $ "Invalid event: " <> tshow d - ) - (pure ()) - -sexprStr :: Text -> SExpr -sexprStr = SExprString . BS.Base64.encodeBase64 . encodeUtf8 - -app :: Config -> Commands IO -> Chan.Chan LiveEvent -> MVar.MVar (Set.Set Text) -> IO Wai.Application -app cfg cmds liveEvents currentlyLive = do - log "Connecting to database..." - db <- DB.connect cfg - log "Connected! Server active." - st <- stateRef - Sc.scottyApp do - Sc.middleware $ Wai.Static.staticPolicy $ Wai.Static.addBase cfg.assetPath - Sc.get "/" $ Sc.redirect "/index.html" - 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.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 - ] - , 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.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/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 liveEvents - 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 - ] - 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 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 "" |