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

@@ -2,7 +2,7 @@
 
 <img width="10%" src="./docs/ema.svg">
 
-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 $ "<b>Hello</b>, from " <> name
 ```
 

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)

docs/concepts/logging.md

@@ -0,0 +1,6 @@
+# Logging
+
+TODO
+
+- monad-logger
+- CLI log levels

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`

ema.cabal

@@ -44,12 +44,15 @@ library
     , 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

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;
               [

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

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)

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

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 =

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)
 

src/Ema/Generate.hs

@@ -5,28 +5,33 @@
 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
+    liftIO $ do
       createDirectoryIfMissing True (takeDirectory fp)
       writeFileLBS fp s
   forM_ (staticAssets $ Proxy @route) $ \staticPath -> do
@@ -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
+            log LevelInfo $ toText $ "C " <> b
+            liftIO $ do
               createDirectoryIfMissing True (takeDirectory b)
               copyFile a 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)

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,24 +21,37 @@ 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
+      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 = putTextLn $ "[" <> show subId <> "] :: " <> s
-        log "ws:connected"
+            let log s = logDebugNS (toText @String $ printf "WS.Client.%.2d" subId) s
+            log "Connected"
             let askClientForRoute = do
                   msg :: Text <- WS.receiveData conn
                   pure $
@@ -45,24 +59,25 @@ runServerWithWebSocketHotReload port model render = do
                       & pathInfoFromWsMsg
                       & routeFromPathInfo
                       & fromMaybe (error "invalid route from ws")
-            loop = do
+                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 <- askClientForRoute
-              log $ "[Watch]: <~~ " <> show watchingRoute
+                  watchingRoute <- liftIO askClientForRoute
+                  log $ "<~~ " <> 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
+                  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.
-                  WS.sendTextData conn $ renderWithEmaHtmlShims newHtml watchingRoute
-                  log $ "[Watch]: ~~> " <> show watchingRoute
-                  loop
+                        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
@@ -70,10 +85,10 @@ runServerWithWebSocketHotReload port model render = do
                         -- request immediately following this).
                         log $ "[Switch]: <~~ " <> show nextRoute
                         html <- LVar.get model
-                  WS.sendTextData conn $ renderWithEmaHtmlShims html nextRoute
+                        liftIO $ WS.sendTextData conn $ renderWithEmaHtmlShims html nextRoute
                         log $ "[Switch]: ~~> " <> show nextRoute
-                  loop
-        try loop >>= \case
+                        lift loop
+            liftIO (try loop) >>= \case
               Right () -> pure ()
               Left (err :: ConnectionException) -> do
                 log $ "ws:error " <> show err
@@ -81,13 +96,15 @@ runServerWithWebSocketHotReload port model render = do
     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
+    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")
@@ -95,7 +112,7 @@ runServerWithWebSocketHotReload port model render = 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
+        liftIO $ f $ Wai.responseLBS status [(H.hContentType, "text/html")] v
     renderWithEmaHtmlShims m r =
       renderCatchingErrors m r <> emaStatusHtml
     renderCatchingErrors m r =