[api]: serve the butler websocket

This change provides adapter to use the butler websocket api.

monocle.cabal

@@ -201,6 +201,7 @@ library
                      , wai-logger                 >= 2.3
                      , wai-middleware-prometheus  >= 1.0
                      , warp                       >= 3.3.15
+                     , websockets
                      , witch                      >= 0.3
   hs-source-dirs:      src
   exposed-modules:     Monocle.Prelude

src/Effectful/Servant.hs

@@ -1,6 +1,6 @@
 {-# LANGUAGE AllowAmbiguousTypes #-}
 
-module Effectful.Servant (runWarpServerSettingsContext, hoistEff) where
+module Effectful.Servant (runWarpServerSettingsContext, hoistEff, handlerToEff) where
 
 import Control.Monad.Except qualified
 import Data.Kind (Type)
@@ -9,10 +9,11 @@ import Effectful
 import Effectful.Dispatch.Static qualified
 import Effectful.Dispatch.Static.Primitive qualified
 import Effectful.Error.Static (Error, runErrorNoCallStack)
+import Effectful.Error.Static qualified as E (throwError)
 import Network.Wai qualified as Wai
 import Network.Wai.Handler.Warp qualified as Warp
 import Servant
-import Prelude (error)
+import Prelude
 
 runWarpServerSettingsContext ::
   forall (api :: Type) (context :: [Type]) (es :: [Effect]).
@@ -44,3 +45,10 @@ hoistEff env ctx = Servant.serveWithContextT (Proxy @api) ctx interpretServer
       es' <- Effectful.Dispatch.Static.Primitive.cloneEnv env
       Effectful.Dispatch.Static.unEff (runErrorNoCallStack action) es'
     Control.Monad.Except.liftEither v
+
+-- | Convert a servant handler to eff
+handlerToEff :: Error Servant.ServerError Effectful.:> es => Servant.Handler a -> Eff es a
+handlerToEff (Servant.Handler (Control.Monad.Except.ExceptT action)) = do
+  Effectful.Dispatch.Static.unsafeEff_ action >>= \case
+    Left e -> E.throwError e
+    Right a -> pure a

src/Monocle/Api/Test.hs

@@ -72,7 +72,7 @@ withTestApi appEnv' testCb = bracket appEnv' cleanIndex runTest
         (\index -> runEmptyQueryM index I.ensureIndex)
         indexes
       unsafeEff $ \es ->
-        let app = Effectful.Servant.hoistEff @RootAPI es cfg (rootServer cookieCfg)
+        let app = Effectful.Servant.hoistEff @RootAPI es cfg (rootServer (error "butler ws test not implemented") cookieCfg)
             withManager manager = do
               withClient "http://localhost" (Just manager) $ \client -> do
                 testCb client

src/Monocle/Butler.hs

@@ -1,15 +1,103 @@
 -- | This module contains the new monocle app
-module Monocle.Butler where
+module Monocle.Butler (
+  -- * The websocket API
+  ButlerWSAPI,
+  butlerWsApp,
+
+  -- * UI Apps
+  dashboardApp,
+
+  -- * Adapter for running ProcessIO inside effectful
+  runButlerEffect,
+  runButlerProcess,
+  withButlerDisplay,
+) where
 
 import Butler
+import Butler.App
+import Butler.Core
+import Butler.Display
+import Butler.Display.Session
+import Butler.Display.WebSocket
+import Network.WebSockets qualified as WS
 import Prelude
 
+import Monocle.Api.Jwt (AuthenticatedUser (..), OIDCEnv)
 import Monocle.Backend.Queries qualified as Q
 import Monocle.Effects qualified as E
 import Monocle.Env qualified as M
 import Monocle.Logging qualified as E (runLoggerEffect)
 import Monocle.Prelude (runEff)
 
+import Network.HTTP.Types.Status qualified as HTTP
+import Network.Socket (SockAddr)
+import Network.Wai qualified as Wai
+import Servant qualified
+
+import Effectful (Dispatch (Static), DispatchOf, Eff, Effect, IOE, withEffToIO, (:>))
+import Effectful.Dispatch.Static (SideEffects (..), StaticRep, evalStaticRep, getStaticRep, unEff, unsafeEff, unsafeEff_)
+import Effectful.Internal.Env (cloneEnv)
+
+data ButlerEffect :: Effect
+type instance DispatchOf ButlerEffect = 'Static 'WithSideEffects
+newtype instance StaticRep ButlerEffect = ButlerEffect ProcessEnv
+
+runButlerEffect :: IOE :> es => (ProcessEnv -> Eff (ButlerEffect : es) ()) -> Eff es ()
+runButlerEffect action =
+  Effectful.Dispatch.Static.unsafeEff \es -> do
+    exit <- withButlerOS do
+      env <- ask
+      liftIO do
+        es' <- cloneEnv es
+        unEff (evalStaticRep (ButlerEffect env) (action env)) es'
+    print exit
+
+runButlerProcess :: ButlerEffect :> es => ProcessIO a -> Eff es a
+runButlerProcess action = do
+  ButlerEffect processEnv <- getStaticRep
+  unsafeEff_ $ runProcessIOEnv processEnv action
+
+_mkMiddleware :: Wai.Application -> Wai.Middleware
+_mkMiddleware app baseApp req resp = baseApp req handleAppResp
+ where
+  handleAppResp appResp = case HTTP.statusCode (Wai.responseStatus appResp) of
+    404 -> app req resp
+    _ -> resp appResp
+
+withButlerDisplay :: (IOE :> es, ButlerEffect :> es) => (Display -> Eff es a) -> Eff es a
+withButlerDisplay cb = do
+  ButlerEffect processEnv <- getStaticRep
+  withEffToIO $ \runInIO -> do
+    runProcessIOEnv processEnv $ withSessions "sessions" \sessions -> do
+      display <- atomically (newDisplay sessions)
+      liftIO $ runInIO (cb display)
+
+type ButlerWSAPI = WebSocketAPI AuthenticatedUser
+
+butlerWsApp :: Maybe OIDCEnv -> ProcessEnv -> Display -> [App] -> Servant.ServerT ButlerWSAPI Servant.Handler
+butlerWsApp mAuth processEnv display apps = websocketServer processEnv adaptMonocleSession onConnect
+ where
+  adaptMonocleSession :: Maybe AuthenticatedUser -> ProcessIO (Maybe Session)
+  adaptMonocleSession = \case
+    Nothing
+      | isNothing mAuth -> Just <$> newSession display.sessions Nothing "guest"
+      | otherwise -> pure Nothing
+    Just aUser -> do
+      let user = UserName aUser.aDefaultMuid
+          provider = externalProvider "monocle" user
+      atomically (lookupSessionByProvider display.sessions provider) >>= \case
+        Just session -> pure (Just session)
+        Nothing -> Just <$> newSession display.sessions (Just provider) user
+
+  onConnect :: SockAddr -> Workspace -> ChannelName -> Session -> WS.Connection -> ProcessIO ()
+  onConnect = connectRoute display "embeded-server-name" onClient
+
+  onClient :: OnClient
+  onClient session workspace = do
+    logInfo "New client!" ["sess" .= session, "workspace" .= workspace]
+    shared <- startApps apps display
+    pure (processEnv, staticClientHandler shared)
+
 -- Here is a demo app that only display the current change count.
 -- Given a elasticEnv, we can unwrap the effectful Eff context into butler's ProcessIO
 dashboardApp :: E.ElasticEnv -> App

src/Monocle/Main.hs

@@ -8,6 +8,7 @@ import Monocle.Api.Jwt (doGenJwk, initOIDCEnv)
 import Monocle.Api.Server (handleLoggedIn, handleLogin)
 import Monocle.Api.ServerHTMX (searchAuthorsHandler)
 import Monocle.Backend.Index qualified as I
+import Monocle.Butler qualified as B
 import Monocle.Config (getAuthProvider, opName)
 import Monocle.Config qualified as Config
 import Monocle.Env
@@ -25,6 +26,7 @@ import Prometheus (register)
 import Prometheus.Metric.GHC (ghcMetrics)
 import Servant
 import Servant.Auth.Server (CookieSettings (..), cookieXsrfSetting, defaultCookieSettings, defaultJWTSettings)
+import Servant.Auth.Server qualified as SAS (JWTSettings)
 import System.Directory qualified
 
 import Effectful qualified as E
@@ -34,11 +36,16 @@ import Effectful.Reader.Static qualified as E
 import Effectful.Servant qualified
 import Monocle.Effects
 
-rootServer :: (ApiEffects es, E.Concurrent Monocle.Prelude.:> es) => CookieSettings -> Servant.ServerT RootAPI (Eff es)
-rootServer cookieSettings = app :<|> app
+type CTX = '[SAS.JWTSettings, CookieSettings]
+
+rootServer :: forall es. (ApiEffects es, E.Concurrent Monocle.Prelude.:> es) => Servant.ServerT B.ButlerWSAPI Servant.Handler -> CookieSettings -> Servant.ServerT RootAPI (Eff es)
+rootServer wsApp cookieSettings = app :<|> app :<|> wsAppEff
  where
   app = server :<|> searchAuthorsHandler :<|> handleLogin :<|> handleLoggedIn cookieSettings
 
+  wsAppEff :: Servant.ServerT B.ButlerWSAPI (Eff es)
+  wsAppEff = Servant.hoistServerWithContext (Proxy @B.ButlerWSAPI) (Proxy @CTX) Effectful.Servant.handlerToEff wsApp
+
 fallbackWebAppPath :: FilePath
 fallbackWebAppPath = "web/build/"
 
@@ -116,7 +123,7 @@ run cfg =
       $ run' cfg aplogger
 
 run' :: (IOE Monocle.Prelude.:> es, MonoConfigEffect Monocle.Prelude.:> es) => ApiConfig -> ApacheLogger -> Eff es ()
-run' ApiConfig {..} aplogger = E.runConcurrent $ runLoggerEffect do
+run' ApiConfig {..} aplogger = B.runButlerEffect \processEnv -> B.withButlerDisplay \display -> E.runConcurrent $ runLoggerEffect do
   conf <- Config.csConfig <$> getReloadConfig
   let workspaces = Config.getWorkspaces conf
 
@@ -163,23 +170,28 @@ run' ApiConfig {..} aplogger = E.runConcurrent $ runLoggerEffect do
     let settings = Warp.setPort port $ Warp.setLogger httpLogger Warp.defaultSettings
         jwtCfg = localJWTSettings
         cookieCfg = defaultCookieSettings {cookieXsrfSetting = Nothing}
+        cfg :: Servant.Context CTX
         cfg = jwtCfg :. cookieCfg :. EmptyContext
         middleware =
           cors (const $ Just corsPolicy)
             . monitoringMiddleware
             . healthMiddleware
             . staticMiddleware
+
+    let wsApp :: Servant.ServerT B.ButlerWSAPI Servant.Handler
+        wsApp = B.butlerWsApp oidcEnv processEnv display [B.dashboardApp bhEnv]
+
     logInfo "SystemReady" ["workspace" .= length workspaces, "port" .= port, "elastic" .= elasticUrl]
 
     appEnv <- E.withEffToIO $ \effToIO -> do
       let configIO = effToIO getReloadConfig
       pure AppEnv {bhEnv, aOIDC, config = configIO}
 
-    E.runReader appEnv
-      $ Effectful.Servant.runWarpServerSettingsContext @RootAPI
+    E.runReader appEnv do
+      Effectful.Servant.runWarpServerSettingsContext @RootAPI
         settings
         cfg
-        (rootServer cookieCfg)
+        (rootServer wsApp cookieCfg)
         middleware
   case r of
     Left e -> error (show e)

src/Monocle/Servant/HTTPMain.hs

@@ -8,11 +8,13 @@ import Servant
 import Servant.Auth.Server (SetCookie)
 import Servant.HTML.Blaze (HTML)
 
+import Monocle.Butler (ButlerWSAPI)
+
 -- | The API is served at both `/api/2/` (for backward compat with the legacy nginx proxy)
 -- and `/` (for compat with crawler client)
 type MonocleAPI' = MonocleAPI :<|> HtmxAPI :<|> AuthAPI
 
-type RootAPI = "api" :> "2" :> MonocleAPI' :<|> MonocleAPI'
+type RootAPI = "api" :> "2" :> MonocleAPI' :<|> MonocleAPI' :<|> ButlerWSAPI
 
 type AuthAPI =
   "auth" :> "login" :> QueryParam "redirectUri" Text :> Get '[JSON] NoContent