summaryrefslogtreecommitdiff
path: root/fig-web
diff options
context:
space:
mode:
Diffstat (limited to 'fig-web')
-rw-r--r--fig-web/fig-web.cabal1
-rw-r--r--fig-web/main/Main.hs22
-rw-r--r--fig-web/src/Fig/Web/Auth.hs27
-rw-r--r--fig-web/src/Fig/Web/Module/Bells.hs2
-rw-r--r--fig-web/src/Fig/Web/Module/Circle.hs8
-rw-r--r--fig-web/src/Fig/Web/Module/Exchange.hs4
-rw-r--r--fig-web/src/Fig/Web/Module/Gizmo.hs6
-rw-r--r--fig-web/src/Fig/Web/Module/Misc.hs2
-rw-r--r--fig-web/src/Fig/Web/Module/Model.hs2
-rw-r--r--fig-web/src/Fig/Web/Module/Redeem.hs2
-rw-r--r--fig-web/src/Fig/Web/Module/Sentiment.hs2
-rw-r--r--fig-web/src/Fig/Web/Module/Shader.hs2
-rw-r--r--fig-web/src/Fig/Web/Module/TwitchAuth.hs2
-rw-r--r--fig-web/src/Fig/Web/Module/User.hs2
-rw-r--r--fig-web/src/Fig/Web/Public.hs8
-rw-r--r--fig-web/src/Fig/Web/Secure.hs8
-rw-r--r--fig-web/src/Fig/Web/Types.hs33
-rw-r--r--fig-web/src/Fig/Web/Utils.hs18
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
generated by cgit v1.2.3 (git 2.25.1) at 2026-05-09 07:11:41 +0000