diff --git a/monocle.cabal b/monocle.cabal index adca689ca..4f9485938 100644 --- a/monocle.cabal +++ b/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 diff --git a/src/Monocle/Api/Test.hs b/src/Monocle/Api/Test.hs index 734c91599..fce3973b1 100644 --- a/src/Monocle/Api/Test.hs +++ b/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 diff --git a/src/Monocle/Butler.hs b/src/Monocle/Butler.hs index 0d4abf016..c87c1f992 100644 --- a/src/Monocle/Butler.hs +++ b/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 } diff --git a/src/Monocle/Main.hs b/src/Monocle/Main.hs index 1adf7065f..b726fb0d1 100644 --- a/src/Monocle/Main.hs +++ b/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) diff --git a/src/Monocle/Servant/HTTPMain.hs b/src/Monocle/Servant/HTTPMain.hs index 65ce009a8..8ec29020a 100644 --- a/src/Monocle/Servant/HTTPMain.hs +++ b/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