Rename fig-frontend to fig-web

(It was the backend anyway :3)

4 files changed, 249 insertions, 0 deletions

diff --git a/fig-web/src/Fig/Web/Auth.hs b/fig-web/src/Fig/Web/Auth.hs
new file mode 100644
index 0000000..3076d1f
--- /dev/null
+++ b/fig-web/src/Fig/Web/Auth.hs
@@ -0,0 +1,93 @@
+module Fig.Web.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.Web.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-web/src/Fig/Web/DB.hs b/fig-web/src/Fig/Web/DB.hs
new file mode 100644
index 0000000..f166bdf
--- /dev/null
+++ b/fig-web/src/Fig/Web/DB.hs
@@ -0,0 +1,64 @@
+module Fig.Web.DB where
+
+import Control.Error.Util (hush)
+
+import qualified Database.Redis as Redis
+
+import Fig.Prelude
+import Fig.Web.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-web/src/Fig/Web/State.hs b/fig-web/src/Fig/Web/State.hs
new file mode 100644
index 0000000..11e0ece
--- /dev/null
+++ b/fig-web/src/Fig/Web/State.hs
@@ -0,0 +1,41 @@
+{-# Language TemplateHaskell #-}
+
+module Fig.Web.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-web/src/Fig/Web/Utils.hs b/fig-web/src/Fig/Web/Utils.hs
new file mode 100644
index 0000000..b6c385a
--- /dev/null
+++ b/fig-web/src/Fig/Web/Utils.hs
@@ -0,0 +1,51 @@
+{-# Language RecordWildCards #-}
+{-# Language ApplicativeDo #-}
+
+module Fig.Web.Utils
+  ( FigWebException(..)
+  , 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 FigWebException = FigWebException Text
+  deriving (Show, Eq, Ord)
+instance Exception FigWebException
+
+data Config = Config
+  { port :: !Int
+  , clientId :: !Text
+  , authToken :: !Text
+  , dbHost :: !Text
+  } deriving (Show, Eq, Ord)
+
+configCodec :: Toml.TomlCodec Config
+configCodec = do
+  port <- Toml.int "port" Toml..= (\a -> a.port)
+  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 . FigWebException $ 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 ""