The serve commands now watches the .slab files.

- We add an STM-based store containing built templates.
- We use the watch code to update the store when watched files change.
- The server tries to serve a template before fallback to serve static
  files (typically used for instance to serve CSS).

.gitignore

@@ -1,2 +1,3 @@
 .*.swp
 result
+_site/

slab.cabal

@@ -1,6 +1,6 @@
 cabal-version:      2.2
 name:               slab
-version:            0.0.1.0
+version:            0.0.2.0
 license:            BSD-2-Clause
 license-file:       LICENSE
 copyright:          2024 Võ Minh Thu, Hypered SRL
@@ -59,6 +59,7 @@ library
     , filepath
     , fsnotify
     , Glob
+    , http-types
     , megaparsec
     , parser-combinators
     , prettyprinter
@@ -67,6 +68,7 @@ library
     , servant
     , servant-blaze
     , servant-server
+    , stm
     , text
     , transformers
     , vector

src/Slab/Build.hs

@@ -1,17 +1,24 @@
 module Slab.Build
   ( buildDir
   , buildFile
+  , StmStore
+  , buildDirInMemory
+  , buildFileInMemory
   , listTemplates
   ) where
 
+import Control.Concurrent.STM (atomically)
+import Control.Concurrent.STM qualified as STM
 import Data.List (sort)
+import Data.Map qualified as M
 import Data.Text.IO qualified as T
 import Data.Text.Lazy.IO qualified as TL
 import Slab.Command qualified as Command
 import Slab.Error qualified as Error
 import Slab.Evaluate qualified as Evaluate
 import Slab.Execute qualified as Execute
 import Slab.Render qualified as Render
+import Slab.Syntax qualified as Syntax
 import System.Directory (createDirectoryIfMissing)
 import System.FilePath (makeRelative, replaceExtension, takeDirectory, (</>))
 import System.FilePath.Glob qualified as Glob
@@ -38,6 +45,39 @@ buildFile srcDir mode distDir path = do
       Command.RenderPretty ->
         T.writeFile path' . Render.prettyHtmls $ Render.renderBlocks nodes
 
