web: Refactor major style

18 files changed, 655 insertions, 411 deletions

diff --git a/fig-web/src/Fig/Web/DB.hs b/fig-web/src/Fig/Web/DB.hs
index d8a70c2..5a51560 100644
--- a/fig-web/src/Fig/Web/DB.hs
+++ b/fig-web/src/Fig/Web/DB.hs
@@ -5,64 +5,65 @@ import Control.Error.Util (hush)
 import qualified Database.Redis as Redis
 
 import Fig.Prelude
+import Fig.Web.Types
 import Fig.Web.Utils
 
-connect :: MonadIO m => Config -> m Redis.Connection
-connect cfg = liftIO $ Redis.checkedConnect Redis.defaultConnectInfo
+connect :: MonadIO m => Config -> m DB
+connect cfg = liftIO $ DB <$> 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
+get :: MonadIO m => DB -> ByteString -> m (Maybe ByteString)
+get (DB 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
+incr :: MonadIO m => DB -> ByteString -> m ()
+incr (DB 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
+decr :: MonadIO m => DB -> ByteString -> m ()
+decr (DB 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
+hget :: MonadIO m => DB -> ByteString -> ByteString -> m (Maybe ByteString)
+hget (DB c) key hkey = liftIO $ Redis.runRedis c do
   v <- Redis.hget key hkey
   pure . join $ hush v
 
-hkeys :: MonadIO m => Redis.Connection -> ByteString -> m (Maybe [ByteString])
-hkeys c key = liftIO $ Redis.runRedis c do
+hkeys :: MonadIO m => DB -> ByteString -> m (Maybe [ByteString])
+hkeys (DB c) key = liftIO $ Redis.runRedis c do
   hush <$> Redis.hkeys key
 
-hvals :: MonadIO m => Redis.Connection -> ByteString -> m (Maybe [ByteString])
-hvals c key = liftIO $ Redis.runRedis c do
+hvals :: MonadIO m => DB -> ByteString -> m (Maybe [ByteString])
+hvals (DB 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
+sadd :: MonadIO m => DB -> ByteString -> [ByteString] -> m ()
+sadd (DB 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
+srem :: MonadIO m => DB -> ByteString -> [ByteString] -> m ()
+srem (DB 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
+smembers :: MonadIO m => DB -> ByteString -> m (Maybe [ByteString])
+smembers (DB 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
+sismember :: MonadIO m => DB -> ByteString -> ByteString -> m Bool
+sismember (DB 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
+lpop :: MonadIO m => DB -> ByteString -> m (Maybe ByteString)
+lpop (DB 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
+rpush :: MonadIO m => DB -> ByteString -> ByteString -> m ()
+rpush (DB c) key val = liftIO $ Redis.runRedis c do
   _ <- Redis.rpush key [val]
   pure ()
diff --git a/fig-web/src/Fig/Web/LDAP.hs b/fig-web/src/Fig/Web/LDAP.hs
deleted file mode 100644
index 07c87d9..0000000
--- a/fig-web/src/Fig/Web/LDAP.hs
+++ /dev/null
@@ -1,43 +0,0 @@
-module Fig.Web.LDAP where
-
-import Fig.Prelude
-
-import System.Exit (ExitCode(..))
-import qualified System.Process as Proc
-
-import qualified Data.UUID as UUID
-import qualified Data.UUID.V4 as UUID
-import qualified Data.Text as Text
-
-import Fig.Web.Utils
-
--- | Reset the password in LDAP for the specified user (creating the user if necessary)
-resetUserPassword :: MonadIO m => Config -> Text -> Text -> m (Maybe Text)
-resetUserPassword cfg user uid = do
-  let login = Text.toLower user
-  password <- UUID.toText <$> liftIO UUID.nextRandom
-  (exitCode, out0, err0) <- liftIO . flip Proc.readCreateProcessWithExitCode ""
-    . Proc.proc cfg.lldapCli $ unpack <$>
-    [ "-H", cfg.lldapHost
-    , "-D", cfg.lldapUser
-    , "-w", cfg.lldapPassword
-    , "user", "add", login, uid <> "@users.colonq.computer"
-    , "-p", password
-    , "-f", uid
-    ]
-  (_, out1, err1) <- liftIO . flip Proc.readCreateProcessWithExitCode ""
-    . Proc.proc cfg.lldapCli $ unpack <$>
-    [ "-H", cfg.lldapHost
-    , "-D", cfg.lldapUser
-    , "-w", cfg.lldapPassword
-    , "user", "group", "add", login, "fig_users"
-    ]
-  case exitCode of
-    ExitSuccess -> pure $ Just password
-    ExitFailure _ -> do
-      log . pack $ mconcat
-        [ "LDAP CLI error:\n"
-        , out0, err0
-        , out1, err1
-        ]
-      pure Nothing
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/Exchange.hs b/fig-web/src/Fig/Web/Module/Exchange.hs
index 264e73c..32851fa 100644
--- a/fig-web/src/Fig/Web/Exchange.hs
+++ b/fig-web/src/Fig/Web/Module/Exchange.hs
@@ -1,4 +1,9 @@
-module Fig.Web.Exchange where
+module Fig.Web.Module.Exchange
+  ( public
+  , secure
+  ) where
+
+import Fig.Prelude
 
 import Control.Error.Util (hush)
 
@@ -11,7 +16,36 @@ import qualified Data.ByteString.Lazy as BS.Lazy
 import qualified Data.UUID as UUID
 import qualified Data.UUID.V4 as UUID
 
-import Fig.Prelude
+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
@@ -64,4 +98,3 @@ satisfyOrder c key buyer = liftIO $ Redis.runRedis c do
         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/Auth.hs b/fig-web/src/Fig/Web/Module/TwitchAuth.hs
index b78e3b3..4847da6 100644
--- a/fig-web/src/Fig/Web/Auth.hs
+++ b/fig-web/src/Fig/Web/Module/TwitchAuth.hs
@@ -1,4 +1,6 @@
-module Fig.Web.Auth where
+module Fig.Web.Module.TwitchAuth
+  ( public
+  ) where
 
 import Fig.Prelude
 
@@ -6,17 +8,34 @@ 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.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 qualified Web.Scotty as Sc
-
 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
@@ -60,7 +79,7 @@ checkAuth cfg =
   Sc.header "Authorization"
   >>= \case
     Just authstrLazy -> do
-      let authstr = drop 1 $ Text.splitOn " " $ Text.Lazy.toStrict authstrLazy
+      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)
@@ -72,8 +91,7 @@ checkAuth cfg =
               | tc.aud == cfg.clientId
               , tc.nonce == nonce
                 -> do
-                  pure . Just $ Auth
-                    { name = tc.preferred_username
+                  pure . Just $ Auth { name = tc.preferred_username
                     , id = tc.sub
                     }
             _else -> do
@@ -81,9 +99,9 @@ checkAuth cfg =
         _else -> pure Nothing
     _else -> pure Nothing
 
-authed :: Config -> (Auth -> Sc.ActionM ()) -> Sc.ActionM ()
-authed cfg f = checkAuth cfg >>= \case
+twitchAuthed :: Config -> (Auth -> Sc.ActionM ()) -> Sc.ActionM ()
+twitchAuthed cfg f = checkAuth cfg >>= \case
   Nothing -> do
-    Sc.status status401
-    Sc.text "unauthorized"
+    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
diff --git a/fig-web/src/Fig/Web/Public.hs b/fig-web/src/Fig/Web/Public.hs
index 40583a6..cd37d4e 100644
--- a/fig-web/src/Fig/Web/Public.hs
+++ b/fig-web/src/Fig/Web/Public.hs
@@ -1,100 +1,59 @@
-module Fig.Web.Public where
+module Fig.Web.Public
+  ( server
+  ) 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 qualified Data.Text as Text
-import qualified Data.Text.Lazy as Text.L
-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.Binary.Client
+import Fig.Web.Types
 import Fig.Web.Utils
-import Fig.Web.Auth
-import Fig.Web.State
 import qualified Fig.Web.DB as DB
-import qualified Fig.Web.LDAP as LDAP
-import qualified Fig.Web.Exchange as Exchange
-
-data LiveEvent
-  = LiveEventOnline !(Set.Set Text)
-  | LiveEventOffline !(Set.Set Text)
-  deriving (Show, Eq, Ord)
-
-data Channels = Channels
-  { live :: !(Chan.Chan LiveEvent)
-  , gizmo :: !(Chan.Chan Text)
-  , model :: !(Chan.Chan WS.DataMessage)
-  }
-
-newChannels :: IO Channels
-newChannels = do
-  live <- Chan.newChan
-  gizmo <- Chan.newChan
-  model <- Chan.newChan
-  pure Channels {..}
+import qualified Fig.Web.Module.Misc as Misc
+import qualified Fig.Web.Module.TwitchAuth as TwitchAuth
+import qualified Fig.Web.Module.Exchange as Exchange
+import qualified Fig.Web.Module.Gizmo as Gizmo
+import qualified Fig.Web.Module.Sentiment as Sentiment
+import qualified Fig.Web.Module.Circle as Circle
+import qualified Fig.Web.Module.Model as Model
+import qualified Fig.Web.Module.Bells as Bells
+import qualified Fig.Web.Module.User as User
+import qualified Fig.Web.Module.Shader as Shader
 
-newtype Globals = Globals
-  { currentlyLive :: MVar.MVar (Set.Set Text)
-  }
-
-newGlobals :: IO Globals
-newGlobals = do
-  currentlyLive <- MVar.newMVar Set.empty
-  pure Globals {..}
+allBusEvents :: ModuleArgs -> BusEventHandlers
+allBusEvents args = busEvents . mconcat $ fmap ($ args)
+  [ Gizmo.publicBusEvents
+  , Circle.publicBusEvents
+  ]
 
 server :: Config -> (Text, Text) -> IO ()
 server cfg busAddr = do
   log $ "Web server running on port " <> tshow cfg.port
-  chans <- newChannels
-  globs <- newGlobals
+  log "Connecting to database..."
+  db <- DB.connect cfg
+  channels <- newChannels
+  globals <- newGlobals
   busClient busAddr
     (\cmds -> do
         log "Connected to bus!"
-        cmds.subscribe "monitor twitch stream online"
-        cmds.subscribe "gizmo buffer update"
-        Warp.run cfg.port =<< app cfg cmds chans globs.currentlyLive
+        let args = ModuleArgs{..}
+        subscribeBusEvents cmds $ allBusEvents args
+        Warp.run cfg.port =<< app args
     )
-    (\_cmds ev d -> do
-        case ev of
-          "monitor twitch stream online" -> do
-            let dstr = decodeUtf8 d
-            let live = Text.splitOn " " dstr
-            let new = Set.fromList live 
-            old <- MVar.swapMVar globs.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 chans.live $ LiveEventOnline online
-            unless (Set.null offline) . Chan.writeChan chans.live $ LiveEventOnline offline
-          "gizmo buffer update" -> do
-            let dstr = decodeUtf8 d
-            let updates = Text.splitOn " " dstr
-            forM_ updates $ Chan.writeChan chans.gizmo
-          _other -> log $ "Invalid event: " <> tshow d
+    (\cmds ev d -> do
+        let args = ModuleArgs{..}
+        handleBusEvent (allBusEvents args) ev d
     )
     (pure ())
 
-app :: Config -> Commands IO -> Channels -> MVar.MVar (Set.Set Text) -> IO Wai.Application
-app cfg _cmds chans currentlyLive = do
-  log "Connecting to database..."
-  db <- DB.connect cfg
+app :: ModuleArgs -> IO Wai.Application
+app args = do
   log "Connected! Server active."
-  st <- stateRef
   Sc.scottyApp do
     Sc.middleware . Wai.Static.staticPolicy $ mconcat
       [ Wai.Static.isNotAbsolute
@@ -104,13 +63,11 @@ app cfg _cmds chans currentlyLive = do
         , ("main.css", "main.css")
         , ("main.js", "main.js")
         ] Wai.Static.<|> Wai.Static.hasPrefix "assets"
-      , Wai.Static.addBase cfg.assetPath
+      , Wai.Static.addBase args.cfg.assetPath
       ]
-    -- Sc.get "/register" do
-    --   Sc.redirect "/register.html"
-    Sc.get "/unauthorized" do
-      Sc.status status401
-      Sc.text $ mconcat
+    onGet "/unauthorized" do
+      status status401
+      respondText $ mconcat
         [ "your request was rejected because that endpoint requires authentication\n"
         , "you can log in by POSTing your credentials to https://auth.colonq.computer/api/firstfactor\n"
         , "for example:\n"
@@ -124,129 +81,19 @@ app cfg _cmds chans currentlyLive = do
         , "for example:\n"
         , "  curl https://secure.colonq.computer --cookie cookies.txt\n"
         ]
-    Sc.get "/api/register" $ authed cfg \auth -> do
-      log "Authenticated with Twitch, trying to register..."
-      let user = Text.toLower auth.name
-      LDAP.resetUserPassword cfg user auth.id >>= \case
-        Nothing -> do
-          log "Failed to register user"
-          Sc.status status500
-          Sc.text "failed to register"
-        Just pass -> do
-          log "Successfully registered user, responding..."
-          Sc.text . Text.L.fromStrict $ user <> " " <> pass
-    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.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/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/shader" do
-      DB.get db "shader" >>= \case
-        Nothing -> do
-          Sc.status status404
-          Sc.text "no shader present"
-        Just sh -> Sc.text . Text.L.fromStrict $ decodeUtf8 sh
-    Sc.get "/api/exchange" do
-      listings <- Exchange.getOrders db
-      Sc.json listings
-    Sc.get "/api/gizmo" do
-      buf <- Sc.queryParam "buf"
-      DB.hget db "gizmos" buf >>= \case
-        Nothing -> do
-          Sc.status status404
-          Sc.text "gizmo does not exist"
-        Just html -> Sc.html . Text.L.fromStrict $ decodeUtf8 html
-    Sc.get "/api/gizmo/list" do
-      gizmos <- maybe [] (fmap decodeUtf8) <$> DB.hkeys db "gizmos"
-      Sc.text $ Text.L.fromStrict $ Text.unlines gizmos
-    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 chans.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
-                  ]
-        )
-      , ( "/api/gizmo/events", \conn -> do
-            c <- Chan.dupChan chans.gizmo
-            forever do
-              ev <- liftIO $ Chan.readChan c
-              WS.sendTextData conn ev
-        )
-      , ( "/api/model/broadcast", \conn -> do
-            forever do
-              msg <- liftIO $ WS.receiveDataMessage conn
-              Chan.writeChan chans.model msg
-        )
-      , ( "/api/model/events", \conn -> do
-            c <- Chan.dupChan chans.model
-            forever do
-              ev <- liftIO $ Chan.readChan c
-              WS.sendDataMessage conn ev
-        )
+    Misc.public args
+    TwitchAuth.public args
+    Exchange.public args
+    Gizmo.public args
+    Sentiment.public args
+    Circle.public args
+    Bells.public args
+    User.public args
+    Shader.public args
+    websocket $ mconcat
+      [ Gizmo.publicWebsockets args
+      , Circle.publicWebsockets args
+      , Model.publicWebsockets args
       ]
     Sc.notFound do
-      Sc.text "not found"
+      respondText "not found"
diff --git a/fig-web/src/Fig/Web/Secure.hs b/fig-web/src/Fig/Web/Secure.hs
index cf10bc1..22135f5 100644
--- a/fig-web/src/Fig/Web/Secure.hs
+++ b/fig-web/src/Fig/Web/Secure.hs
@@ -1,12 +1,9 @@
-module Fig.Web.Secure where
+module Fig.Web.Secure
+  ( server
+  ) where
 
 import Fig.Prelude
 
-import Data.Maybe (maybeToList)
-import qualified Data.Text as Text
-import qualified Data.Text.Lazy as Text.Lazy
-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
@@ -14,32 +11,39 @@ import qualified Network.Wai.Handler.Warp as Warp
 import qualified Web.Scotty as Sc
 
 import Fig.Bus.Binary.Client
+import Fig.Web.Types
 import Fig.Web.Utils
 import qualified Fig.Web.DB as DB
-import qualified Fig.Web.Exchange as Exchange
+import qualified Fig.Web.Module.Exchange as Exchange
+import qualified Fig.Web.Module.Exchange as Redeem
 
-data LiveEvent
-  = LiveEventOnline !(Set.Set Text)
-  | LiveEventOffline !(Set.Set Text)
-  deriving (Show, Eq, Ord)
+allBusEvents :: ModuleArgs -> BusEventHandlers
+allBusEvents args = busEvents . mconcat $ fmap ($ args)
+  [ 
+  ]
 
 server :: Config -> (Text, Text) -> IO ()
 server cfg busAddr = do
   log $ "Web server running on port " <> tshow cfg.port
+  log "Connecting to database..."
+  db <- DB.connect cfg
+  channels <- newChannels
+  globals <- newGlobals
   busClient busAddr
     (\cmds -> do
         log "Connected to bus!"
-        Warp.run cfg.port =<< app cfg cmds
+        let args = ModuleArgs{..}
+        subscribeBusEvents cmds $ allBusEvents args
+        Warp.run cfg.port =<< app args
     )
-    (\_cmds ev _d -> do
-        log $ "Invalid event: " <> tshow ev
+    (\cmds ev d -> do
+        let args = ModuleArgs{..}
+        handleBusEvent (allBusEvents args) ev d
     )
     (pure ())
 
-app :: Config -> Commands IO -> IO Wai.Application
-app cfg cmds = do
-  log "Connecting to database..."
-  db <- DB.connect cfg
+app :: ModuleArgs -> IO Wai.Application
+app args = do
   log "Connected! Secure server active."
   Sc.scottyApp do
     Sc.middleware . Wai.Static.staticPolicy $ mconcat
@@ -52,70 +56,15 @@ app cfg cmds = do
         ]
         Wai.Static.<|> Wai.Static.hasPrefix "assets"
         Wai.Static.<|> Wai.Static.hasPrefix "newton"
-      , Wai.Static.addBase cfg.assetPath
+      , Wai.Static.addBase args.cfg.assetPath
       ]
-    Sc.get "/" do
-      Sc.text "this is the secure endpoint"
-    Sc.get "/api/status" do
-      Sc.text "this is the secure endpoint"
-    Sc.get "/api/info" do
-      muser <- Sc.header "Remote-User"
-      memail <- Sc.header "Remote-Email"
-      case (muser, memail) of
-        (Just user, Just email) -> do
-          Sc.text $ user <> " " <> email
-        _else -> do
-          Sc.status status401
-          Sc.text "you're not logged in buddy"
-    Sc.post "/api/redeem" do
-      muser <- Sc.header "Remote-User"
-      memail <- Sc.header "Remote-Email"
-      case (muser, memail) of
-        (Just user, Just _email) -> do
-          name <- Sc.formParam "name"
-          input <- Sc.formParamMaybe "input"
-          liftIO . cmds.publish "frontend redeem incoming"
-            . encodeUtf8 . Text.intercalate "\t" $
-            [ Text.Lazy.toStrict user
-            , name
-            ] <> maybeToList input
-          Sc.text "it worked"
-        _else -> do
-          Sc.status status401
-          Sc.text "you're not logged in buddy"
-    Sc.post "/api/exchange" do
-      Sc.header "Remote-Email" >>= \case
-        Nothing -> do
-          Sc.status status401
-          Sc.text "you're not logged in buddy"
-        Just creator -> do
-          haveCur <- Text.Lazy.toStrict <$> Sc.formParam "haveCur"
-          haveAmount <- Sc.formParam "haveAmount"
-          wantCur <- Text.Lazy.toStrict <$> Sc.formParam "wantCur"
-          wantAmount <- Sc.formParam "wantAmount"
-          key <- Exchange.createOrder db $ Exchange.Order
-            { creator = Text.Lazy.toStrict creator
-            , haveCur = haveCur
-            , haveAmount = haveAmount
-            , wantCur = wantCur
-            , wantAmount = wantAmount
-            }
-          Sc.text . Text.Lazy.fromStrict $ decodeUtf8 key
-    Sc.post "/api/exchange/:key" do
-      Sc.header "Remote-Email" >>= \case
-        Nothing -> do
-          Sc.status status401
-          Sc.text "you're not logged in buddy"
-        Just buyer -> do
-          key <- Sc.pathParam "key"
-          Exchange.satisfyOrder db key $ Text.Lazy.toStrict buyer
-    Sc.delete "/api/exchange/:key" do
-      Sc.header "Remote-Email" >>= \case
-        Nothing -> do
-          Sc.status status401
-          Sc.text "you're not logged in buddy"
-        Just _buyer -> do
-          key <- Sc.pathParam "key"
-          Exchange.cancelOrder db key
+    onGet "/" do
+      respondText "this is the secure endpoint"
+    onGet "/api/status" do
+      respondText "this is the secure endpoint"
+    onGet "/api/info" $ authed \creds -> do
+      respondText $ creds.user <> " " <> creds.email
+    Exchange.secure args
+    Redeem.secure args
     Sc.notFound do
-      Sc.text "not found"
+      respondText "not found"
diff --git a/fig-web/src/Fig/Web/State.hs b/fig-web/src/Fig/Web/State.hs
deleted file mode 100644
index 11e0ece..0000000
--- a/fig-web/src/Fig/Web/State.hs
+++ /dev/null
@@ -1,41 +0,0 @@
-{-# 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/Types.hs b/fig-web/src/Fig/Web/Types.hs
new file mode 100644
index 0000000..0a80f47
--- /dev/null
+++ b/fig-web/src/Fig/Web/Types.hs
@@ -0,0 +1,70 @@
+module Fig.Web.Types
+  ( LiveEvent(..)
+  , Commands(..)
+  , Channels(..)
+  , newChannels
+  , Globals(..)
+  , newGlobals
+  , DB(..)
+  , ModuleArgs(..)
+  , Module
+  , Websockets
+  , BusEvents
+  ) where
+
+import Fig.Prelude
+
+import qualified Control.Concurrent.Chan as Chan
+import qualified Control.Concurrent.MVar as MVar
+
+import qualified Data.Set as Set
+
+import qualified Network.WebSockets as WS
+
+import qualified Web.Scotty as Sc
+
+import qualified Database.Redis as Redis
+
+import Fig.Bus.Binary.Client
+import Fig.Web.Utils
+
+data LiveEvent
+  = LiveEventOnline !(Set.Set Text)
+  | LiveEventOffline !(Set.Set Text)
+  deriving (Show, Eq, Ord)
+
+data Channels = Channels
+  { live :: !(Chan.Chan LiveEvent)
+  , gizmo :: !(Chan.Chan Text)
+  , model :: !(Chan.Chan WS.DataMessage)
+  }
+
+newChannels :: IO Channels
+newChannels = do
+  live <- Chan.newChan
+  gizmo <- Chan.newChan
+  model <- Chan.newChan
+  pure Channels {..}
+
+newtype Globals = Globals
+  { currentlyLive :: MVar.MVar (Set.Set Text)
+  }
+
+newGlobals :: IO Globals
+newGlobals = do
+  currentlyLive <- MVar.newMVar Set.empty
+  pure Globals {..}
+
+newtype DB = DB { conn :: Redis.Connection }
+
+data ModuleArgs = ModuleArgs
+  { cfg :: Config
+  , cmds :: Commands IO
+  , db :: DB
+  , globals :: Globals
+  , channels :: Channels
+  }
+
+type Module = ModuleArgs -> Sc.ScottyM ()
+type Websockets = ModuleArgs -> [WebsocketHandler]
+type BusEvents = ModuleArgs -> [BusEventHandler]
diff --git a/fig-web/src/Fig/Web/Utils.hs b/fig-web/src/Fig/Web/Utils.hs
index 48f2e24..8875529 100644
--- a/fig-web/src/Fig/Web/Utils.hs
+++ b/fig-web/src/Fig/Web/Utils.hs
@@ -5,12 +5,35 @@ module Fig.Web.Utils
   ( FigWebException(..)
   , loadConfig
   , Config(..)
-  , websocket
+  , resetUserPassword
   , module Network.HTTP.Types.Status
+  , onGet, onPost, onPut, onDelete
+  , status
+  , queryParam, queryParamMaybe, formParam, formParamMaybe, pathParam
+  , header
+  , respondText, respondJSON, respondHTML
+  , Credentials(..)
+  , authed
+  , WebsocketHandler
+  , websocket
+  , BusEventHandler, BusEventHandlers
+  , busEvents
+  , handleBusEvent
+  , subscribeBusEvents
   ) where
 
 import Fig.Prelude
 
+import System.Exit (ExitCode(..))
+import qualified System.Process as Proc
+
+import qualified Data.UUID as UUID
+import qualified Data.UUID.V4 as UUID
+import qualified Data.Text as Text
+import qualified Data.Text.Lazy as Text.L
+import qualified Data.Aeson as Aeson
+import qualified Data.Map.Strict as Map
+
 import Network.HTTP.Types.Status
 import qualified Network.Wai.Handler.WebSockets as Wai.WS
 import qualified Network.WebSockets as WS
@@ -19,6 +42,8 @@ import qualified Web.Scotty as Sc
 
 import qualified Toml
 
+import Fig.Bus.Binary.Client
+
 newtype FigWebException = FigWebException Text
   deriving (Show, Eq, Ord)
 instance Exception FigWebException
@@ -53,9 +78,111 @@ loadConfig path = Toml.decodeFileEither configCodec path >>= \case
   Left err -> throwM . FigWebException $ tshow err
   Right config -> pure config
 
-websocket :: [(ByteString, WS.Connection -> IO ())] -> Sc.ScottyM ()
+-- | Reset the password in LDAP for the specified user (creating the user if necessary)
+resetUserPassword :: MonadIO m => Config -> Text -> Text -> m (Maybe Text)
+resetUserPassword cfg user uid = do
+  let login = Text.toLower user
+  password <- UUID.toText <$> liftIO UUID.nextRandom
+  (exitCode, out0, err0) <- liftIO . flip Proc.readCreateProcessWithExitCode ""
+    . Proc.proc cfg.lldapCli $ unpack <$>
+    [ "-H", cfg.lldapHost
+    , "-D", cfg.lldapUser
+    , "-w", cfg.lldapPassword
+    , "user", "add", login, uid <> "@users.colonq.computer"
+    , "-p", password
+    , "-f", uid
+    ]
+  (_, out1, err1) <- liftIO . flip Proc.readCreateProcessWithExitCode ""
+    . Proc.proc cfg.lldapCli $ unpack <$>
+    [ "-H", cfg.lldapHost
+    , "-D", cfg.lldapUser
+    , "-w", cfg.lldapPassword
+    , "user", "group", "add", login, "fig_users"
+    ]
+  case exitCode of
+    ExitSuccess -> pure $ Just password
+    ExitFailure _ -> do
+      log . pack $ mconcat
+        [ "LDAP CLI error:\n"
+        , out0, err0
+        , out1, err1
+        ]
+      pure Nothing
+
+onGet :: Sc.RoutePattern -> Sc.ActionM () -> Sc.ScottyM ()
+onGet = Sc.get
+
+onPost :: Sc.RoutePattern -> Sc.ActionM () -> Sc.ScottyM ()
+onPost = Sc.post
+
+onPut :: Sc.RoutePattern -> Sc.ActionM () -> Sc.ScottyM ()
+onPut = Sc.post
+
+onDelete :: Sc.RoutePattern -> Sc.ActionM () -> Sc.ScottyM ()
+onDelete = Sc.post
+
+status :: Status -> Sc.ActionM ()
+status = Sc.status
+
+queryParam :: Sc.Parsable a => Text -> Sc.ActionM a
+queryParam = Sc.queryParam . Text.L.fromStrict
+queryParamMaybe :: Sc.Parsable a => Text -> Sc.ActionM (Maybe a)
+queryParamMaybe = Sc.queryParamMaybe . Text.L.fromStrict
+
+formParam :: Sc.Parsable a => Text -> Sc.ActionM a
+formParam = Sc.formParam . Text.L.fromStrict
+formParamMaybe :: Sc.Parsable a => Text -> Sc.ActionM (Maybe a)
+formParamMaybe = Sc.formParamMaybe . Text.L.fromStrict
+
+pathParam :: Sc.Parsable a => Text -> Sc.ActionM a
+pathParam = Sc.pathParam . Text.L.fromStrict
+
+header :: Text -> Sc.ActionM (Maybe Text)
+header h = Sc.header (Text.L.fromStrict h) >>= \case
+  Nothing -> pure Nothing
+  Just t -> pure . Just $ Text.L.toStrict t
+
+respondText :: Text -> Sc.ActionM ()
+respondText = Sc.text . Text.L.fromStrict
+
+respondJSON :: Aeson.ToJSON a => a -> Sc.ActionM ()
+respondJSON = Sc.json
+
+respondHTML :: Text -> Sc.ActionM ()
+respondHTML = Sc.html . Text.L.fromStrict
+
+data Credentials = Credentials
+  { user :: Text
+  , email :: Text
+  }
+authed :: (Credentials -> Sc.ActionM ()) -> Sc.ActionM ()
+authed h = do
+  muser <- header "Remote-User"
+  memail <- header "Remote-Email"
+  case (muser, memail) of
+    (Just user, Just email) -> do
+      let auth = Credentials{..}
+      h auth
+    _else -> do
+      status status401
+      respondText "you're not logged in buddy (this is probably a bug, go message clonk)"
+
+type WebsocketHandler = (ByteString, WS.Connection -> IO ())
+websocket :: [WebsocketHandler] -> Sc.ScottyM ()
 websocket hs = Sc.middleware $ Wai.WS.websocketsOr WS.defaultConnectionOptions handler
   where
     handler pending = case lookup (WS.requestPath (WS.pendingRequest pending)) hs of
       Nothing -> WS.rejectRequest pending ""
       Just h -> WS.acceptRequest pending >>= \c -> WS.withPingThread c 30 (pure ()) $ h c
+
+type BusEventHandler = (ByteString, ByteString -> IO ())
+type BusEventHandlers = Map.Map ByteString (ByteString -> IO ())
+busEvents :: [BusEventHandler] -> BusEventHandlers
+busEvents = Map.fromList
+handleBusEvent :: BusEventHandlers -> ByteString -> ByteString -> IO ()
+handleBusEvent hs ev d = case Map.lookup ev hs of
+  Just h -> h d
+  Nothing -> log $ "Invalid event: " <> tshow ev
+subscribeBusEvents :: Commands IO -> BusEventHandlers -> IO ()
+subscribeBusEvents cmds hs = forM_ (Map.keys hs) $ \ev -> do
+  cmds.subscribe ev