web: Big refactor part 2

18 files changed, 95 insertions, 56 deletions

diff --git a/fig-web/fig-web.cabal b/fig-web/fig-web.cabal
index c81f016..876d47f 100644
--- a/fig-web/fig-web.cabal
+++ b/fig-web/fig-web.cabal
@@ -58,6 +58,7 @@ library
   exposed-modules:
     Fig.Web.Utils
     Fig.Web.Types
+    Fig.Web.Auth
     Fig.Web.DB
     Fig.Web.Public
     Fig.Web.Secure
diff --git a/fig-web/main/Main.hs b/fig-web/main/Main.hs
index 8db47e2..89ac345 100644
--- a/fig-web/main/Main.hs
+++ b/fig-web/main/Main.hs
@@ -6,18 +6,28 @@ import Fig.Prelude
 
 import Options.Applicative
 
+import Fig.Web.Types
 import Fig.Web.Utils
 import qualified Fig.Web.Public as Public
 import qualified Fig.Web.Secure as Secure
 
+parsePublicOptions :: Parser PublicOptions
+parsePublicOptions = do
+  pure PublicOptions{}
+
+parseSecureOptions :: Parser SecureOptions
+parseSecureOptions = do
+  simAuth <- switch (long "sim-auth" <> help "Simulate authentication instead of actually requiring authentication proxy headers")
+  pure SecureOptions{..}
+
 data Command
-  = Public
-  | Secure
+  = Public PublicOptions
+  | Secure SecureOptions
 
 parseCommand :: Parser Command
 parseCommand = subparser $ mconcat
-  [ command "public" $ info (pure Public) (progDesc "Launch the public web server")
-  , command "secure" $ info (pure Secure) (progDesc "Launch the private web server (intended to be run behind authentication proxy)")
+  [ command "public" $ info (Public <$> parsePublicOptions) (progDesc "Launch the public web server")
+  , command "secure" $ info (Secure <$> parseSecureOptions) (progDesc "Launch the private web server (intended to be run behind authentication proxy)")
   ]
 
 data Opts = Opts
@@ -43,5 +53,5 @@ main = do
     )
   cfg <- loadConfig opts.config
   case opts.cmd of
-    Public -> Public.server cfg (opts.busHost, opts.busPort)
-    Secure -> Secure.server cfg (opts.busHost, opts.busPort)
+    Public o -> Public.server o cfg (opts.busHost, opts.busPort)
+    Secure o -> Secure.server o cfg (opts.busHost, opts.busPort)
diff --git a/fig-web/src/Fig/Web/Auth.hs b/fig-web/src/Fig/Web/Auth.hs
new file mode 100644
index 0000000..5017b3e
--- /dev/null
+++ b/fig-web/src/Fig/Web/Auth.hs
@@ -0,0 +1,27 @@
+module Fig.Web.Auth
+  ( Credentials(..)
+  , authed
+  ) where
+
+import Fig.Prelude
+
+import qualified Web.Scotty as Sc
+
+import Fig.Web.Types
+import Fig.Web.Utils
+
+data Credentials = Credentials
+  { user :: Text
+  , email :: Text
+  }
+authed :: SecureModuleArgs -> (Credentials -> Sc.ActionM ()) -> Sc.ActionM ()
+authed args 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)"
diff --git a/fig-web/src/Fig/Web/Module/Bells.hs b/fig-web/src/Fig/Web/Module/Bells.hs
index 7451079..1ae6dce 100644
--- a/fig-web/src/Fig/Web/Module/Bells.hs
+++ b/fig-web/src/Fig/Web/Module/Bells.hs
@@ -9,7 +9,7 @@ import Fig.Web.Utils
 import Fig.Web.Types
 import qualified Fig.Web.DB as DB
 
-public :: Module
+public :: PublicModule
 public a = do
   onGet "/api/songs" do
     DB.hvals a.db "songnames" >>= \case
diff --git a/fig-web/src/Fig/Web/Module/Circle.hs b/fig-web/src/Fig/Web/Module/Circle.hs
index 5c21477..5db59fb 100644
--- a/fig-web/src/Fig/Web/Module/Circle.hs
+++ b/fig-web/src/Fig/Web/Module/Circle.hs
@@ -18,13 +18,13 @@ import Fig.Utils.SExpr
 import Fig.Web.Utils
 import Fig.Web.Types
 
