Add fig-frontend

3 files changed, 157 insertions, 0 deletions

diff --git a/fig-frontend/src/Fig/Frontend.hs b/fig-frontend/src/Fig/Frontend.hs
new file mode 100644
index 0000000..fa1965a
--- /dev/null
+++ b/fig-frontend/src/Fig/Frontend.hs
@@ -0,0 +1,42 @@
+module Fig.Frontend where
+
+import Fig.Prelude
+
+import qualified Network.Wai.Middleware.Static as Wai.Static
+import qualified Network.Wai.Handler.Warp as Warp
+
+import qualified Web.Twain as Tw
+
+import qualified Lucid as L
+
+import Fig.Frontend.Utils
+import Fig.Frontend.Auth
+
+server :: Config -> IO ()
+server cfg = do
+  log $ "Frontend server running on port " <> tshow cfg.port
+  Warp.run cfg.port $ app cfg
+
+app :: Config -> Tw.Application
+app cfg = foldr' @[] ($)
+  (Tw.notFound . Tw.send $ Tw.text "not found")
+  [ Wai.Static.staticPolicy $ Wai.Static.addBase cfg.assetPath
+  , Tw.get "/"
+    . Tw.send . Tw.html
+    . L.renderBS
+    $ L.doctypehtml_ do
+        L.head_ do
+          L.title_ "The Junkyard"
+          L.link_ [L.rel_ "stylesheet", L.href_ "js/index.css"]
+          L.link_ [L.rel_ "stylesheet", L.href_ "https://fonts.googleapis.com/css?family=Rubik+Maps"]
+          L.link_ [L.rel_ "icon", L.href_ "data:;base64,iVBORw0KGgo="]
+          L.script_ [L.type_ "module", L.src_ "js/index.js"] ("" :: L.Html ())
+        L.body_ do
+          L.term "fig-backdrop" ""
+          L.term "fig-header" ""
+          L.term "fig-login" ""
+          L.term "fig-window" do
+            L.h1_ "hello"
+  , Tw.get "/api/check" $ authed cfg \auth -> do
+      Tw.send $ Tw.json @[Text] [auth.id, auth.name]
+  ]
diff --git a/fig-frontend/src/Fig/Frontend/Auth.hs b/fig-frontend/src/Fig/Frontend/Auth.hs
new file mode 100644
index 0000000..72eac0d
--- /dev/null
+++ b/fig-frontend/src/Fig/Frontend/Auth.hs
@@ -0,0 +1,78 @@
+module Fig.Frontend.Auth where
+
+import Fig.Prelude
+
+import GHC.Generics (Generic)
+
+import qualified Network.HTTP.Req as R
+
+import qualified Data.Aeson as Aeson
+import qualified Data.Aeson.Types as Aeson
+
+import qualified Web.Twain as Tw
+
+import qualified Jose.Jwk as Jwk
+import qualified Jose.Jwt as Jwt
+
+import Fig.Frontend.Utils
+
+data TokenContents = TokenContents
+  { aud :: Text
+  , exp :: Int
+  , iat :: Int
+  , iss :: Text
+  , sub :: Text
+  , azp :: 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 -> Tw.ResponderM (Maybe Auth)
+checkAuth cfg = (,)
+  <$> Tw.cookieParamMaybe "id_token"
+  <*> Tw.cookieParamMaybe "authnonce"
+  >>= \case
+    (Just token, Just nonce) -> do
+      validateToken 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
+                }
+        _ -> pure Nothing
+    _ -> pure Nothing
+
+authed :: Config -> (Auth -> Tw.ResponderM a) -> Tw.ResponderM a
+authed cfg f = checkAuth cfg >>= \case
+  Nothing -> Tw.send . Tw.status Tw.status401 $ Tw.text "unauthorized"
+  Just auth -> f auth
diff --git a/fig-frontend/src/Fig/Frontend/Utils.hs b/fig-frontend/src/Fig/Frontend/Utils.hs
new file mode 100644
index 0000000..1ba1d5f
--- /dev/null
+++ b/fig-frontend/src/Fig/Frontend/Utils.hs
@@ -0,0 +1,37 @@
+{-# Language RecordWildCards #-}
+{-# Language ApplicativeDo #-}
+
+module Fig.Frontend.Utils
+  ( FigFrontendException(..)
+  , loadConfig
+  , Config(..)
+  , module Network.HTTP.Types.Status
+  ) where
+
+import Fig.Prelude
+
+import Network.HTTP.Types.Status
+
+import qualified Toml
+
+newtype FigFrontendException = FigFrontendException Text
+  deriving (Show, Eq, Ord)
+instance Exception FigFrontendException
+
+data Config = Config
+  { port :: Int
+  , assetPath :: FilePath
+  , clientId :: 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)
+  pure $ Config{..}
+
+loadConfig :: FilePath -> IO Config
+loadConfig path = Toml.decodeFileEither configCodec path >>= \case
+  Left err -> throwM . FigFrontendException $ tshow err
+  Right config -> pure config