From acb19f89b3744332ea6ec14ad45342d6284776e9 Mon Sep 17 00:00:00 2001 From: Vo Minh Thu Date: Mon, 24 Jun 2024 13:13:39 +0200 Subject: [PATCH] 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 + slab.cabal | 4 ++- src/Slab/Build.hs | 40 ++++++++++++++++++++++++++++++ src/Slab/Command.hs | 10 +++++--- src/Slab/Error.hs | 18 ++++++++------ src/Slab/Render.hs | 6 +++++ src/Slab/Run.hs | 2 +- src/Slab/Serve.hs | 60 +++++++++++++++++++++++++++++++++++++-------- 8 files changed, 119 insertions(+), 22 deletions(-) diff --git a/.gitignore b/.gitignore index 3bcd14f..dd32b44 100644 --- a/.gitignore +++ b/.gitignore @@ -1,2 +1,3 @@ .*.swp result +_site/ diff --git a/slab.cabal b/slab.cabal index cad03ae..abcaba7 100644 --- a/slab.cabal +++ b/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 diff --git a/src/Slab/Build.hs b/src/Slab/Build.hs index f8dfe69..8354dbc 100644 --- a/src/Slab/Build.hs +++ b/src/Slab/Build.hs @@ -1,10 +1,16 @@ 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 @@ -12,6 +18,7 @@ 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 diff --git a/src/Slab/Command.hs b/src/Slab/Command.hs index 712f1ba..673ad6f 100644 --- a/src/Slab/Command.hs +++ b/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 diff --git a/src/Slab/Error.hs b/src/Slab/Error.hs index bfba381..aa0416a 100644 --- a/src/Slab/Error.hs +++ b/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. diff --git a/src/Slab/Render.hs b/src/Slab/Render.hs index 17ac823..084d428 100644 --- a/src/Slab/Render.hs +++ b/src/Slab/Render.hs @@ -1,9 +1,11 @@ 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 @@ -11,6 +13,7 @@ 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 diff --git a/src/Slab/Run.hs b/src/Slab/Run.hs index 0458db9..7973ce9 100644 --- a/src/Slab/Run.hs +++ b/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 diff --git a/src/Slab/Serve.hs b/src/Slab/Serve.hs index aef3f92..04add25 100644 --- a/src/Slab/Serve.hs +++ b/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