Rename fig-frontend to fig-web

(It was the backend anyway :3)

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 ""