[api]: serve butler html on the "/view" route

monocle.cabal

@@ -160,6 +160,7 @@ library
                      , lens
                      , lens-aeson
                      , lucid                      >= 2.11.1
+                     , lucid-xstatic
                      , megaparsec                 >= 9
                      , morpheus-graphql-client    >= 0.27
                      , mmorph
@@ -203,6 +204,7 @@ library
                      , warp                       >= 3.3.15
                      , websockets
                      , witch                      >= 0.3
+                     , xstatic
   hs-source-dirs:      src
   exposed-modules:     Monocle.Prelude
                      , Monocle.Env

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 (error "butler ws test not implemented") cookieCfg)
+        let app = Effectful.Servant.hoistEff @RootAPI es cfg (rootServer (error "butler ws test not implemented") (error "butler html test not implemented") cookieCfg)
             withManager manager = do
               withClient "http://localhost" (Just manager) $ \client -> do
                 testCb client

src/Monocle/Butler.hs

@@ -4,6 +4,10 @@ module Monocle.Butler (
   ButlerWSAPI,
   butlerWsApp,
 
+  -- * The html API
+  ButlerHtmlAPI,
+  butlerHtmlApp,
+
   -- * UI Apps
   dashboardApp,
 
@@ -19,6 +23,7 @@ import Butler.Core
 import Butler.Display
 import Butler.Display.Session
 import Butler.Display.WebSocket
+import Butler.Frame (butlerHelpersScript)
 import Network.WebSockets qualified as WS
 import Prelude
 
@@ -28,11 +33,16 @@ import Monocle.Effects qualified as E
 import Monocle.Env qualified as M
 import Monocle.Logging qualified as E (runLoggerEffect)
 import Monocle.Prelude (runEff)
+import Monocle.Search.Query qualified as MQ
 
 import Network.HTTP.Types.Status qualified as HTTP
 import Network.Socket (SockAddr)
 import Network.Wai qualified as Wai
 import Servant qualified
+import Servant.HTML.Lucid (HTML)
+
+import Lucid.XStatic qualified
+import XStatic qualified
 
 import Effectful (Dispatch (Static), DispatchOf, Eff, Effect, IOE, withEffToIO, (:>))
 import Effectful.Dispatch.Static (SideEffects (..), StaticRep, evalStaticRep, getStaticRep, unEff, unsafeEff, unsafeEff_)
@@ -72,6 +82,20 @@ withButlerDisplay cb = do
       display <- atomically (newDisplay sessions)
       liftIO $ runInIO (cb display)
 
+type ButlerHtmlAPI = "view" Servant.:> Servant.Get '[HTML] (Html ())
+
+butlerHtmlApp :: [XStatic.XStaticFile] -> Servant.ServerT ButlerHtmlAPI Servant.Handler
+butlerHtmlApp xfiles = pure do
+  doctypehtml_ do
+    head_ do
+      title_ "Monocle"
+      meta_ [charset_ "utf-8"]
+      meta_ [name_ "viewport", content_ "width=device-width, initial-scale=1.0"]
+      Lucid.XStatic.xstaticScripts xfiles
+      script_ butlerHelpersScript
+      body_ do
+        websocketHtml (workspaceUrl Nothing)
+
 type ButlerWSAPI = WebSocketAPI AuthenticatedUser
 
 butlerWsApp :: Maybe OIDCEnv -> ProcessEnv -> Display -> [App] -> Servant.ServerT ButlerWSAPI Servant.Handler
@@ -103,13 +127,16 @@ butlerWsApp mAuth processEnv display apps = websocketServer processEnv adaptMono
 dashboardApp :: E.ElasticEnv -> App
 dashboardApp elasticEnv = defaultApp "dashboard" startDashboard
  where
-  runEffects = liftIO . runEff . E.runLoggerEffect . E.runElasticEffect elasticEnv . E.runMonoQuery queryEnv
+  runEffects queryEnv = liftIO . runEff . E.runLoggerEffect . E.runElasticEffect elasticEnv . E.runMonoQuery queryEnv
 
   startDashboard ctx = do
+    now <- liftIO getCurrentTime
+    let queryEnv = mkQueryEnv (MQ.blankQuery (MQ.yearAgo now) now)
+
     state <- newTVarIO 0
-    let getChanges = runEffects do
+    let getChanges = runEffects queryEnv do
           -- Here is the demo of using the monocle backend:
-          count <- Q.countDocs
+          count <- Q.openChangesCount
           atomically do writeTVar state count
 
     -- make a query
@@ -126,9 +153,9 @@ dashboardApp elasticEnv = defaultApp "dashboard" startDashboard
         _ -> pure ()
 
   -- TODO: make this configurable by the user.
-  queryEnv :: E.MonoQueryEnv
-  queryEnv =
+  mkQueryEnv :: MQ.Query -> E.MonoQueryEnv
+  mkQueryEnv query =
     E.MonoQueryEnv
-      { queryTarget = M.QueryWorkspace (M.mkConfig "openstack")
-      , searchQuery = undefined
+      { queryTarget = M.QueryWorkspace (M.mkConfig "monocle")
+      , searchQuery = query
       }

src/Monocle/Main.hs

@@ -28,6 +28,8 @@ import Servant
 import Servant.Auth.Server (CookieSettings (..), cookieXsrfSetting, defaultCookieSettings, defaultJWTSettings)
 import Servant.Auth.Server qualified as SAS (JWTSettings)
 import System.Directory qualified
+import XStatic qualified
+import XStatic.Butler (defaultXFiles)
 
 import Effectful qualified as E
 import Effectful.Concurrent.MVar qualified as E
@@ -38,11 +40,14 @@ import Monocle.Effects
 
 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
+rootServer :: forall es. (ApiEffects es, E.Concurrent Monocle.Prelude.:> es) => Servant.ServerT B.ButlerWSAPI Servant.Handler -> Servant.ServerT B.ButlerHtmlAPI Servant.Handler -> CookieSettings -> Servant.ServerT RootAPI (Eff es)
+rootServer wsApp htmlApp cookieSettings = app :<|> app :<|> htmlAppEff :<|> wsAppEff
  where
   app = server :<|> searchAuthorsHandler :<|> handleLogin :<|> handleLoggedIn cookieSettings
 
+  htmlAppEff :: Servant.ServerT B.ButlerHtmlAPI (Eff es)
+  htmlAppEff = Servant.hoistServerWithContext (Proxy @B.ButlerHtmlAPI) (Proxy @CTX) Effectful.Servant.handlerToEff htmlApp
+
   wsAppEff :: Servant.ServerT B.ButlerWSAPI (Eff es)
   wsAppEff = Servant.hoistServerWithContext (Proxy @B.ButlerWSAPI) (Proxy @CTX) Effectful.Servant.handlerToEff wsApp
 
@@ -172,15 +177,19 @@ run' ApiConfig {..} aplogger = B.runButlerEffect \processEnv -> B.withButlerDisp
         cookieCfg = defaultCookieSettings {cookieXsrfSetting = Nothing}
         cfg :: Servant.Context CTX
         cfg = jwtCfg :. cookieCfg :. EmptyContext
+        xfiles = defaultXFiles
         middleware =
           cors (const $ Just corsPolicy)
             . monitoringMiddleware
             . healthMiddleware
             . staticMiddleware
+            . XStatic.xstaticMiddleware xfiles
 
     let wsApp :: Servant.ServerT B.ButlerWSAPI Servant.Handler
         wsApp = B.butlerWsApp oidcEnv processEnv display [B.dashboardApp bhEnv]
 
+        htmlApp = B.butlerHtmlApp xfiles
+
     logInfo "SystemReady" ["workspace" .= length workspaces, "port" .= port, "elastic" .= elasticUrl]
 
     appEnv <- E.withEffToIO $ \effToIO -> do
@@ -191,7 +200,7 @@ run' ApiConfig {..} aplogger = B.runButlerEffect \processEnv -> B.withButlerDisp
       Effectful.Servant.runWarpServerSettingsContext @RootAPI
         settings
         cfg
-        (rootServer wsApp cookieCfg)
+        (rootServer wsApp htmlApp cookieCfg)
         middleware
   case r of
     Left e -> error (show e)

src/Monocle/Servant/HTTPMain.hs

@@ -8,13 +8,13 @@ import Servant
 import Servant.Auth.Server (SetCookie)
 import Servant.HTML.Blaze (HTML)
 
-import Monocle.Butler (ButlerWSAPI)
+import Monocle.Butler (ButlerHtmlAPI, 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' :<|> ButlerWSAPI
+type RootAPI = "api" :> "2" :> MonocleAPI' :<|> MonocleAPI' :<|> ButlerHtmlAPI :<|> ButlerWSAPI
 
 type AuthAPI =
   "auth" :> "login" :> QueryParam "redirectUri" Text :> Get '[JSON] NoContent