+--------------------------------------------------------------------------------
+
+type Store = M.Map FilePath [Syntax.Block]
+
+type StmStore = STM.TVar Store
+
+-- | A version of `buildDir` that doesn't write files to disk, but instead
+-- record the generated `Syntax.Block`s in STM.
+buildDirInMemory :: FilePath -> Command.RenderMode -> StmStore -> IO ()
+buildDirInMemory srcDir mode store = do
+  templates <- listTemplates srcDir
+  mapM_ (buildFileInMemory srcDir mode store) templates
+
+buildFileInMemory :: FilePath -> Command.RenderMode -> StmStore -> FilePath -> IO ()
+buildFileInMemory srcDir mode store path = do
+  let path' = replaceExtension (makeRelative srcDir path) ".html"
+  putStrLn $ "Building " <> path' <> "..."
+
+  mnodes <- Execute.executeFile path
+  case mnodes of
+    Right nodes ->
+      if Evaluate.simplify nodes == []
+        then putStrLn $ "No generated content for " <> path
+        else case mode of
+          Command.RenderNormal ->
+            atomically $ STM.modifyTVar store (writeStore path' nodes)
+          Command.RenderPretty ->
+            atomically $ STM.modifyTVar store (writeStore path' nodes)
+    Left err -> Error.display err
+
+writeStore :: FilePath -> [Syntax.Block] -> Store -> Store
+writeStore path blocks = M.insert path blocks
+
 --------------------------------------------------------------------------------
 listTemplates :: FilePath -> IO [FilePath]
 listTemplates templatesDir = sort <$> Glob.globDir1 pat templatesDir

src/Slab/Command.hs

@@ -26,7 +26,7 @@ import Options.Applicative qualified as A
 data Command
   = Build FilePath RenderMode FilePath
   | Watch FilePath RenderMode FilePath
-  | Serve FilePath
+  | Serve FilePath FilePath
   | Report FilePath
   | -- | Generate code. Only Haskell for now.
     Generate FilePath
@@ -158,15 +158,19 @@ parserBuild = do
 
 parserServe :: A.Parser Command
 parserServe = do
+  srcDir <-
+    A.argument
+      A.str
+      (A.metavar "DIR" <> A.action "file" <> A.help "Directory of Slab templates to build.")
   distDir <-
     A.strOption
       ( A.long "dist"
           <> A.value "./_site"
           <> A.metavar "DIR"
           <> A.help
-            "A destination directory for the generated HTML files."
+            "A directory with existing static files."
       )
-  pure $ Serve distDir
+  pure $ Serve srcDir distDir
 
 parserReport :: A.Parser Command
 parserReport = do

src/Slab/Error.hs

@@ -1,6 +1,7 @@
 module Slab.Error
   ( Error (..)
   , unwrap
+  , display
   ) where
 
 import Data.List.NonEmpty qualified as NE (toList)
@@ -30,18 +31,21 @@ data Error
 -- | Extract a Right value, or die, emitting an error message.
 unwrap :: Either Error a -> IO a
 unwrap = \case
-  Left (ParseError err) -> do
+  Left err -> do
+    display err
+    exitFailure
+  Right a -> pure a
+
+display :: Error -> IO ()
+display = \case
+  ParseError err ->
     -- Our custom function seems actually worse than errorBundlePretty.
     -- T.putStrLn . parseErrorPretty $ err
     T.putStrLn . T.pack $ errorBundlePretty err
-    exitFailure
-  Left (EvaluateError err) -> do
+  EvaluateError err ->
     T.putStrLn $ "Error during evaluation: " <> err
-    exitFailure
-  Left err -> do
+  err ->
     TL.putStrLn $ pShowNoColor err
-    exitFailure
-  Right a -> pure a
 
 --------------------------------------------------------------------------------
 -- Convert parse errors to a user-friendly message.

src/Slab/Render.hs

@@ -1,16 +1,19 @@
 module Slab.Render
   ( prettyHtmls
   , renderHtmls
+  , renderHtmlsUtf8
   , renderBlocks
   ) where
 
+import Data.ByteString.Lazy qualified as BSL
 import Data.String (fromString)
 import Data.Text (Text)
 import Data.Text qualified as T
 import Data.Text.Lazy qualified as TL
 import Slab.Syntax qualified as Syntax
 import Text.Blaze.Html.Renderer.Pretty qualified as Pretty (renderHtml)
 import Text.Blaze.Html.Renderer.Text (renderHtml)
+import Text.Blaze.Html.Renderer.Utf8 qualified as Utf8 (renderHtml)
 import Text.Blaze.Html5 (Html, (!))
 import Text.Blaze.Html5 qualified as H
 import Text.Blaze.Html5.Attributes qualified as A
@@ -24,6 +27,9 @@ prettyHtmls = T.pack . concat . map Pretty.renderHtml
 renderHtmls :: [Html] -> TL.Text
 renderHtmls = TL.concat . map renderHtml
 
+renderHtmlsUtf8 :: [Html] -> BSL.ByteString
+renderHtmlsUtf8 = BSL.concat . map Utf8.renderHtml
+
 --------------------------------------------------------------------------------
 renderBlocks :: [Syntax.Block] -> [H.Html]
 renderBlocks = map renderBlock

src/Slab/Run.hs

@@ -37,7 +37,7 @@ run :: Command.Command -> IO ()
 run (Command.Build srcDir renderMode distDir) = Build.buildDir srcDir renderMode distDir
 run (Command.Watch srcDir renderMode distDir) =
   Watch.run srcDir (Build.buildFile srcDir renderMode distDir)
-run (Command.Serve distDir) = Serve.run distDir
+run (Command.Serve srcDir distDir) = Serve.run srcDir distDir
 run (Command.Report srcDir) = Report.run srcDir
 run (Command.Generate path) = Generate.renderHs path
 run (Command.CommandWithPath path pmode (Command.Render Command.RenderNormal)) = do

src/Slab/Serve.hs

@@ -1,33 +1,49 @@
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE NoImplicitPrelude #-}
 
 module Slab.Serve
   ( run
   ) where
 
+import Control.Concurrent.STM qualified as STM
+import Data.Map qualified as M
+import Data.Text qualified as T
+import Network.HTTP.Types (status200)
 import Network.Wai qualified as Wai
 import Network.Wai.Handler.Warp qualified as Warp
 import Protolude hiding (Handler)
 import Servant hiding (serve)
 import Servant.HTML.Blaze qualified as B
 import Servant.Server qualified as Server
+import Slab.Build qualified as Build
+import Slab.Command qualified as Command
+import Slab.Render qualified as Render
+import Slab.Watch qualified as Watch
 import Text.Blaze.Html5 (Html)
 import WaiAppStatic.Storage.Filesystem
   ( defaultWebAppSettings
   )
 
 ------------------------------------------------------------------------------
-run :: FilePath -> IO ()
-run distDir =
-  Warp.run 9000 $ serve distDir
+run :: FilePath -> FilePath -> IO ()
+run srcDir distDir = do
+  store <- atomically $ STM.newTVar M.empty
+  -- Initial build to populate the store.
+  Build.buildDirInMemory srcDir Command.RenderNormal store
+  -- Then rebuild one file upon change.
+  _ <-
+    forkIO $
+      Watch.run srcDir (Build.buildFileInMemory srcDir Command.RenderNormal store)
+  Warp.run 9000 $ serve distDir store
 
 -- | Turn our `serverT` implementation into a Wai application, suitable for
 -- Warp.run.
-serve :: FilePath -> Wai.Application
-serve root =
+serve :: FilePath -> Build.StmStore -> Wai.Application
+serve root store =
   Servant.serveWithContext appProxy Server.EmptyContext $
     Server.hoistServerWithContext appProxy settingsProxy identity $
-      serverT root
+      serverT root store
 
 ------------------------------------------------------------------------------
 type ServerSettings = '[]
@@ -38,21 +54,45 @@ settingsProxy = Proxy
 ------------------------------------------------------------------------------
 type App =
   "hello" :> Get '[B.HTML] Html
-    :<|> Servant.Raw -- Fallback handler for the static files, in particular the
+    :<|> Servant.Raw -- Fallback handler for the static files.
 
 appProxy :: Proxy App
 appProxy = Proxy
 
 ------------------------------------------------------------------------------
-serverT :: FilePath -> ServerT App Handler
-serverT root =
+serverT :: FilePath -> Build.StmStore -> ServerT App Handler
+serverT root store =
   showHelloPage
-    :<|> serveStatic root
+    :<|> app root store
 
 ------------------------------------------------------------------------------
 showHelloPage :: Handler Html
 showHelloPage = pure "Hello."
 
+------------------------------------------------------------------------------
+
+-- | Try to serve a built page, and fallback to static files if the page
+-- doesn't exist.
+app :: FilePath -> Build.StmStore -> Server.Tagged Handler Server.Application
+app root store = Tagged $ \req sendRes -> app' root store req sendRes
+
+app' :: FilePath -> Build.StmStore -> Application
+app' root store req sendRes = do
+  templates <- liftIO . atomically $ STM.readTVar store
+  let path = T.intercalate "/" $ Wai.pathInfo req
+      path' = if T.null path then "index.html" else path
+  -- TODO Check requestMethod is GET.
+  case M.lookup (T.unpack path') templates of
+    Just blocks ->
+      sendRes $
+        Wai.responseLBS
+          status200
+          [("Content-Type", "text/html")]
+          (Render.renderHtmlsUtf8 $ Render.renderBlocks blocks)
+    Nothing -> do
+      let Tagged staticApp = serveStatic root
+      staticApp req sendRes
+
 ------------------------------------------------------------------------------
 serveStatic :: FilePath -> Server.Tagged Handler Server.Application
 serveStatic root = Servant.serveDirectoryWith settings