web: Refactor major style

11 files changed, 490 insertions, 0 deletions

diff --git a/fig-web/src/Fig/Web/Module/Bells.hs b/fig-web/src/Fig/Web/Module/Bells.hs
new file mode 100644
index 0000000..7451079
--- /dev/null
+++ b/fig-web/src/Fig/Web/Module/Bells.hs
@@ -0,0 +1,26 @@
+module Fig.Web.Module.Bells
+  ( public
+  ) where
+
+import Fig.Prelude
+
+import Fig.Utils.SExpr
+import Fig.Web.Utils
+import Fig.Web.Types
+import qualified Fig.Web.DB as DB
+
+public :: Module
+public a = do
+  onGet "/api/songs" do
+    DB.hvals a.db "songnames" >>= \case
+      Nothing -> do
+        status status404
+        respondText "no sounds found :("
+      Just songs -> respondText . pretty . SExprList @Void $ SExprString . decodeUtf8 <$> songs
+  onGet "/api/song/:hash" do
+    hash <- pathParam "hash"
+    DB.hget a.db "songnotes" hash >>= \case
+      Nothing -> do
+        status status404
+        respondText "song not found"
+      Just val -> respondText $ decodeUtf8 val
diff --git a/fig-web/src/Fig/Web/Module/Circle.hs b/fig-web/src/Fig/Web/Module/Circle.hs
new file mode 100644
index 0000000..5c21477
--- /dev/null
+++ b/fig-web/src/Fig/Web/Module/Circle.hs
@@ -0,0 +1,61 @@
+module Fig.Web.Module.Circle
+  ( public
+  , publicWebsockets
+  , publicBusEvents
+  ) where
+
+import Fig.Prelude
+
+import qualified Control.Concurrent.MVar as MVar
+import qualified Control.Concurrent.Chan as Chan
+
+import qualified Data.Text as Text
+import qualified Data.Set as Set
+
+import qualified Network.WebSockets as WS
+
+import Fig.Utils.SExpr
+import Fig.Web.Utils
+import Fig.Web.Types
+
+public :: Module
+public a = do
+  onGet "/api/circle" do
+    live <- liftIO $ MVar.readMVar a.globals.currentlyLive
+    respondText $ pretty . SExprList @Void $ SExprString <$> Set.toList live
+
+publicWebsockets :: Websockets
+publicWebsockets a =
+  [ ( "/api/circle/events", \conn -> do
+        c <- Chan.dupChan a.channels.live
+        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
+              ]
+    )
+  ]
+
+publicBusEvents :: BusEvents
+publicBusEvents a =
+  [ ("monitor twitch stream online", \d -> do
+        let dstr = decodeUtf8 d
+        let live = Text.splitOn " " dstr
+        let new = Set.fromList live 
+        old <- MVar.swapMVar a.globals.currentlyLive new
+        let online = Set.difference new old
+        let offline = Set.difference old new
+        unless (Set.null online && Set.null offline) do
+          log $ "Newly online: " <> Text.intercalate " " (Set.toList online) <> ", newly offline: " <> Text.intercalate " " (Set.toList offline)
+        unless (Set.null online) . Chan.writeChan a.channels.live $ LiveEventOnline online
+        unless (Set.null offline) . Chan.writeChan a.channels.live $ LiveEventOnline offline
+    )
+  ]
diff --git a/fig-web/src/Fig/Web/Module/Exchange.hs b/fig-web/src/Fig/Web/Module/Exchange.hs
new file mode 100644
index 0000000..32851fa
--- /dev/null
+++ b/fig-web/src/Fig/Web/Module/Exchange.hs
@@ -0,0 +1,100 @@
+module Fig.Web.Module.Exchange
+  ( public
+  , secure
+  ) where
+
+import Fig.Prelude
+
+import Control.Error.Util (hush)
+
+import qualified Database.Redis as Redis
+
+import Data.Maybe (mapMaybe)
+import qualified Data.Aeson as Aeson
+import qualified Data.Text.Read as Text.R
+import qualified Data.ByteString.Lazy as BS.Lazy
+import qualified Data.UUID as UUID
+import qualified Data.UUID.V4 as UUID
+
+import Fig.Web.Utils
+import Fig.Web.Types
+
+public :: Module
+public a = do
+  onGet "/api/exchange" do
+    listings <- getOrders a.db.conn
+    respondJSON listings
+
+secure :: Module
+secure a = do
+  onPost "/api/exchange" $ authed \creds -> do
+    haveCur <- formParam "haveCur"
+    haveAmount <- formParam "haveAmount"
+    wantCur <- formParam "wantCur"
+    wantAmount <- formParam "wantAmount"
+    key <- createOrder a.db.conn $ Order
+      { creator = creds.email
+      , haveCur = haveCur
+      , haveAmount = haveAmount
+      , wantCur = wantCur
+      , wantAmount = wantAmount
+      }
+    respondText $ decodeUtf8 key
+  onPost "/api/exchange/:key" $ authed \creds -> do
+    key <- pathParam "key"
+    satisfyOrder a.db.conn key creds.email
+  onDelete "/api/exchange/:key" $ authed \_creds -> do
+    key <- pathParam "key"
+    cancelOrder a.db.conn key
+
+adjustUserCurrency :: Text -> Text -> Integer -> Redis.Redis ()
+adjustUserCurrency user cur amt = do
+  let key = "currency:" <> encodeUtf8 user
+  let ecur = encodeUtf8 cur
+  mold <- hush <$> Redis.hget key ecur
+  let old = case mold of
+        Just (Just o) -> case Text.R.decimal $ decodeUtf8 o of
+          Right (num, _) -> num
+          _else -> 0
+        _else -> 0
+  void . Redis.hset key ecur . encodeUtf8 . tshow $ old + amt
+
+data Order = Order
+  { creator :: !Text
+  , wantCur :: !Text
+  , wantAmount :: !Integer
+  , haveCur :: !Text
+  , haveAmount :: !Integer
+  } deriving Generic
+instance Aeson.ToJSON Order
+instance Aeson.FromJSON Order
+
+createOrder :: MonadIO m => Redis.Connection -> Order -> m ByteString
+createOrder c o = liftIO $ Redis.runRedis c do
+  let bs = Aeson.encode o
+  uuid <- liftIO UUID.nextRandom
+  let key = BS.Lazy.toStrict $ UUID.toByteString uuid
+  void $ Redis.hset "orders" key (BS.Lazy.toStrict bs)
+  pure key
+
+getOrders :: MonadIO m => Redis.Connection -> m [Order]
+getOrders c = liftIO $ Redis.runRedis c do
+  Redis.hvals "orders" >>= \case
+    Left _ -> pure []
+    Right orders -> pure $ mapMaybe (Aeson.decode' . BS.Lazy.fromStrict) orders
+
+cancelOrder :: MonadIO m => Redis.Connection -> ByteString -> m ()
+cancelOrder c key = liftIO $ Redis.runRedis c do
+  void $ Redis.hdel "orders" [key]
+
+satisfyOrder :: MonadIO m => Redis.Connection -> ByteString -> Text -> m ()
+satisfyOrder c key buyer = liftIO $ Redis.runRedis c do
+  Redis.hget "orders" key >>= \case
+    Right (Just bs) -> case Aeson.decode' $ BS.Lazy.fromStrict bs of
+      Nothing -> pure ()
+      Just (order :: Order) -> do
+        adjustUserCurrency buyer order.wantCur (-order.wantAmount)
+        adjustUserCurrency order.creator order.wantCur order.wantAmount
+        adjustUserCurrency buyer order.haveCur order.haveAmount
+        adjustUserCurrency order.creator order.haveCur (-order.haveAmount)
+    _else -> pure ()
diff --git a/fig-web/src/Fig/Web/Module/Gizmo.hs b/fig-web/src/Fig/Web/Module/Gizmo.hs
new file mode 100644
index 0000000..8112670
--- /dev/null
+++ b/fig-web/src/Fig/Web/Module/Gizmo.hs
@@ -0,0 +1,49 @@
+module Fig.Web.Module.Gizmo
+  ( public
+  , publicWebsockets
+  , publicBusEvents
+  ) where
+
+import Fig.Prelude
+
+import qualified Control.Concurrent.Chan as Chan
+
+import qualified Data.Text as Text
+
+import qualified Network.WebSockets as WS
+
+import Fig.Web.Utils
+import Fig.Web.Types
+import qualified Fig.Web.DB as DB
+
+public :: Module
+public a = do
+  onGet "/api/gizmo" do
+    buf <- queryParam "buf"
+    DB.hget a.db "gizmos" buf >>= \case
+      Nothing -> do
+        status status404
+        respondText "gizmo does not exist"
+      Just html -> respondHTML $ decodeUtf8 html
+  onGet "/api/gizmo/list" do
+    gizmos <- maybe [] (fmap decodeUtf8) <$> DB.hkeys a.db "gizmos"
+    respondText $ Text.unlines gizmos
+
+publicWebsockets :: Websockets
+publicWebsockets a =
+  [ ( "/api/gizmo/events", \conn -> do
+        c <- Chan.dupChan a.channels.gizmo
+        forever do
+          ev <- liftIO $ Chan.readChan c
+          WS.sendTextData conn ev
+    )
+  ]
+
+publicBusEvents :: BusEvents
+publicBusEvents a =
+  [ ("gizmo buffer update", \d -> do
+        let dstr = decodeUtf8 d
+        let updates = Text.splitOn " " dstr
+        forM_ updates $ Chan.writeChan a.channels.gizmo
+    )
+  ]
diff --git a/fig-web/src/Fig/Web/Module/Misc.hs b/fig-web/src/Fig/Web/Module/Misc.hs
new file mode 100644
index 0000000..b193314
--- /dev/null
+++ b/fig-web/src/Fig/Web/Module/Misc.hs
@@ -0,0 +1,38 @@
+module Fig.Web.Module.Misc
+  ( public
+  ) where
+
+import Fig.Prelude
+
+import System.Random (randomRIO)
+
+import Control.Lens ((^?), Ixed (..))
+
+import Fig.Web.Utils
+import Fig.Web.Types
+import qualified Fig.Web.DB as DB
+
+public :: Module
+public a = do
+  onGet "/api/motd" do
+    DB.get a.db "motd" >>= \case
+      Nothing -> respondText ""
+      Just val -> respondText $ decodeUtf8 val
+  onGet "/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 -> respondText "man of letters"
+      Just val -> respondText val
diff --git a/fig-web/src/Fig/Web/Module/Model.hs b/fig-web/src/Fig/Web/Module/Model.hs
new file mode 100644
index 0000000..86f0128
--- /dev/null
+++ b/fig-web/src/Fig/Web/Module/Model.hs
@@ -0,0 +1,26 @@
+module Fig.Web.Module.Model
+  ( publicWebsockets
+  ) where
+
+import Fig.Prelude
+
+import qualified Control.Concurrent.Chan as Chan
+
+import qualified Network.WebSockets as WS
+
+import Fig.Web.Types
+
+publicWebsockets :: Websockets
+publicWebsockets a =
+  [ ( "/api/model/broadcast", \conn -> do
+        forever do
+          msg <- liftIO $ WS.receiveDataMessage conn
+          Chan.writeChan a.channels.model msg
+    )
+  , ( "/api/model/events", \conn -> do
+        c <- Chan.dupChan a.channels.model
+        forever do
+          ev <- liftIO $ Chan.readChan c
+          WS.sendDataMessage conn ev
+    )
+  ]
diff --git a/fig-web/src/Fig/Web/Module/Redeem.hs b/fig-web/src/Fig/Web/Module/Redeem.hs
new file mode 100644
index 0000000..7dbafc0
--- /dev/null
+++ b/fig-web/src/Fig/Web/Module/Redeem.hs
@@ -0,0 +1,23 @@
+module Fig.Web.Module.Redeem
+  ( secure
+  ) where
+
+import Fig.Prelude
+
+import qualified Data.Maybe as Maybe
+import qualified Data.Text as Text
+
+import Fig.Web.Utils
+import Fig.Web.Types
+
+secure :: Module
+secure a = do
+  onPost "/api/redeem" $ authed \creds -> do
+    name <- formParam "name"
+    input <- formParamMaybe "input"
+    liftIO . a.cmds.publish "frontend redeem incoming"
+      . encodeUtf8 . Text.intercalate "\t" $
+      [ creds.user
+      , name
+      ] <> Maybe.maybeToList input
+    respondText "it worked"
diff --git a/fig-web/src/Fig/Web/Module/Sentiment.hs b/fig-web/src/Fig/Web/Module/Sentiment.hs
new file mode 100644
index 0000000..38a9250
--- /dev/null
+++ b/fig-web/src/Fig/Web/Module/Sentiment.hs
@@ -0,0 +1,21 @@
+module Fig.Web.Module.Sentiment
+  ( public
+  ) where
+
+import Fig.Prelude
+
+import Fig.Web.Utils
+import Fig.Web.Types
+import qualified Fig.Web.DB as DB
+
+public :: Module
+public a = do
+  onGet "/api/sentiment" do
+    s <- DB.get a.db "sentiment" >>= \case
+      Nothing -> pure "0"
+      Just x -> pure x
+    respondText $ decodeUtf8 s
+  onPost "/api/sentiment/green" do
+    DB.incr a.db "sentiment"
+  onPost "/api/sentiment/red" do
+    DB.decr a.db "sentiment"
diff --git a/fig-web/src/Fig/Web/Module/Shader.hs b/fig-web/src/Fig/Web/Module/Shader.hs
new file mode 100644
index 0000000..d4b43cc
--- /dev/null
+++ b/fig-web/src/Fig/Web/Module/Shader.hs
@@ -0,0 +1,18 @@
+module Fig.Web.Module.Shader
+  ( public
+  ) where
+
+import Fig.Prelude
+
+import Fig.Web.Utils
+import Fig.Web.Types
+import qualified Fig.Web.DB as DB
+
+public :: Module
+public a = do
+  onGet "/api/shader" do
+    DB.get a.db "shader" >>= \case
+      Nothing -> do
+        status status404
+        respondText "no shader present"
+      Just sh -> respondText $ decodeUtf8 sh
diff --git a/fig-web/src/Fig/Web/Module/TwitchAuth.hs b/fig-web/src/Fig/Web/Module/TwitchAuth.hs
new file mode 100644
index 0000000..4847da6
--- /dev/null
+++ b/fig-web/src/Fig/Web/Module/TwitchAuth.hs
@@ -0,0 +1,107 @@
+module Fig.Web.Module.TwitchAuth
+  ( public
+  ) 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.L
+import qualified Data.Map.Strict as Map
+import qualified Data.Aeson as Aeson
+import qualified Data.Aeson.Types as Aeson
+
+import qualified Web.Scotty as Sc
+
+import qualified Jose.Jwk as Jwk
+import qualified Jose.Jwt as Jwt
+
+import Fig.Web.Utils
+import Fig.Web.Types
+
+public :: Module
+public a = do
+  onGet "/api/register" $ twitchAuthed a.cfg \auth -> do
+    log "Authenticated with Twitch, trying to register..."
+    let user = Text.toLower auth.name
+    resetUserPassword a.cfg user auth.id >>= \case
+      Nothing -> do
+        log "Failed to register user"
+        status status500
+        respondText "failed to register"
+      Just pass -> do
+        log "Successfully registered user, responding..."
+        respondText $ user <> " " <> pass
+  onGet "/api/check" $ twitchAuthed a.cfg \auth -> do
+    respondJSON @[Text] [auth.id, auth.name]
+
+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.L.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)
+              _other -> Nothing
+      case (Map.lookup "token" pairs, Map.lookup "nonce" pairs) of
+        (Just token, Just nonce) -> do
+          validateToken (encodeUtf8 token) >>= \case
+            Just tc
+              | tc.aud == cfg.clientId
+              , tc.nonce == nonce
+                -> do
+                  pure . Just $ Auth { name = tc.preferred_username
+                    , id = tc.sub
+                    }
+            _else -> do
+              pure Nothing
+        _else -> pure Nothing
+    _else -> pure Nothing
+
+twitchAuthed :: Config -> (Auth -> Sc.ActionM ()) -> Sc.ActionM ()
+twitchAuthed cfg f = checkAuth cfg >>= \case
+  Nothing -> do
+    status status401
+    respondText "unauthorized"
+  Just auth -> f auth
diff --git a/fig-web/src/Fig/Web/Module/User.hs b/fig-web/src/Fig/Web/Module/User.hs
new file mode 100644
index 0000000..5b27b2d
--- /dev/null
+++ b/fig-web/src/Fig/Web/Module/User.hs
@@ -0,0 +1,21 @@
+module Fig.Web.Module.User
+  ( public
+  ) where
+
+import Fig.Prelude
+
+import qualified Data.Text as Text
+
+import Fig.Web.Utils
+import Fig.Web.Types
+import qualified Fig.Web.DB as DB
+
+public :: Module
+public a = do
+  onGet "/api/user/:name" do
+    name <- Text.toLower <$> pathParam "name"
+    DB.get a.db ("user:" <> encodeUtf8 name) >>= \case
+      Nothing -> do
+        status status404
+        respondText "user not found"
+      Just val -> respondText $ decodeUtf8 val