From bb9c95a4b9161d3bd93b3324dd6b7414fe2d7706 Mon Sep 17 00:00:00 2001 From: Sridhar Ratnakumar <3998+srid@users.noreply.github.com> Date: Mon, 26 Apr 2021 12:46:35 -0400 Subject: [PATCH] Add logging support (#17) * Prototype logging using monad-logger-extras * Use logging in Server.hs * Add logging to generate * Cleanup websocket logging * Cleanups --- README.md | 4 +- docs/concepts.md | 1 + docs/concepts/logging.md | 6 ++ docs/guide/model.md | 1 + ema.cabal | 5 +- flake.nix | 1 + src/Ema.hs | 1 + src/Ema/App.hs | 47 ++++----- src/Ema/Class.hs | 9 ++ src/Ema/Example/Ex02_Clock.hs | 4 +- src/Ema/Example/Ex03_Documentation.hs | 12 ++- src/Ema/Generate.hs | 41 +++++--- src/Ema/Helper/FileSystem.hs | 59 ++++++++--- src/Ema/Server.hs | 143 ++++++++++++++------------ 14 files changed, 207 insertions(+), 127 deletions(-) create mode 100644 docs/concepts/logging.md diff --git a/README.md b/README.md index 503ebbe..e27b83b 100644 --- a/README.md +++ b/README.md @@ -2,7 +2,7 @@ -Ema is a next-gen **Haskell** library for building [jamstack-style](https://jamstack.org/) static sites, with fast hot reload. See [ema.srid.ca](https://ema.srid.ca/) for documentation. +Ema is a next-gen **Haskell** library for building [jamstack-style](https://jamstack.org/) static sites, with fast hot reload. See [ema.srid.ca](https://ema.srid.ca/) for further information. The simplest Ema app looks like this: @@ -10,7 +10,7 @@ The simplest Ema app looks like this: main :: IO () main = do let name :: Text = "Ema" - runEmaPure $ + runEmaPure $ \_ -> encodeUtf8 $ "Hello, from " <> name ``` diff --git a/docs/concepts.md b/docs/concepts.md index a9b70bd..85fb224 100644 --- a/docs/concepts.md +++ b/docs/concepts.md @@ -4,4 +4,5 @@ * [LVar](concepts/lvar.md) * [Slug](concepts/slug.md) * [CLI](concepts/cli.md) +* [Logging](concepts/logging.md) * [Haskell's Safety](concepts/haskell-safety.md) \ No newline at end of file diff --git a/docs/concepts/logging.md b/docs/concepts/logging.md new file mode 100644 index 0000000..30792ae --- /dev/null +++ b/docs/concepts/logging.md @@ -0,0 +1,6 @@ +# Logging + +TODO + +- monad-logger +- CLI log levels diff --git a/docs/guide/model.md b/docs/guide/model.md index 87cb786..cda0d2e 100644 --- a/docs/guide/model.md +++ b/docs/guide/model.md @@ -3,6 +3,7 @@ TODO - What's a "model"? + - Represents all the 'state' in your app. - Any Haskell type - Stored in `LVar` to enable hot-reload - `LVar.set` and `LVar.modify` diff --git a/ema.cabal b/ema.cabal index 8457fe7..612e723 100644 --- a/ema.cabal +++ b/ema.cabal @@ -38,18 +38,21 @@ library build-depends: , aeson , async - , base ^>=4.14.1.0 + , base ^>=4.14.1.0 , containers , data-default , directory , filepath , http-types + , monad-logger + , monad-logger-extras , neat-interpolation , optparse-applicative , relude , safe-exceptions , stm , text + , unliftio , wai , wai-middleware-static , wai-websockets diff --git a/flake.nix b/flake.nix index df181da..f5208bb 100644 --- a/flake.nix +++ b/flake.nix @@ -21,6 +21,7 @@ inherit name returnShellEnv; root = ./.; withHoogle = false; + overrides = self: super: with pkgs.haskell.lib; { }; modifier = drv: pkgs.haskell.lib.addBuildTools drv (with pkgs.haskellPackages; [ diff --git a/src/Ema.hs b/src/Ema.hs index 7d0e755..96724f0 100644 --- a/src/Ema.hs +++ b/src/Ema.hs @@ -6,4 +6,5 @@ module Ema where import Ema.App as X +import Ema.Class as X import Ema.Route as X diff --git a/src/Ema/App.hs b/src/Ema/App.hs index 3108b17..1a8d207 100644 --- a/src/Ema/App.hs +++ b/src/Ema/App.hs @@ -1,4 +1,6 @@ +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} @@ -6,20 +8,21 @@ module Ema.App ( runEma, runEmaPure, runEmaWithCli, - Ema (..), + MonadEma, ) where import Control.Concurrent (threadDelay) import Control.Concurrent.Async (race_) +import Control.Monad.Logger +import Control.Monad.Logger.Extras import Data.LVar (LVar) import qualified Data.LVar as LVar import Ema.CLI (Action (..), Cli) import qualified Ema.CLI as CLI -import Ema.Class (Ema (..)) +import Ema.Class (Ema (..), MonadEma) import qualified Ema.Generate as Generate import qualified Ema.Server as Server -import GHC.IO.Handle (BufferMode (LineBuffering), hSetBuffering) import System.Directory (getCurrentDirectory, withCurrentDirectory) import System.Environment (lookupEnv) @@ -31,13 +34,12 @@ import System.Environment (lookupEnv) -- function. runEmaPure :: -- | How to render a route - (Cli -> LByteString) -> + (CLI.Action -> LByteString) -> IO () -runEmaPure html = do - cli <- CLI.cliAction - runEmaWithCli cli (\_ () () -> html cli) $ \model -> do +runEmaPure render = do + runEma (\act () () -> render act) $ \model -> do LVar.set model () - threadDelay maxBound + liftIO $ threadDelay maxBound -- | Convenient version of @runEmaWith@ that takes initial model and an update -- function. You typically want to use this. @@ -51,7 +53,7 @@ runEma :: (CLI.Action -> model -> route -> LByteString) -> -- | A long-running IO action that will update the @model@ @LVar@ over time. -- This IO action must set the initial model value in the very beginning. - (LVar model -> IO ()) -> + (forall m. MonadEma m => LVar model -> m ()) -> IO () runEma render runModel = do cli <- CLI.cliAction @@ -68,26 +70,26 @@ runEmaWithCli :: (CLI.Action -> model -> route -> LByteString) -> -- | A long-running IO action that will update the @model@ @LVar@ over time. -- This IO action must set the initial model value in the very beginning. - (LVar model -> IO ()) -> + (forall m. MonadEma m => LVar model -> m ()) -> IO () runEmaWithCli cli render runModel = do model <- LVar.empty - -- TODO: Use a logging library, in place of managing buffering and using putStrLn - hSetBuffering stdout LineBuffering - hSetBuffering stderr LineBuffering + -- TODO: Allow library users to control logging levels + let logger = colorize logToStdout withCurrentDirectory (CLI.workingDir cli) $ do cwd <- getCurrentDirectory - putStrLn $ "Running Ema under: " <> cwd - putStrLn "Waiting for initial site model ..." - putStrLn " stuck here? set a model value using `LVar.set`" + flip runLoggerLoggingT logger $ do + logInfoN $ "Running Ema under: " <> toText cwd + logInfoN "Waiting for initial site model ..." + logInfoN " stuck here? set a model value using `LVar.set`" race_ - (runModel model) - (runEmaWithCliInCwd (CLI.action cli) model render) + (flip runLoggerLoggingT logger $ runModel model) + (flip runLoggerLoggingT logger $ runEmaWithCliInCwd (CLI.action cli) model render) -- | Run Ema live dev server runEmaWithCliInCwd :: - forall model route. - (Ema model route, Show route) => + forall model route m. + (MonadEma m, Ema model route, Show route) => -- | CLI arguments CLI.Action -> -- | Your site model type, as a @LVar@ in order to support modifications over @@ -101,7 +103,7 @@ runEmaWithCliInCwd :: -- @route@ type as arguments. It must return the raw HTML to render to browser -- or generate on disk. (Action -> model -> route -> LByteString) -> - IO () + m () runEmaWithCliInCwd cliAction model render = do case cliAction of Generate dest -> do @@ -109,6 +111,5 @@ runEmaWithCliInCwd cliAction model render = do Generate.generate dest val (render cliAction) Run -> do void $ LVar.get model - port <- fromMaybe 8000 . (readMaybe @Int =<<) <$> lookupEnv "PORT" - putStrLn $ "Launching Ema at http://localhost:" <> show port + port <- liftIO $ fromMaybe 8000 . (readMaybe @Int =<<) <$> lookupEnv "PORT" Server.runServerWithWebSocketHotReload port model (render cliAction) diff --git a/src/Ema/Class.hs b/src/Ema/Class.hs index 0c319b0..bb35a54 100644 --- a/src/Ema/Class.hs +++ b/src/Ema/Class.hs @@ -1,10 +1,19 @@ +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} module Ema.Class where +import Control.Monad.Logger (MonadLoggerIO) import Ema.Route.Slug (Slug) +import UnliftIO (MonadUnliftIO) + +type MonadEma m = + ( MonadIO m, + MonadUnliftIO m, + MonadLoggerIO m + ) -- | Enrich a model to work with Ema class Ema model route | route -> model where diff --git a/src/Ema/Example/Ex02_Clock.hs b/src/Ema/Example/Ex02_Clock.hs index 789fc74..1547dbf 100644 --- a/src/Ema/Example/Ex02_Clock.hs +++ b/src/Ema/Example/Ex02_Clock.hs @@ -40,8 +40,8 @@ main :: IO () main = do runEma render $ \model -> forever $ do - LVar.set model =<< getCurrentTime - threadDelay $ 1 * 1000000 + LVar.set model =<< liftIO getCurrentTime + liftIO $ threadDelay $ 1 * 1000000 render :: Ema.CLI.Action -> UTCTime -> Route -> LByteString render emaAction now r = diff --git a/src/Ema/Example/Ex03_Documentation.hs b/src/Ema/Example/Ex03_Documentation.hs index 87c7134..294842d 100644 --- a/src/Ema/Example/Ex03_Documentation.hs +++ b/src/Ema/Example/Ex03_Documentation.hs @@ -16,6 +16,7 @@ import qualified Commonmark as CM import qualified Commonmark.Extensions as CE import qualified Commonmark.Pandoc as CP import Control.Exception (throw) +import Control.Monad.Logger import qualified Data.LVar as LVar import qualified Data.List.NonEmpty as NE import qualified Data.Map.Strict as Map @@ -91,28 +92,31 @@ instance Ema MarkdownSources MarkdownPath where staticAssets _ = ["manifest.json", "ema.svg"] +log :: MonadLogger m => Text -> m () +log = logInfoNS "Ex03_Documentation" + main :: IO () main = runEma render $ \model -> do LVar.set model =<< do - putStrLn "Loading .md files" mdFiles <- FileSystem.filesMatching "." ["**/*.md"] forM mdFiles readSource <&> Tagged . Map.fromList . catMaybes FileSystem.onChange "." $ \fp -> \case FileSystem.Update -> whenJustM (readSource fp) $ \(spath, s) -> do - putStrLn $ "Update: " <> show spath + log $ "Update: " <> show spath LVar.modify model $ Tagged . Map.insert spath s . untag FileSystem.Delete -> whenJust (mkMarkdownPath fp) $ \spath -> do - putStrLn $ "Delete: " <> show spath + log $ "Delete: " <> show spath LVar.modify model $ Tagged . Map.delete spath . untag where - readSource :: FilePath -> IO (Maybe (MarkdownPath, Pandoc)) + readSource :: (MonadIO m, MonadLogger m) => FilePath -> m (Maybe (MarkdownPath, Pandoc)) readSource fp = runMaybeT $ do spath :: MarkdownPath <- MaybeT $ pure $ mkMarkdownPath fp + log $ "Reading " <> toText fp s <- readFileText fp pure (spath, parseMarkdown s) diff --git a/src/Ema/Generate.hs b/src/Ema/Generate.hs index ff1bb74..2910ba6 100644 --- a/src/Ema/Generate.hs +++ b/src/Ema/Generate.hs @@ -5,30 +5,35 @@ module Ema.Generate where import Control.Exception (throw) +import Control.Monad.Logger import Ema.Class import Ema.Route (routeFile) import System.Directory (copyFile, createDirectoryIfMissing, doesDirectoryExist, doesFileExist) import System.FilePath (takeDirectory, ()) import System.FilePattern.Directory (getDirectoryFiles) +log :: MonadLogger m => LogLevel -> Text -> m () +log = logWithoutLoc "Generate" + generate :: - forall model route. - Ema model route => + forall model route m. + (MonadEma m, Ema model route) => FilePath -> model -> (model -> route -> LByteString) -> - IO () + m () generate dest model render = do - unlessM (doesDirectoryExist dest) $ do + unlessM (liftIO $ doesDirectoryExist dest) $ do error "Destination does not exist" let routes = staticRoutes model - putStrLn $ "Writing " <> show (length routes) <> " routes" + log LevelInfo $ "Writing " <> show (length routes) <> " routes" forM_ routes $ \r -> do let fp = dest routeFile @model r - putStrLn $ "W " <> fp + log LevelInfo $ toText $ "W " <> fp let !s = render model r - createDirectoryIfMissing True (takeDirectory fp) - writeFileLBS fp s + liftIO $ do + createDirectoryIfMissing True (takeDirectory fp) + writeFileLBS fp s forM_ (staticAssets $ Proxy @route) $ \staticPath -> do copyDirRecursively staticPath dest @@ -36,26 +41,28 @@ newtype StaticAssetMissing = StaticAssetMissing FilePath deriving (Show, Exception) copyDirRecursively :: + MonadEma m => -- | Source file or directory relative to CWD that will be copied FilePath -> -- | Directory *under* which the source file/dir will be copied FilePath -> - IO () + m () copyDirRecursively srcRel destParent = - doesFileExist srcRel >>= \case + liftIO (doesFileExist srcRel) >>= \case True -> do let b = destParent srcRel - putStrLn $ "C " <> b - copyFile srcRel b + log LevelInfo $ toText $ "C " <> b + liftIO $ copyFile srcRel b False -> - doesDirectoryExist srcRel >>= \case + liftIO (doesDirectoryExist srcRel) >>= \case False -> throw $ StaticAssetMissing srcRel True -> do - fs <- getDirectoryFiles srcRel ["**"] + fs <- liftIO $ getDirectoryFiles srcRel ["**"] forM_ fs $ \fp -> do let a = srcRel fp b = destParent srcRel fp - putStrLn $ "C " <> b - createDirectoryIfMissing True (takeDirectory b) - copyFile a b + log LevelInfo $ toText $ "C " <> b + liftIO $ do + createDirectoryIfMissing True (takeDirectory b) + copyFile a b diff --git a/src/Ema/Helper/FileSystem.hs b/src/Ema/Helper/FileSystem.hs index 2678e03..6ceeaa9 100644 --- a/src/Ema/Helper/FileSystem.hs +++ b/src/Ema/Helper/FileSystem.hs @@ -1,46 +1,75 @@ +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeFamilies #-} -- | Helper to read a directory of files, and observe it for changes. -- -- Use @new@ in conjunction with @observe@ in your @runEma@ function call. -module Ema.Helper.FileSystem where +module Ema.Helper.FileSystem + ( filesMatching, + onChange, + FileAction (..), + ) +where import Control.Concurrent (threadDelay) import Control.Exception (finally) +import Control.Monad.Logger +import Ema.App (MonadEma) import System.Directory (canonicalizePath) import System.FSNotify - ( Event (..), - watchTree, - withManager, - ) import System.FilePath (makeRelative) import System.FilePattern (FilePattern) import System.FilePattern.Directory (getDirectoryFiles) +import UnliftIO (withRunInIO) type FolderPath = FilePath -filesMatching :: FolderPath -> [FilePattern] -> IO [FilePath] +log :: MonadLogger m => LogLevel -> Text -> m () +log = logWithoutLoc "Helper.FileSystem" + +filesMatching :: MonadEma m => FolderPath -> [FilePattern] -> m [FilePath] filesMatching parent' pats = do - parent <- canonicalizePath parent' - getDirectoryFiles parent pats + parent <- liftIO $ canonicalizePath parent' + log LevelInfo $ toText $ "Traversing " <> parent <> " for files matching " <> show pats + liftIO $ getDirectoryFiles parent pats data FileAction = Update | Delete deriving (Eq, Show) -onChange :: FolderPath -> (FilePath -> FileAction -> IO ()) -> IO () +onChange :: forall m. MonadEma m => FolderPath -> (FilePath -> FileAction -> m ()) -> m () onChange parent' f = do -- NOTE: It is important to use canonical path, because this will allow us to -- transform fsnotify event's (absolute) path into one that is relative to -- @parent'@ (as passed by user), which is what @f@ will expect. - parent <- canonicalizePath parent' - withManager $ \mgr -> do - stop <- watchTree mgr parent (const True) $ \event -> do - print event + parent <- liftIO $ canonicalizePath parent' + withManagerM $ \mgr -> do + log LevelInfo $ toText $ "Monitoring " <> parent <> " for changes" + stop <- watchTreeM mgr parent (const True) $ \event -> do + log LevelDebug $ show event let rel = makeRelative parent case event of Added (rel -> fp) _ _ -> f fp Update Modified (rel -> fp) _ _ -> f fp Update Removed (rel -> fp) _ _ -> f fp Delete Unknown (rel -> fp) _ _ -> f fp Delete - threadDelay maxBound - `finally` stop + liftIO $ threadDelay maxBound `finally` stop + +withManagerM :: + MonadEma m => + (WatchManager -> m a) -> + m a +withManagerM f = do + withRunInIO $ \run -> + withManager $ \mgr -> run (f mgr) + +watchTreeM :: + forall m. + MonadEma m => + WatchManager -> + FilePath -> + ActionPredicate -> + (Event -> m ()) -> + m StopListening +watchTreeM wm fp pr f = + withRunInIO $ \run -> + watchTree wm fp pr $ \evt -> run (f evt) diff --git a/src/Ema/Server.hs b/src/Ema/Server.hs index 0a6987a..926e784 100644 --- a/src/Ema/Server.hs +++ b/src/Ema/Server.hs @@ -6,10 +6,11 @@ module Ema.Server where import Control.Concurrent.Async (race) import Control.Exception (catch, try) +import Control.Monad.Logger import Data.LVar (LVar) import qualified Data.LVar as LVar import qualified Data.Text as T -import Ema.Class (Ema (decodeRoute, staticAssets)) +import Ema.Class (Ema (decodeRoute, staticAssets), MonadEma) import GHC.IO.Unsafe (unsafePerformIO) import NeatInterpolation (text) import qualified Network.HTTP.Types as H @@ -20,82 +21,98 @@ import qualified Network.Wai.Middleware.Static as Static import Network.WebSockets (ConnectionException) import qualified Network.WebSockets as WS import Relude.Extra.Foldable1 (foldl1') +import Text.Printf (printf) runServerWithWebSocketHotReload :: - forall model route. - (Ema model route, Show route) => + forall model route m. + (Ema model route, Show route, MonadEma m) => Int -> LVar model -> (model -> route -> LByteString) -> - IO () + m () runServerWithWebSocketHotReload port model render = do let settings = Warp.setPort port Warp.defaultSettings - Warp.runSettings settings $ assetsMiddleware $ WaiWs.websocketsOr WS.defaultConnectionOptions wsApp httpApp + logger <- askLoggerIO + + logInfoN $ "Launching Ema at http://localhost:" <> show port + liftIO $ + Warp.runSettings settings $ + assetsMiddleware $ + WaiWs.websocketsOr + WS.defaultConnectionOptions + (flip runLoggingT logger . wsApp) + (httpApp logger) where wsApp pendingConn = do - conn :: WS.Connection <- WS.acceptRequest pendingConn - WS.withPingThread conn 30 (pure ()) $ do - subId <- LVar.addListener model - let log s = putTextLn $ "[" <> show subId <> "] :: " <> s - log "ws:connected" - let askClientForRoute = do - msg :: Text <- WS.receiveData conn - pure $ - msg - & pathInfoFromWsMsg - & routeFromPathInfo - & fromMaybe (error "invalid route from ws") - loop = do - -- Notice that we @askClientForRoute@ in succession twice here. - -- The first route will be the route the client intends to observe - -- for changes on. The second route, *if* it is sent, indicates - -- that the client wants to *switch* to that route. This proecess - -- repeats ad infinitum: i.e., the third route is for observing - -- changes, the fourth route is for switching to, and so on. - watchingRoute <- askClientForRoute - log $ "[Watch]: <~~ " <> show watchingRoute - -- Listen *until* either we get a new value, or the client requests - -- to switch to a new route. - race (LVar.listenNext model subId) askClientForRoute >>= \case - Left newHtml -> do - -- The page the user is currently viewing has changed. Send - -- the new HTML to them. - WS.sendTextData conn $ renderWithEmaHtmlShims newHtml watchingRoute - log $ "[Watch]: ~~> " <> show watchingRoute - loop - Right nextRoute -> do - -- The user clicked on a route link; send them the HTML for - -- that route this time, ignoring what we are watching - -- currently (we expect the user to initiate a watch route - -- request immediately following this). - log $ "[Switch]: <~~ " <> show nextRoute - html <- LVar.get model - WS.sendTextData conn $ renderWithEmaHtmlShims html nextRoute - log $ "[Switch]: ~~> " <> show nextRoute - loop - try loop >>= \case - Right () -> pure () - Left (err :: ConnectionException) -> do - log $ "ws:error " <> show err - LVar.removeListener model subId + conn :: WS.Connection <- lift $ WS.acceptRequest pendingConn + logger <- askLoggerIO + lift $ + WS.withPingThread conn 30 (pure ()) $ + flip runLoggingT logger $ do + subId <- LVar.addListener model + let log s = logDebugNS (toText @String $ printf "WS.Client.%.2d" subId) s + log "Connected" + let askClientForRoute = do + msg :: Text <- WS.receiveData conn + pure $ + msg + & pathInfoFromWsMsg + & routeFromPathInfo + & fromMaybe (error "invalid route from ws") + loop = flip runLoggingT logger $ do + -- Notice that we @askClientForRoute@ in succession twice here. + -- The first route will be the route the client intends to observe + -- for changes on. The second route, *if* it is sent, indicates + -- that the client wants to *switch* to that route. This proecess + -- repeats ad infinitum: i.e., the third route is for observing + -- changes, the fourth route is for switching to, and so on. + watchingRoute <- liftIO askClientForRoute + log $ "<~~ " <> show watchingRoute + -- Listen *until* either we get a new value, or the client requests + -- to switch to a new route. + liftIO $ do + race (LVar.listenNext model subId) askClientForRoute >>= \res -> flip runLoggingT logger $ case res of + Left newHtml -> do + -- The page the user is currently viewing has changed. Send + -- the new HTML to them. + liftIO $ WS.sendTextData conn $ renderWithEmaHtmlShims newHtml watchingRoute + log $ " ~~> " <> show watchingRoute + lift loop + Right nextRoute -> do + -- The user clicked on a route link; send them the HTML for + -- that route this time, ignoring what we are watching + -- currently (we expect the user to initiate a watch route + -- request immediately following this). + log $ "[Switch]: <~~ " <> show nextRoute + html <- LVar.get model + liftIO $ WS.sendTextData conn $ renderWithEmaHtmlShims html nextRoute + log $ "[Switch]: ~~> " <> show nextRoute + lift loop + liftIO (try loop) >>= \case + Right () -> pure () + Left (err :: ConnectionException) -> do + log $ "ws:error " <> show err + LVar.removeListener model subId assetsMiddleware = do case nonEmpty (staticAssets $ Proxy @route) of Nothing -> id - Just assets -> + Just topLevelPaths -> let assetPolicy :: Static.Policy = - foldl1' (Static.<|>) $ Static.hasPrefix <$> assets + foldl1' (Static.<|>) $ Static.hasPrefix <$> topLevelPaths in Static.staticPolicy assetPolicy - httpApp req f = do - let mr = routeFromPathInfo (Wai.pathInfo req) - putStrLn $ "[http] " <> show mr - (status, v) <- case mr of - Nothing -> - pure (H.status404, "No route") - Just r -> do - val <- LVar.get model - let html = renderCatchingErrors val r - pure (H.status200, html <> emaStatusHtml <> wsClientShim) - f $ Wai.responseLBS status [(H.hContentType, "text/html")] v + httpApp logger req f = do + flip runLoggingT logger $ do + let path = Wai.pathInfo req + mr = routeFromPathInfo path + logInfoNS "HTTP" $ show path <> " as " <> show mr + (status, v) <- case mr of + Nothing -> + pure (H.status404, "No route") + Just r -> do + val <- LVar.get model + let html = renderCatchingErrors val r + pure (H.status200, html <> emaStatusHtml <> wsClientShim) + liftIO $ f $ Wai.responseLBS status [(H.hContentType, "text/html")] v renderWithEmaHtmlShims m r = renderCatchingErrors m r <> emaStatusHtml renderCatchingErrors m r =