-public :: Module
+public :: PublicModule
 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 :: PublicWebsockets
 publicWebsockets a =
   [ ( "/api/circle/events", \conn -> do
         c <- Chan.dupChan a.channels.live
@@ -44,11 +44,11 @@ publicWebsockets a =
     )
   ]
 
-publicBusEvents :: BusEvents
+publicBusEvents :: PublicBusEvents
 publicBusEvents a =
   [ ("monitor twitch stream online", \d -> do
         let dstr = decodeUtf8 d
-        let live = Text.splitOn " " dstr
+        let live = Text.words dstr
         let new = Set.fromList live 
         old <- MVar.swapMVar a.globals.currentlyLive new
         let online = Set.difference new old
diff --git a/fig-web/src/Fig/Web/Module/Exchange.hs b/fig-web/src/Fig/Web/Module/Exchange.hs
index 32851fa..3672265 100644
--- a/fig-web/src/Fig/Web/Module/Exchange.hs
+++ b/fig-web/src/Fig/Web/Module/Exchange.hs
@@ -19,13 +19,13 @@ import qualified Data.UUID.V4 as UUID
 import Fig.Web.Utils
 import Fig.Web.Types
 
-public :: Module
+public :: PublicModule
 public a = do
   onGet "/api/exchange" do
     listings <- getOrders a.db.conn
     respondJSON listings
 
-secure :: Module
+secure :: SecureModule
 secure a = do
   onPost "/api/exchange" $ authed \creds -> do
     haveCur <- formParam "haveCur"
diff --git a/fig-web/src/Fig/Web/Module/Gizmo.hs b/fig-web/src/Fig/Web/Module/Gizmo.hs
index 8112670..0267ab6 100644
--- a/fig-web/src/Fig/Web/Module/Gizmo.hs
+++ b/fig-web/src/Fig/Web/Module/Gizmo.hs
@@ -16,7 +16,7 @@ import Fig.Web.Utils
 import Fig.Web.Types
 import qualified Fig.Web.DB as DB
 
-public :: Module
+public :: PublicModule
 public a = do
   onGet "/api/gizmo" do
     buf <- queryParam "buf"
@@ -29,7 +29,7 @@ public a = do
     gizmos <- maybe [] (fmap decodeUtf8) <$> DB.hkeys a.db "gizmos"
     respondText $ Text.unlines gizmos
 
-publicWebsockets :: Websockets
+publicWebsockets :: PublicWebsockets
 publicWebsockets a =
   [ ( "/api/gizmo/events", \conn -> do
         c <- Chan.dupChan a.channels.gizmo
@@ -39,7 +39,7 @@ publicWebsockets a =
     )
   ]
 
-publicBusEvents :: BusEvents
+publicBusEvents :: PublicBusEvents
 publicBusEvents a =
   [ ("gizmo buffer update", \d -> do
         let dstr = decodeUtf8 d
diff --git a/fig-web/src/Fig/Web/Module/Misc.hs b/fig-web/src/Fig/Web/Module/Misc.hs
index d16df6c..1bbb2ba 100644
--- a/fig-web/src/Fig/Web/Module/Misc.hs
+++ b/fig-web/src/Fig/Web/Module/Misc.hs
@@ -12,7 +12,7 @@ import Fig.Web.Utils
 import Fig.Web.Types
 import qualified Fig.Web.DB as DB
 
-public :: Module
+public :: PublicModule
 public a = do
   onGet "/api/motd" do
     log "getting motd"
diff --git a/fig-web/src/Fig/Web/Module/Model.hs b/fig-web/src/Fig/Web/Module/Model.hs
index 86f0128..527a334 100644
--- a/fig-web/src/Fig/Web/Module/Model.hs
+++ b/fig-web/src/Fig/Web/Module/Model.hs
@@ -10,7 +10,7 @@ import qualified Network.WebSockets as WS
 
 import Fig.Web.Types
 
-publicWebsockets :: Websockets
+publicWebsockets :: PublicWebsockets
 publicWebsockets a =
   [ ( "/api/model/broadcast", \conn -> do
         forever do
diff --git a/fig-web/src/Fig/Web/Module/Redeem.hs b/fig-web/src/Fig/Web/Module/Redeem.hs
index 2d72f66..fd174f6 100644
--- a/fig-web/src/Fig/Web/Module/Redeem.hs
+++ b/fig-web/src/Fig/Web/Module/Redeem.hs
@@ -10,7 +10,7 @@ import qualified Data.Text as Text
 import Fig.Web.Utils
 import Fig.Web.Types
 
-secure :: Module
+secure :: SecureModule
 secure a = do
   onGet "/api/redeeminfo" do
     respondText "hiiiiiii"
diff --git a/fig-web/src/Fig/Web/Module/Sentiment.hs b/fig-web/src/Fig/Web/Module/Sentiment.hs
index 38a9250..6b99873 100644
--- a/fig-web/src/Fig/Web/Module/Sentiment.hs
+++ b/fig-web/src/Fig/Web/Module/Sentiment.hs
@@ -8,7 +8,7 @@ import Fig.Web.Utils
 import Fig.Web.Types
 import qualified Fig.Web.DB as DB
 
-public :: Module
+public :: PublicModule
 public a = do
   onGet "/api/sentiment" do
     s <- DB.get a.db "sentiment" >>= \case
diff --git a/fig-web/src/Fig/Web/Module/Shader.hs b/fig-web/src/Fig/Web/Module/Shader.hs
index d4b43cc..cb21d30 100644
--- a/fig-web/src/Fig/Web/Module/Shader.hs
+++ b/fig-web/src/Fig/Web/Module/Shader.hs
@@ -8,7 +8,7 @@ import Fig.Web.Utils
 import Fig.Web.Types
 import qualified Fig.Web.DB as DB
 
-public :: Module
+public :: PublicModule
 public a = do
   onGet "/api/shader" do
     DB.get a.db "shader" >>= \case
diff --git a/fig-web/src/Fig/Web/Module/TwitchAuth.hs b/fig-web/src/Fig/Web/Module/TwitchAuth.hs
index 4847da6..80d2380 100644
--- a/fig-web/src/Fig/Web/Module/TwitchAuth.hs
+++ b/fig-web/src/Fig/Web/Module/TwitchAuth.hs
@@ -21,7 +21,7 @@ import qualified Jose.Jwt as Jwt
 import Fig.Web.Utils
 import Fig.Web.Types
 
-public :: Module
+public :: PublicModule
 public a = do
   onGet "/api/register" $ twitchAuthed a.cfg \auth -> do
     log "Authenticated with Twitch, trying to register..."
diff --git a/fig-web/src/Fig/Web/Module/User.hs b/fig-web/src/Fig/Web/Module/User.hs
index 5b27b2d..6983906 100644
--- a/fig-web/src/Fig/Web/Module/User.hs
+++ b/fig-web/src/Fig/Web/Module/User.hs
@@ -10,7 +10,7 @@ import Fig.Web.Utils
 import Fig.Web.Types
 import qualified Fig.Web.DB as DB
 
-public :: Module
+public :: PublicModule
 public a = do
   onGet "/api/user/:name" do
     name <- Text.toLower <$> pathParam "name"
diff --git a/fig-web/src/Fig/Web/Public.hs b/fig-web/src/Fig/Web/Public.hs
index cd37d4e..1ff9962 100644
--- a/fig-web/src/Fig/Web/Public.hs
+++ b/fig-web/src/Fig/Web/Public.hs
@@ -25,14 +25,14 @@ import qualified Fig.Web.Module.Bells as Bells
 import qualified Fig.Web.Module.User as User
 import qualified Fig.Web.Module.Shader as Shader
 
-allBusEvents :: ModuleArgs -> BusEventHandlers
+allBusEvents :: PublicModuleArgs -> BusEventHandlers
 allBusEvents args = busEvents . mconcat $ fmap ($ args)
   [ Gizmo.publicBusEvents
   , Circle.publicBusEvents
   ]
 
-server :: Config -> (Text, Text) -> IO ()
-server cfg busAddr = do
+server :: PublicOptions -> Config -> (Text, Text) -> IO ()
+server options cfg busAddr = do
   log $ "Web server running on port " <> tshow cfg.port
   log "Connecting to database..."
   db <- DB.connect cfg
@@ -51,7 +51,7 @@ server cfg busAddr = do
     )
     (pure ())
 
-app :: ModuleArgs -> IO Wai.Application
+app :: PublicModuleArgs -> IO Wai.Application
 app args = do
   log "Connected! Server active."
   Sc.scottyApp do
diff --git a/fig-web/src/Fig/Web/Secure.hs b/fig-web/src/Fig/Web/Secure.hs
index b47c019..a334570 100644
--- a/fig-web/src/Fig/Web/Secure.hs
+++ b/fig-web/src/Fig/Web/Secure.hs
@@ -17,13 +17,13 @@ import qualified Fig.Web.DB as DB
 import qualified Fig.Web.Module.Exchange as Exchange
 import qualified Fig.Web.Module.Redeem as Redeem
 
-allBusEvents :: ModuleArgs -> BusEventHandlers
+allBusEvents :: SecureModuleArgs -> BusEventHandlers
 allBusEvents args = busEvents . mconcat $ fmap ($ args)
   [ 
   ]
 
-server :: Config -> (Text, Text) -> IO ()
-server cfg busAddr = do
+server :: SecureOptions -> Config -> (Text, Text) -> IO ()
+server options cfg busAddr = do
   log $ "Web server running on port " <> tshow cfg.port
   log "Connecting to database..."
   db <- DB.connect cfg
@@ -42,7 +42,7 @@ server cfg busAddr = do
     )
     (pure ())
 
-app :: ModuleArgs -> IO Wai.Application
+app :: SecureModuleArgs -> IO Wai.Application
 app args = do
   log "Connected! Secure server active."
   Sc.scottyApp do
diff --git a/fig-web/src/Fig/Web/Types.hs b/fig-web/src/Fig/Web/Types.hs
index 0a80f47..94a3a65 100644
--- a/fig-web/src/Fig/Web/Types.hs
+++ b/fig-web/src/Fig/Web/Types.hs
@@ -7,9 +7,11 @@ module Fig.Web.Types
   , newGlobals
   , DB(..)
   , ModuleArgs(..)
-  , Module
-  , Websockets
-  , BusEvents
+  , PublicOptions(..), SecureOptions(..)
+  , PublicModuleArgs, SecureModuleArgs
+  , PublicModule, SecureModule
+  , PublicWebsockets, SecureWebsockets
+  , PublicBusEvents, SecureBusEvents
   ) where
 
 import Fig.Prelude
@@ -57,14 +59,31 @@ newGlobals = do
 
 newtype DB = DB { conn :: Redis.Connection }
 
-data ModuleArgs = ModuleArgs
+data ModuleArgs o = ModuleArgs
   { cfg :: Config
   , cmds :: Commands IO
   , db :: DB
   , globals :: Globals
   , channels :: Channels
+  , options :: o
   }
 
-type Module = ModuleArgs -> Sc.ScottyM ()
-type Websockets = ModuleArgs -> [WebsocketHandler]
-type BusEvents = ModuleArgs -> [BusEventHandler]
+data PublicOptions = PublicOptions
+  {
+  }
+
+newtype SecureOptions = SecureOptions
+  { simAuth :: Bool
+  }
+
+type PublicModuleArgs = ModuleArgs PublicOptions
+type SecureModuleArgs = ModuleArgs SecureOptions 
+
+type PublicModule = PublicModuleArgs -> Sc.ScottyM ()
+type SecureModule = SecureModuleArgs -> Sc.ScottyM ()
+
+type PublicWebsockets = PublicModuleArgs -> [WebsocketHandler]
+type SecureWebsockets = SecureModuleArgs -> [WebsocketHandler]
+
+type PublicBusEvents = PublicModuleArgs -> [BusEventHandler]
+type SecureBusEvents = SecureModuleArgs -> [BusEventHandler]
diff --git a/fig-web/src/Fig/Web/Utils.hs b/fig-web/src/Fig/Web/Utils.hs
index ee7fdf7..fbe17bf 100644
--- a/fig-web/src/Fig/Web/Utils.hs
+++ b/fig-web/src/Fig/Web/Utils.hs
@@ -12,8 +12,6 @@ module Fig.Web.Utils
   , queryParam, queryParamMaybe, formParam, formParamMaybe, pathParam
   , header
   , respondText, respondJSON, respondHTML
-  , Credentials(..)
-  , authed
   , WebsocketHandler
   , websocket
   , BusEventHandler, BusEventHandlers
@@ -151,22 +149,6 @@ 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