Fix websocket handlers

2 files changed, 29 insertions, 25 deletions

diff --git a/fig-web/src/Fig/Web.hs b/fig-web/src/Fig/Web.hs
index f657094..b0a0f51 100644
--- a/fig-web/src/Fig/Web.hs
+++ b/fig-web/src/Fig/Web.hs
@@ -230,28 +230,32 @@ app cfg _cmds chans currentlyLive = do
     Sc.get "/api/gizmo/list" do
       gizmos <- maybe [] (fmap decodeUtf8) <$> DB.hkeys db "gizmos"
       Sc.text $ Text.L.fromStrict $ Text.unlines gizmos
-    websocket "/api/gizmo/events" \conn -> do
-      c <- Chan.dupChan chans.gizmo
-      forever do
-        ev <- liftIO $ Chan.readChan c
-        WS.sendTextData conn ev
     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
-            ]
+    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
+        )
+      ]
     Sc.notFound do
       Sc.text "not found"
diff --git a/fig-web/src/Fig/Web/Utils.hs b/fig-web/src/Fig/Web/Utils.hs
index 9076bd0..48f2e24 100644
--- a/fig-web/src/Fig/Web/Utils.hs
+++ b/fig-web/src/Fig/Web/Utils.hs
@@ -53,9 +53,9 @@ loadConfig path = Toml.decodeFileEither configCodec path >>= \case
   Left err -> throwM . FigWebException $ tshow err
   Right config -> pure config
 
-websocket :: ByteString -> (WS.Connection -> IO ()) -> Sc.ScottyM ()
-websocket pat h = Sc.middleware $ Wai.WS.websocketsOr WS.defaultConnectionOptions handler
+websocket :: [(ByteString, WS.Connection -> IO ())] -> Sc.ScottyM ()
+websocket hs = Sc.middleware $ Wai.WS.websocketsOr WS.defaultConnectionOptions handler
   where
-    handler pending = if WS.requestPath (WS.pendingRequest pending) == pat
-      then WS.acceptRequest pending >>= \c -> WS.withPingThread c 30 (pure ()) $ h c
-      else WS.rejectRequest pending ""
+    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