ema 0.1.0.0 → 0.2.0.0
raw patch · 22 files changed
+836/−895 lines, 22 filesdep +megaparsecdep +parsecdep +parser-combinatorsdep −emadep −profunctorsdep −showerdep ~basedep ~fsnotifydep ~relude
Dependencies added: megaparsec, parsec, parser-combinators, unicode-transforms, unionmount, uri-encode, yaml
Dependencies removed: ema, profunctors, shower, tagged
Dependency ranges changed: base, fsnotify, relude
Files
- CHANGELOG.md +50/−0
- README.md +10/−11
- docs/Main.hs +0/−6
- ema.cabal +22/−24
- src/Ema.hs +5/−0
- src/Ema/App.hs +43/−29
- src/Ema/Asset.hs +18/−0
- src/Ema/CLI.hs +1/−8
- src/Ema/Class.hs +16/−27
- src/Ema/Example/Ex02_Basic.hs +58/−0
- src/Ema/Example/Ex02_Clock.hs +0/−72
- src/Ema/Example/Ex03_Clock.hs +76/−0
- src/Ema/Example/Ex03_Documentation.hs +0/−471
- src/Ema/Generate.hs +62/−24
- src/Ema/Helper/FileSystem.hs +4/−81
- src/Ema/Helper/Markdown.hs +139/−0
- src/Ema/Helper/PathTree.hs +78/−0
- src/Ema/Helper/Tailwind.hs +20/−10
- src/Ema/Route.hs +54/−16
- src/Ema/Route/Slug.hs +24/−2
- src/Ema/Route/UrlStrategy.hs +0/−46
- src/Ema/Server.hs +156/−68
CHANGELOG.md view
@@ -1,5 +1,55 @@ # Revision history for ema +## 0.2.0.0 -- 2021-11-21++- TODO(doc) runEma's action gets the `CLI.Action` as argument, to prevent the `gen` command from needing to monitoring files.+- Live Server+ - Avoid unncessary DOM patch on page load+ - Handle invalid routes gracefully without breaking websocket+ - Re-add `<script>` tags on hot reload+ - Scroll to top on route switches+ - Use secure websockets when on HTTPS+ - Bind to loopback (127.0.0.1) for security reasons+ - Do not handle target=_blank links in websocket route switch+- `Asset` type+ - Introduce the `Asset` type to distinguishing between static files and generated files. The later can be one of `Html` or `Other`, allowing the live server to handle them sensibly.+ - `Ema` typeclass: + - Drop `staticAssets` in favour of `allRoutes` (renamed from `staticRoutes`) returning all routes including both generated and static routes.+ - Drop `Slug` and use plain `FilePath`. Route encoder and decoder deal directly with the on-disk path of the generated (or static) files.+ - Make the render function (which `runEma` takes) return a `Asset LByteString` instead of `LByteString` such that it can handle all routes, and handle static files as well as generation of non-HTML content (eg: RSS)+ - Allow copying static files anywhere on the filesystem+- `routeUrl`: + - Unicode normalize as well URI encode route URLs+ - now returns relative URLs (ie. without the leading `/`)+ - Use the `<base>` tag to specify an explicit prefix for relative URLs in generated HTML. This way hosting on GitHub Pages without CNAME will continue to have functional links.+ - Fix: prevent encoding of non-HTML paths+ - Now takes the `model` type as argument, inasmuch as `encodeRoute` takes it as as well (to accomodate scenarios where route path can only be computed depending on model state; storing slug aliases for instance)+ - Add `routeUrlWith` for non-pretty URLs+- `Ema.Slug`+ - Add `Ord`, `Generic`, `Data` and Aeson instances to `Slug`+ - Unicode normalize slugs using NFC+ - Add `decodeSlug` and `encodeSlug`+- Add default implementation based on Enum for `allRoutes`+- Warn, without failing, on missing static assets during static generation+- Static generation+ - Use block buffering to prevent logging from slowing down site generation+ - Write .nojekyll+- CLI+ - Removed `-C` argument (orthogonal to Ema)+- Helpers+ - Helpers.FileSystem+ - Add Union mount support; re-exported from `unionmount` library+ - enrich FileAction type to distinguish between existance and new and update states+ - Helpers.Tailwind+ - add overflow-y-scroll to body+ - Add twind shim *before* application's head+ - CDN: Use latest version always.+ - Helpers.Markdown+ - add helpers to parse markdown; `parseMarkdownWithFrontMatter` and `parseMarkdown`+- Examples+ - ~~Remove Ex03_Documentation.hs (moved to separate repo, `ema-docs`)~~ Back to ./docs, but using Emanote.+ - Add Ex03_Basic.hs example+ ## 0.1.0.0 -- 2021-04-26 * First version. Released on an unsuspecting world.
README.md view
@@ -1,19 +1,18 @@ # ema -<img width="10%" src="./docs/ema.svg">+<img width="10%" src="https://ema.srid.ca/favicon.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 further information.+[](https://hackage.haskell.org/package/ema)+[](https://www.fairforall.org/about/) -The simplest Ema app looks like this:+Ema is a next-gen **Haskell** library toolkit for building [jamstack-style](https://jamstack.org/) static sites, with fast hot reload. See [ema.srid.ca](https://ema.srid.ca/) for further information. -```haskell-main :: IO ()-main = do- let name :: Text = "Ema"- runEmaPure $ \_ ->- encodeUtf8 $ "<b>Hello</b>, from " <> name-```+https://user-images.githubusercontent.com/3998/116333460-789c1400-a7a1-11eb-8d28-297c349e42c6.mp4 ## Hacking -Run `bin/run` (or <kbd>Ctrl+Shift+B</kbd> in VSCode). This runs the documentation example; modify `./.ghcid` to run a different example, such as the clock example - which updates every second, demonstrating hot reload.+Run `bin/run` (or <kbd>Ctrl+Shift+B</kbd> in VSCode). This runs the clock example (which updates every second, only to demonstrate hot reload); modify `./.ghcid` to run a different example. ++## Getting Started++https://ema.srid.ca/start
− docs/Main.hs
@@ -1,6 +0,0 @@-module Main where --import qualified Ema.Example.Ex03_Documentation as Doc--main :: IO ()-main = Doc.main
ema.cabal view
@@ -1,6 +1,6 @@ cabal-version: 2.4 name: ema-version: 0.1.0.0+version: 0.2.0.0 license: AGPL-3.0-only copyright: 2021 Sridhar Ratnakumar maintainer: srid@srid.ca@@ -42,17 +42,21 @@ , data-default , directory , filepath+ , filepattern , http-types , lvar , monad-logger , monad-logger-extras , neat-interpolation , optparse-applicative- , relude+ , relude >=0.7 && <1.0 , safe-exceptions , stm , text+ , unicode-transforms+ , unionmount , unliftio+ , uri-encode , wai , wai-middleware-static , wai-websockets@@ -63,19 +67,19 @@ build-depends: , blaze-html , blaze-markup- , filepattern- , fsnotify+ , commonmark+ , commonmark-extensions+ , commonmark-pandoc+ , fsnotify ^>=0.3+ , megaparsec+ , pandoc-types+ , parsec+ , parser-combinators+ , time+ , yaml if flag(with-examples)- build-depends:- , commonmark- , commonmark-extensions- , commonmark-pandoc- , pandoc-types- , profunctors- , shower- , tagged- , time+ build-depends: time mixins: base hiding (Prelude),@@ -104,30 +108,24 @@ if (flag(with-helpers) || flag(with-examples)) exposed-modules: Ema.Helper.FileSystem+ Ema.Helper.Markdown+ Ema.Helper.PathTree Ema.Helper.Tailwind other-modules: Ema.App+ Ema.Asset Ema.Class Ema.Generate Ema.Route Ema.Route.Slug- Ema.Route.UrlStrategy Ema.Server if flag(with-examples) exposed-modules: Ema.Example.Ex01_HelloWorld- Ema.Example.Ex02_Clock- Ema.Example.Ex03_Documentation+ Ema.Example.Ex02_Basic+ Ema.Example.Ex03_Clock hs-source-dirs: src default-language: Haskell2010--executable ema-docs- hs-source-dirs: docs- default-language: Haskell2010- main-is: Main.hs- build-depends:- , base- , ema
src/Ema.hs view
@@ -6,5 +6,10 @@ where import Ema.App as X+import Ema.Asset as X import Ema.Class as X import Ema.Route as X+import Ema.Route.Slug as X+import Ema.Server as X+ ( emaErrorHtmlResponse,+ )
src/Ema/App.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeApplications #-}@@ -8,23 +9,28 @@ ( runEma, runEmaPure, runEmaWithCli,- MonadEma, ) where import Control.Concurrent (threadDelay) import Control.Concurrent.Async (race_)-import Control.Monad.Logger+import Control.Monad.Logger (MonadLoggerIO, logInfoN) import Control.Monad.Logger.Extras+ ( colorize,+ logToStdout,+ runLoggerLoggingT,+ ) import Data.LVar (LVar) import qualified Data.LVar as LVar-import Ema.CLI (Action (..), Cli)+import Ema.Asset (Asset (AssetGenerated), Format (Html))+import Ema.CLI (Cli) import qualified Ema.CLI as CLI-import Ema.Class (Ema (..), MonadEma)+import Ema.Class (Ema) import qualified Ema.Generate as Generate import qualified Ema.Server as Server-import System.Directory (getCurrentDirectory, withCurrentDirectory)+import System.Directory (getCurrentDirectory) import System.Environment (lookupEnv)+import UnliftIO (BufferMode (BlockBuffering, LineBuffering), MonadUnliftIO, hFlush, hSetBuffering) -- | Pure version of @runEmaWith@ (i.e with no model). --@@ -37,9 +43,10 @@ (CLI.Action -> LByteString) -> IO () runEmaPure render = do- runEma (\act () () -> render act) $ \model -> do+ runEma (\act () () -> AssetGenerated Html $ render act) $ \act model -> do LVar.set model ()- liftIO $ threadDelay maxBound+ when (act == CLI.Run) $ do+ liftIO $ threadDelay maxBound -- | Convenient version of @runEmaWith@ that takes initial model and an update -- function. You typically want to use this.@@ -50,10 +57,10 @@ forall model route. (Ema model route, Show route) => -- | How to render a route, given the model- (CLI.Action -> model -> route -> LByteString) ->+ (CLI.Action -> model -> route -> Asset 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.- (forall m. MonadEma m => LVar model -> m ()) ->+ (forall m. (MonadIO m, MonadUnliftIO m, MonadLoggerIO m) => CLI.Action -> LVar model -> m ()) -> IO () runEma render runModel = do cli <- CLI.cliAction@@ -67,29 +74,27 @@ (Ema model route, Show route) => Cli -> -- | How to render a route, given the model- (CLI.Action -> model -> route -> LByteString) ->+ (CLI.Action -> model -> route -> Asset 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.- (forall m. MonadEma m => LVar model -> m ()) ->+ (forall m. (MonadIO m, MonadUnliftIO m, MonadLoggerIO m) => CLI.Action -> LVar model -> m ()) -> IO () runEmaWithCli cli render runModel = do model <- LVar.empty- -- TODO: Allow library users to control logging levels+ -- TODO: Allow library users to control logging levels, or colors. let logger = colorize logToStdout- withCurrentDirectory (CLI.workingDir cli) $ do- cwd <- getCurrentDirectory- 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_- (flip runLoggerLoggingT logger $ runModel model)- (flip runLoggerLoggingT logger $ runEmaWithCliInCwd (CLI.action cli) model render)+ flip runLoggerLoggingT logger $ do+ cwd <- liftIO getCurrentDirectory+ logInfoN $ "Launching Ema under: " <> toText cwd+ logInfoN "Waiting for initial model ..."+ race_+ (flip runLoggerLoggingT logger $ runModel (CLI.action cli) model)+ (flip runLoggerLoggingT logger $ runEmaWithCliInCwd (CLI.action cli) model render) -- | Run Ema live dev server runEmaWithCliInCwd :: forall model route m.- (MonadEma m, Ema model route, Show route) =>+ (MonadIO m, MonadUnliftIO m, MonadLoggerIO m, Ema model route, Show route) => -- | CLI arguments CLI.Action -> -- | Your site model type, as a @LVar@ in order to support modifications over@@ -102,14 +107,23 @@ -- | Your site render function. Takes the current @model@ value, and the page -- @route@ type as arguments. It must return the raw HTML to render to browser -- or generate on disk.- (Action -> model -> route -> LByteString) ->+ (CLI.Action -> model -> route -> Asset LByteString) -> m () runEmaWithCliInCwd cliAction model render = do+ val <- LVar.get model+ logInfoN "... initial model is now available." case cliAction of- Generate dest -> do- val <- LVar.get model- Generate.generate dest val (render cliAction)- Run -> do- void $ LVar.get model+ CLI.Generate dest -> do+ withBlockBuffering $+ Generate.generate dest val (render cliAction)+ CLI.Run -> do port <- liftIO $ fromMaybe 8000 . (readMaybe @Int =<<) <$> lookupEnv "PORT"- Server.runServerWithWebSocketHotReload port model (render cliAction)+ host <- liftIO $ fromMaybe "127.0.0.1" <$> lookupEnv "HOST"+ Server.runServerWithWebSocketHotReload host port model (render cliAction)+ where+ -- Temporarily use block buffering before calling an IO action that is+ -- known ahead to log rapidly, so as to not hamper serial processing speed.+ withBlockBuffering f =+ hSetBuffering stdout (BlockBuffering Nothing)+ *> f+ <* (hSetBuffering stdout LineBuffering >> hFlush stdout)
+ src/Ema/Asset.hs view
@@ -0,0 +1,18 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE TypeApplications #-}++module Ema.Asset where++-- | The type of assets that can be bundled in a static site.+data Asset a+ = -- | A file that is copied as-is from the source directory.+ --+ -- Relative paths are assumed relative to the source directory. Absolute+ -- paths allow copying static files outside of source directory.+ AssetStatic FilePath+ | -- | A file whose contents are generated at runtime by user code.+ AssetGenerated Format a+ deriving (Eq, Show, Ord, Generic)++data Format = Html | Other+ deriving (Eq, Show, Ord, Generic)
src/Ema/CLI.hs view
@@ -7,8 +7,7 @@ import Options.Applicative hiding (action) data Cli = Cli- { workingDir :: FilePath,- action :: Action+ { action :: Action } deriving (Eq, Show) @@ -19,12 +18,6 @@ cliParser :: Parser Cli cliParser = do- workingDir <-- option- str- ( short 'C' <> metavar "PATH" <> value "."- <> help "Run as if ema was started in PATH instead of the current working directory."- ) action <- subparser (command "gen" (info generate (progDesc "Generate static HTML files")))
src/Ema/Class.hs view
@@ -1,41 +1,30 @@-{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DefaultSignatures #-} {-# 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- -- How to convert URLs to/from routes- encodeRoute :: route -> [Slug]- decodeRoute :: [Slug] -> Maybe route+ -- | Get the filepath on disk corresponding to this route.+ encodeRoute :: model -> route -> FilePath - -- | Routes to use when generating the static site- --- -- This is never used by the dev server.- staticRoutes :: model -> [route]+ -- | Decode a filepath on disk into a route.+ decodeRoute :: model -> FilePath -> Maybe route - -- | List of (top-level) filepaths to serve as static assets+ -- | All routes in the site --- -- These will be copied over as-is during static site generation- staticAssets :: Proxy route -> [FilePath]- staticAssets Proxy = mempty+ -- The `gen` command will generate only these routes. On live server, this+ -- function is never used.+ allRoutes :: model -> [route]+ default allRoutes :: (Bounded route, Enum route) => model -> [route]+ allRoutes _ = [minBound .. maxBound] --- | The unit model is useful when using Ema in pure fashion (see @Ema.runEmaPure@) with a single route (index.html) only.+-- | The unit model is useful when using Ema in pure fashion (see+-- @Ema.runEmaPure@) with a single route (index.html) only. instance Ema () () where- encodeRoute () = []- decodeRoute = \case+ encodeRoute () () = []+ decodeRoute () = \case [] -> Just () _ -> Nothing- staticRoutes () = one ()+ allRoutes () = one ()
+ src/Ema/Example/Ex02_Basic.hs view
@@ -0,0 +1,58 @@+{-# LANGUAGE TypeApplications #-}++-- | A very simple site with two routes, and HTML rendered using Blaze DSL+module Ema.Example.Ex02_Basic where++import Control.Concurrent (threadDelay)+import qualified Data.LVar as LVar+import Ema (Ema (..))+import qualified Ema+import qualified Ema.CLI+import qualified Ema.CLI as CLI+import qualified Ema.Helper.Tailwind as Tailwind+import Text.Blaze.Html5 ((!))+import qualified Text.Blaze.Html5 as H+import qualified Text.Blaze.Html5.Attributes as A++data Route+ = Index+ | About+ deriving (Show, Enum, Bounded)++newtype Model = Model {unModel :: Text}++instance Ema Model Route where+ encodeRoute _model =+ \case+ Index -> "index.html"+ About -> "about.html"+ decodeRoute _model = \case+ "index.html" -> Just Index+ "about.html" -> Just About+ _ -> Nothing++main :: IO ()+main = do+ Ema.runEma (\act m -> Ema.AssetGenerated Ema.Html . render act m) $ \act model -> do+ LVar.set model $ Model "Hello World. "+ when (act == CLI.Run) $+ liftIO $ threadDelay maxBound++render :: Ema.CLI.Action -> Model -> Route -> LByteString+render emaAction model r =+ Tailwind.layout emaAction (H.title "Basic site" >> H.base ! A.href "/") $+ H.div ! A.class_ "container mx-auto" $ do+ H.div ! A.class_ "mt-8 p-2 text-center" $ do+ case r of+ Index -> do+ H.toHtml (unModel model)+ "You are on the index page. "+ routeElem About "Go to About"+ About -> do+ "You are on the about page. "+ routeElem Index "Go to Index"+ where+ routeElem r' w =+ H.a ! A.class_ "text-red-500 hover:underline" ! routeHref r' $ w+ routeHref r' =+ A.href (fromString . toString $ Ema.routeUrl model r')
− src/Ema/Example/Ex02_Clock.hs
@@ -1,72 +0,0 @@-{-# LANGUAGE TypeApplications #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}---- | A very simple site with routes, but based on dynamically changing values------ The current time is computed in the server every second, and the resultant--- generated HTML is automatically updated on the browser. This is only a demo;--- usually we render HTML based on files on disk or something accessible outside--- of the browser. More advanced examples will demonstrate that.-module Ema.Example.Ex02_Clock where--import Control.Concurrent (threadDelay)-import qualified Data.LVar as LVar-import Data.List ((!!))-import Data.Time (UTCTime, defaultTimeLocale, formatTime, getCurrentTime)-import Ema (Ema (..), routeUrl, runEma)-import qualified Ema.CLI-import qualified Ema.Helper.Tailwind as Tailwind-import Text.Blaze.Html5 ((!))-import qualified Text.Blaze.Html5 as H-import qualified Text.Blaze.Html5.Attributes as A--data Route- = Index- | OnlyTime- deriving (Show, Enum, Bounded)--instance Ema UTCTime Route where- encodeRoute = \case- Index -> mempty- OnlyTime -> one "time"- decodeRoute = \case- [] -> Just Index- ["time"] -> Just OnlyTime- _ -> Nothing- staticRoutes _ =- [minBound .. maxBound]--main :: IO ()-main = do- runEma render $ \model ->- forever $ do- LVar.set model =<< liftIO getCurrentTime- liftIO $ threadDelay $ 1 * 1000000--render :: Ema.CLI.Action -> UTCTime -> Route -> LByteString-render emaAction now r =- Tailwind.layout emaAction (H.title "Clock") $- H.div ! A.class_ "container mx-auto" $ do- H.div ! A.class_ "border-t-1 p-2 tex{-# OPTIONS_GHC -fno-warn-orphans #-}t-center" $ do- "The current time is: "- H.pre ! A.class_ "text-6xl font-bold mt-2" $ do- H.span ! A.class_ ("text-" <> randomColor now <> "-500") $ do- let fmt = case r of- Index -> "%Y/%m/%d %H:%M:%S"- OnlyTime -> "%H:%M:%S"- H.toMarkup $ formatTime defaultTimeLocale fmt now- H.div ! A.class_ "mt-4 text-center" $ do- case r of- Index -> do- routeElem OnlyTime "Hide day?"- OnlyTime -> do- routeElem Index "Show day?"- where- routeElem r' w =- H.a ! A.class_ "text-xl text-purple-500 hover:underline" ! routeHref r' $ w- routeHref r' =- A.href (fromString . toString $ routeUrl r')- randomColor t =- let epochSecs = fromMaybe 0 . readMaybe @Int $ formatTime defaultTimeLocale "%s" t- colors = ["green", "gray", "purple", "red", "blue", "yellow", "black", "pink"]- in colors !! mod epochSecs (length colors)
+ src/Ema/Example/Ex03_Clock.hs view
@@ -0,0 +1,76 @@+{-# LANGUAGE TypeApplications #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++-- | A very simple site with routes, but based on dynamically changing values+--+-- The current time is computed in the server every second, and the resultant+-- generated HTML is automatically updated on the browser. This is only a demo;+-- usually we render HTML based on files on disk or something accessible outside+-- of the browser. More advanced examples will demonstrate that.+module Ema.Example.Ex03_Clock where++import Control.Concurrent (threadDelay)+import qualified Data.LVar as LVar+import Data.List ((!!))+import Data.Time (UTCTime, defaultTimeLocale, formatTime, getCurrentTime)+import Ema (Ema (..))+import qualified Ema+import qualified Ema.CLI+import qualified Ema.Helper.Tailwind as Tailwind+import Text.Blaze.Html5 ((!))+import qualified Text.Blaze.Html5 as H+import qualified Text.Blaze.Html5.Attributes as A++data Route+ = Index+ | OnlyTime+ deriving (Show, Enum, Bounded)++instance Ema UTCTime Route where+ encodeRoute _time = \case+ Index -> "index.html"+ OnlyTime -> "time.html"+ decodeRoute _time = \case+ "index.html" -> Just Index+ "time.html" -> Just OnlyTime+ _ -> Nothing++main :: IO ()+main = do+ Ema.runEma (\act m -> Ema.AssetGenerated Ema.Html . render act m) $ \_act model ->+ forever $ do+ -- logDebugNS "ex:clock" "Refreshing time"+ LVar.set model =<< liftIO getCurrentTime+ liftIO $ threadDelay 1000000++render :: Ema.CLI.Action -> UTCTime -> Route -> LByteString+render emaAction now r =+ Tailwind.layout emaAction (H.title "Clock" >> H.base ! A.href "/") $+ H.div ! A.class_ "container mx-auto" $ do+ H.div ! A.class_ "mt-8 p-2 text-center" $ do+ case r of+ Index ->+ "The current date & time is: "+ OnlyTime ->+ "The current time is: "+ H.pre ! A.class_ "text-6xl font-bold mt-2" $ do+ H.span ! A.class_ ("text-" <> randomColor now <> "-500") $ do+ let fmt = case r of+ Index -> "%Y/%m/%d %H:%M:%S"+ OnlyTime -> "%H:%M:%S"+ H.toMarkup $ formatTime defaultTimeLocale fmt now+ H.div ! A.class_ "mt-4 text-center" $ do+ case r of+ Index -> do+ routeElem OnlyTime "Hide day?"+ OnlyTime -> do+ routeElem Index "Show day?"+ where+ routeElem r' w =+ H.a ! A.class_ "text-xl text-purple-500 hover:underline" ! routeHref r' $ w+ routeHref r' =+ A.href (fromString . toString $ Ema.routeUrl now r')+ randomColor t =+ let epochSecs = fromMaybe 0 . readMaybe @Int $ formatTime defaultTimeLocale "%s" t+ colors = ["green", "gray", "purple", "red", "blue", "yellow", "black", "pink"]+ in colors !! mod epochSecs (length colors)
− src/Ema/Example/Ex03_Documentation.hs
@@ -1,471 +0,0 @@-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE DeriveAnyClass #-}-{-# LANGUAGE QuasiQuotes #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE TypeFamilies #-}-{-# OPTIONS_GHC -Wno-orphans #-}---- | An advanced example demonstrating how to build documentation sites.------ This "example" is actually used to build Ema's documentation site itself. It--- is a work in progress currently.-module Ema.Example.Ex03_Documentation where--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-import Data.Profunctor (dimap)-import Data.Tagged (Tagged (Tagged), untag)-import qualified Data.Text as T-import Ema (Ema (..), Slug (unSlug), routeUrl, runEma)-import qualified Ema.CLI-import qualified Ema.Helper.FileSystem as FileSystem-import qualified Ema.Helper.Tailwind as Tailwind-import NeatInterpolation (text)-import System.FilePath (splitExtension, splitPath)-import Text.Blaze.Html5 ((!))-import qualified Text.Blaze.Html5 as H-import qualified Text.Blaze.Html5.Attributes as A-import qualified Text.Pandoc.Builder as B-import Text.Pandoc.Definition (Pandoc (..))-import qualified Text.Pandoc.Walk as W---- | Represents the relative path to a source (.md) file under some directory.-type MarkdownPath = Tagged "MarkdownPath" (NonEmpty Text)--indexMarkdownPath :: MarkdownPath-indexMarkdownPath = Tagged $ "index" :| []--mkMarkdownPath :: FilePath -> Maybe MarkdownPath-mkMarkdownPath = \case- (splitExtension -> (fp, ".md")) ->- let slugs = T.dropWhileEnd (== '/') . toText <$> splitPath fp- in Tagged <$> nonEmpty slugs- _ ->- Nothing--markdownPathFileBase :: MarkdownPath -> Text-markdownPathFileBase (Tagged slugs) =- head $ NE.reverse slugs--markdownPathInits :: MarkdownPath -> NonEmpty MarkdownPath-markdownPathInits (Tagged ("index" :| [])) =- one indexMarkdownPath-markdownPathInits (Tagged (slug :| rest')) =- indexMarkdownPath :| case nonEmpty rest' of- Nothing ->- one $ Tagged (one slug)- Just rest ->- Tagged (one slug) : go (one slug) rest- where- go :: NonEmpty Text -> NonEmpty Text -> [MarkdownPath]- go x (y :| ys') =- let this = Tagged (x <> one y)- in case nonEmpty ys' of- Nothing ->- one this- Just ys ->- this : go (untag this) ys--type MarkdownSources = Tagged "MarkdownSources" (Map MarkdownPath Pandoc)--instance Ema MarkdownSources MarkdownPath where- encodeRoute = \case- Tagged ("index" :| []) -> mempty- Tagged paths -> toList . fmap (fromString . toString) $ paths- decodeRoute = \case- (nonEmpty -> Nothing) ->- pure $ Tagged $ one "index"- (nonEmpty -> Just slugs) -> do- let parts = toText . unSlug <$> slugs- -- Heuristic to let requests to static files (eg: favicon.ico) to pass through- guard $ not (any (T.isInfixOf ".") parts)- pure $ Tagged parts- staticRoutes (Map.keys . untag -> spaths) =- spaths- 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- mdFiles <- FileSystem.filesMatching "." ["**/*.md"]- forM mdFiles readSource- <&> Tagged . Map.fromList . catMaybes- FileSystem.onChange "." $ \fp -> \case- FileSystem.Update ->- whenJustM (readSource fp) $ \(spath, s) -> do- log $ "Update: " <> show spath- LVar.modify model $ Tagged . Map.insert spath s . untag- FileSystem.Delete ->- whenJust (mkMarkdownPath fp) $ \spath -> do- log $ "Delete: " <> show spath- LVar.modify model $ Tagged . Map.delete spath . untag- where- 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)--newtype BadRoute = BadRoute MarkdownPath- deriving (Show, Exception)--render :: Ema.CLI.Action -> MarkdownSources -> MarkdownPath -> LByteString-render emaAction srcs spath = do- case Map.lookup spath (untag srcs) of- Nothing -> throw $ BadRoute spath- Just doc -> do- Tailwind.layout emaAction (headHtml spath doc) (bodyHtml srcs spath doc)--headHtml :: MarkdownPath -> Pandoc -> H.Html-headHtml spath doc = do- let siteTitle = "Ema"- routeTitle = maybe (last $ untag spath) plainify $ getPandocH1 doc- H.title $- H.text $- if routeTitle == siteTitle then siteTitle else routeTitle <> " – " <> siteTitle- H.meta ! A.name "description" ! A.content "Ema static site generator (Jamstack) in Haskell"- favIcon- -- Make this a PWA and w/ https://web.dev/themed-omnibox/- H.link ! A.rel "manifest" ! A.href "/manifest.json"- H.meta ! A.name "theme-color" ! A.content "#d53f8c"- unless (spath == indexMarkdownPath) prismJs- where- prismJs = do- H.unsafeByteString . encodeUtf8 $- [text|- <link href="https://cdn.jsdelivr.net/npm/prismjs@1.23.0/themes/prism-tomorrow.css" rel="stylesheet" />- <script src="https://cdn.jsdelivr.net/combine/npm/prismjs@1.23.0/prism.min.js,npm/prismjs@1.23.0/plugins/autoloader/prism-autoloader.min.js"></script>- |]- favIcon = do- H.unsafeByteString . encodeUtf8 $- [text|- <link href="/ema.svg" rel="icon" />- |]--bodyHtml :: MarkdownSources -> MarkdownPath -> Pandoc -> H.Html-bodyHtml srcs spath doc = do- H.div ! A.class_ "flex justify-center p-4 bg-red-500 text-gray-100 font-bold text-2xl" $ do- H.div $ do- H.b "WIP: "- "Documentation is still being written"- H.div ! A.class_ "container mx-auto xl:max-w-screen-lg" $ do- H.div ! A.class_ "px-2" $ do- renderBreadcrumbs srcs spath- renderPandoc $- doc- & applyClassLibrary (\c -> fromMaybe c $ Map.lookup c emaMarkdownStyleLibrary)- & rewriteLinks- -- Rewrite .md links to @MarkdownPath@- ( \url -> fromMaybe url $ do- guard $ not $ "://" `T.isInfixOf` url- target <- mkMarkdownPath $ toString url- -- Check that .md links are not broken- if Map.member target (untag srcs)- then pure $ routeUrl target- else throw $ BadRoute target- )- H.footer ! A.class_ "mt-8 text-center text-gray-500" $ do- "Powered by "- H.a ! A.class_ "font-bold" ! A.target "blank" ! A.href "https://github.com/srid/ema" $ "Ema"- where- emaMarkdownStyleLibrary =- Map.fromList- [ ("feature", "flex justify-center items-center text-center shadow-lg p-2 m-2 w-32 h-16 lg:w-auto rounded border-2 border-gray-400 bg-pink-100 text-base font-bold hover:bg-pink-200 hover:border-black"),- ("avatar", "float-right w-32 h-32"),- -- List item specifc styles- ("item-intro", "text-gray-500"),- -- Styling the last line in series posts- ("last", "mt-8 border-t-2 border-pink-500 pb-1 pl-1 bg-gray-50 rounded"),- ("next", "py-2 text-xl italic font-bold")- ]--lookupTitleForgiving :: MarkdownSources -> MarkdownPath -> Text-lookupTitleForgiving srcs spath =- fromMaybe (markdownPathFileBase spath) $ do- doc <- Map.lookup spath $ untag srcs- is <- getPandocH1 doc- pure $ plainify is--renderBreadcrumbs :: MarkdownSources -> MarkdownPath -> H.Html-renderBreadcrumbs srcs spath = do- whenNotNull (init $ markdownPathInits spath) $ \(toList -> crumbs) ->- H.div ! A.class_ "w-full text-gray-600 mt-4" $ do- H.div ! A.class_ "flex justify-center" $ do- H.div ! A.class_ "w-full bg-white py-2 rounded" $ do- H.ul ! A.class_ "flex text-gray-500 text-sm lg:text-base" $ do- forM_ crumbs $ \crumb ->- H.li ! A.class_ "inline-flex items-center" $ do- H.a ! A.class_ "px-1 font-bold bg-pink-500 text-gray-50 rounded"- ! routeHref crumb- $ H.text $ lookupTitleForgiving srcs crumb- rightArrow- H.li ! A.class_ "inline-flex items-center text-gray-600" $ do- H.a $ H.text $ lookupTitleForgiving srcs spath- where- rightArrow =- H.unsafeByteString $- encodeUtf8- [text|- <svg fill="currentColor" viewBox="0 0 20 20" class="h-5 w-auto text-gray-400"><path fill-rule="evenodd" d="M7.293 14.707a1 1 0 010-1.414L10.586 10 7.293 6.707a1 1 0 011.414-1.414l4 4a1 1 0 010 1.414l-4 4a1 1 0 01-1.414 0z" clip-rule="evenodd"></path></svg>- |]--routeHref :: Ema a r => r -> H.Attribute-routeHref r' =- A.href (fromString . toString $ routeUrl r')---- Pandoc transformer--rewriteLinks :: (Text -> Text) -> Pandoc -> Pandoc-rewriteLinks f =- W.walk $ \case- B.Link attr is (url, title) ->- B.Link attr is (f url, title)- x -> x--applyClassLibrary :: (Text -> Text) -> Pandoc -> Pandoc-applyClassLibrary f =- walkBlocks . walkInlines- where- walkBlocks = W.walk $ \case- B.Div attr bs ->- B.Div (g attr) bs- x -> x- walkInlines = W.walk $ \case- B.Span attr is ->- B.Span (g attr) is- x -> x- g (id', cls, attr) =- (id', withPackedClass f cls, attr)- withPackedClass :: (Text -> Text) -> [Text] -> [Text]- withPackedClass =- dimap (T.intercalate " ") (T.splitOn " ")---- Pandoc renderer------ Note that we hardcode tailwind classes, because pandoc AST is not flexible--- enough to provide attrs for all inlines/blocks. So we can't rely on Walk to--- transform it.--renderPandoc :: Pandoc -> H.Html-renderPandoc (Pandoc _meta blocks) =- mapM_ rpBlock blocks--rpBlock :: B.Block -> H.Html-rpBlock = \case- B.Plain is ->- mapM_ rpInline is- B.Para is ->- H.p ! A.class_ "my-2" $ mapM_ rpInline is- B.LineBlock iss ->- forM_ iss $ \is ->- mapM_ rpInline is >> "\n"- B.CodeBlock (id', classes, attrs) s ->- -- Prism friendly classes- let classes' = flip concatMap classes $ \cls -> [cls, "language-" <> cls]- in H.pre ! rpAttr (id', classes', attrs) $ H.code ! rpAttr ("", classes', []) $ H.text s- B.RawBlock _ _ ->- pure ()- B.BlockQuote bs ->- H.blockquote $ mapM_ rpBlock bs- B.OrderedList _ bss ->- H.ol ! A.class_ listStyle $- forM_ bss $ \bs ->- H.li ! A.class_ listItemStyle $ mapM_ rpBlock bs- B.BulletList bss ->- H.ul ! A.class_ (listStyle <> " list-disc") $- forM_ bss $ \bs ->- H.li ! A.class_ listItemStyle $ mapM_ rpBlock bs- B.DefinitionList defs ->- H.dl $- forM_ defs $ \(term, descList) -> do- mapM_ rpInline term- forM_ descList $ \desc ->- H.dd $ mapM_ rpBlock desc- B.Header level attr is ->- headerElem level ! rpAttr attr $ mapM_ rpInline is- B.HorizontalRule ->- H.hr- B.Table {} ->- throw Unsupported- B.Div attr bs ->- H.div ! rpAttr attr $ mapM_ rpBlock bs- B.Null ->- pure ()- where- listStyle = "list-inside ml-2"- listItemStyle = "text-xl py-1.5 lg:py-0 lg:text-base"--headerElem :: Int -> H.Html -> H.Html-headerElem = \case- 1 -> H.h1 ! A.class_ ("text-6xl " <> my <> " text-center py-2")- 2 -> H.h2 ! A.class_ ("text-5xl " <> my)- 3 -> H.h3 ! A.class_ ("text-4xl " <> my)- 4 -> H.h4 ! A.class_ ("text-3xl " <> my)- 5 -> H.h5 ! A.class_ ("text-2xl " <> my)- 6 -> H.h6 ! A.class_ ("text-xl " <> my)- _ -> error "Invalid pandoc header level"- where- my = "my-2"--rpInline :: B.Inline -> H.Html-rpInline = \case- B.Str s -> H.toHtml s- B.Emph is ->- H.em $ mapM_ rpInline is- B.Strong is ->- H.strong $ mapM_ rpInline is- B.Underline is ->- H.u $ mapM_ rpInline is- B.Strikeout is ->- -- FIXME: Should use <s>, but blaze doesn't have it.- H.del $ mapM_ rpInline is- B.Superscript is ->- H.sup $ mapM_ rpInline is- B.Subscript is ->- H.sub $ mapM_ rpInline is- B.Quoted qt is ->- flip inQuotes qt $ mapM_ rpInline is- B.Code attr s ->- H.code ! rpAttr attr $ H.toHtml s- B.Space -> " "- B.SoftBreak -> " "- B.LineBreak -> H.br- B.RawInline _fmt s ->- H.pre $ H.toHtml s- B.Math _ _ ->- throw Unsupported- B.Link attr is (url, title) -> do- let (cls, target) =- if "://" `T.isInfixOf` url- then ("text-pink-600 hover:underline", A.target "_blank")- else ("text-pink-600 font-bold hover:bg-pink-50", mempty)- H.a- ! A.class_ cls- ! A.href (H.textValue url)- ! A.title (H.textValue title)- ! target- ! rpAttr attr- $ mapM_ rpInline is- B.Image attr is (url, title) ->- H.img ! A.src (H.textValue url) ! A.title (H.textValue title) ! A.alt (H.textValue $ plainify is) ! rpAttr attr- B.Note _ ->- throw Unsupported- B.Span attr is ->- H.span ! rpAttr attr $ mapM_ rpInline is- x ->- H.pre $ H.toHtml $ show @Text x- where- inQuotes :: H.Html -> B.QuoteType -> H.Html- inQuotes w = \case- B.SingleQuote -> "‘" >> w <* "’"- B.DoubleQuote -> "“" >> w <* "”"--rpAttr :: B.Attr -> H.Attribute-rpAttr (id', classes, attrs) =- let cls = T.intercalate " " classes- in unlessNull id' (A.id (fromString . toString $ id'))- <> unlessNull cls (A.class_ (fromString . toString $ cls))- <> mconcat (fmap (\(k, v) -> H.dataAttribute (fromString . toString $ k) (fromString . toString $ v)) attrs)- where- unlessNull x f =- if T.null x then mempty else f--data Unsupported = Unsupported- deriving (Show, Exception)---- Pandoc helpers--getPandocH1 :: Pandoc -> Maybe [B.Inline]-getPandocH1 = listToMaybe . W.query go- where- go :: B.Block -> [[B.Inline]]- go = \case- B.Header 1 _ inlines ->- [inlines]- _ ->- []---- | Convert Pandoc AST inlines to raw text.-plainify :: [B.Inline] -> Text-plainify = W.query $ \case- B.Str x -> x- B.Code _attr x -> x- B.Space -> " "- B.SoftBreak -> " "- B.LineBreak -> " "- B.RawInline _fmt s -> s- B.Math _mathTyp s -> s- -- Ignore the rest of AST nodes, as they are recursively defined in terms of- -- `Inline` which `W.query` will traverse again.- _ -> ""---- --------------------------- Markdown parsing helpers--- --------------------------newtype BadMarkdown = BadMarkdown Text- deriving (Show, Exception)--parseMarkdown :: Text -> Pandoc-parseMarkdown s =- Pandoc mempty $- B.toList $- CP.unCm @() @B.Blocks $- either (throw . BadMarkdown . show) id $- join $ CM.commonmarkWith @(Either CM.ParseError) markdownSpec "x" s--type SyntaxSpec' m il bl =- ( Monad m,- CM.IsBlock il bl,- CM.IsInline il,- Typeable m,- Typeable il,- Typeable bl,- CE.HasEmoji il,- CE.HasStrikethrough il,- CE.HasPipeTable il bl,- CE.HasTaskList il bl,- CM.ToPlainText il,- CE.HasFootnote il bl,- CE.HasMath il,- CE.HasDefinitionList il bl,- CE.HasDiv bl,- CE.HasQuoted il,- CE.HasSpan il- )--markdownSpec ::- SyntaxSpec' m il bl =>- CM.SyntaxSpec m il bl-markdownSpec =- mconcat- [ CE.gfmExtensions,- CE.fancyListSpec,- CE.footnoteSpec,- CE.mathSpec,- CE.smartPunctuationSpec,- CE.definitionListSpec,- CE.attributesSpec,- CE.rawAttributeSpec,- CE.fencedDivSpec,- CE.bracketedSpanSpec,- CE.autolinkSpec,- CM.defaultSyntaxSpec,- -- as the commonmark documentation states, pipeTableSpec should be placed after- -- fancyListSpec and defaultSyntaxSpec to avoid bad results when non-table lines- CE.pipeTableSpec- ]
src/Ema/Generate.hs view
@@ -6,63 +6,101 @@ import Control.Exception (throw) import Control.Monad.Logger-import Ema.Class-import Ema.Route (routeFile)-import System.Directory (copyFile, createDirectoryIfMissing, doesDirectoryExist, doesFileExist)+import Ema.Asset (Asset (..))+import Ema.Class (Ema (allRoutes, encodeRoute))+import System.Directory (copyFile, createDirectoryIfMissing, doesDirectoryExist, doesFileExist, doesPathExist) import System.FilePath (takeDirectory, (</>)) import System.FilePattern.Directory (getDirectoryFiles)+import UnliftIO (MonadUnliftIO) log :: MonadLogger m => LogLevel -> Text -> m () log = logWithoutLoc "Generate" generate :: forall model route m.- (MonadEma m, Ema model route) =>+ ( MonadIO m,+ MonadUnliftIO m,+ MonadLoggerIO m,+ Ema model route,+ HasCallStack+ ) => FilePath -> model ->- (model -> route -> LByteString) ->+ (model -> route -> Asset LByteString) -> m () generate dest model render = do unlessM (liftIO $ doesDirectoryExist dest) $ do- error "Destination does not exist"- let routes = staticRoutes model+ error $ "Destination does not exist: " <> toText dest+ let routes = allRoutes model log LevelInfo $ "Writing " <> show (length routes) <> " routes"- forM_ routes $ \r -> do- let fp = dest </> routeFile @model r+ let (staticPaths, generatedPaths) =+ lefts &&& rights $+ routes <&> \r ->+ case render model r of+ AssetStatic fp -> Left (r, fp)+ AssetGenerated _fmt s -> Right (encodeRoute model r, s)+ forM_ generatedPaths $ \(relPath, !s) -> do+ let fp = dest </> relPath 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- copyDirRecursively staticPath dest+ forM_ staticPaths $ \(r, staticPath) -> do+ liftIO (doesPathExist staticPath) >>= \case+ True ->+ -- TODO: In current branch, we don't expect this to be a directory.+ -- Although the user may pass it, but review before merge.+ copyDirRecursively (encodeRoute model r) staticPath dest+ False ->+ log LevelWarn $ toText $ "? " <> staticPath <> " (missing)"+ noBirdbrainedJekyll dest +-- | Disable birdbrained hacks from GitHub to disable surprises like,+-- https://github.com/jekyll/jekyll/issues/55+noBirdbrainedJekyll :: (MonadIO m, MonadLoggerIO m) => FilePath -> m ()+noBirdbrainedJekyll dest = do+ let nojekyll = dest </> ".nojekyll"+ liftIO (doesFileExist nojekyll) >>= \case+ True -> pure ()+ False -> do+ log LevelInfo $ "Disabling Jekyll by writing " <> toText nojekyll+ writeFileLBS nojekyll ""+ newtype StaticAssetMissing = StaticAssetMissing FilePath deriving (Show, Exception) copyDirRecursively ::- MonadEma m =>- -- | Source file or directory relative to CWD that will be copied+ ( MonadIO m,+ MonadUnliftIO m,+ MonadLoggerIO m,+ HasCallStack+ ) =>+ -- | Source file path relative to CWD FilePath ->+ -- | Absolute path to source file to copy.+ FilePath -> -- | Directory *under* which the source file/dir will be copied FilePath -> m ()-copyDirRecursively srcRel destParent =- liftIO (doesFileExist srcRel) >>= \case+copyDirRecursively srcRel srcAbs destParent = do+ liftIO (doesFileExist srcAbs) >>= \case True -> do let b = destParent </> srcRel log LevelInfo $ toText $ "C " <> b- liftIO $ copyFile srcRel b+ copyFileCreatingParents srcAbs b False ->- liftIO (doesDirectoryExist srcRel) >>= \case+ liftIO (doesDirectoryExist srcAbs) >>= \case False ->- throw $ StaticAssetMissing srcRel+ throw $ StaticAssetMissing srcAbs True -> do- fs <- liftIO $ getDirectoryFiles srcRel ["**"]+ fs <- liftIO $ getDirectoryFiles srcAbs ["**"] forM_ fs $ \fp -> do- let a = srcRel </> fp+ let a = srcAbs </> fp b = destParent </> srcRel </> fp log LevelInfo $ toText $ "C " <> b- liftIO $ do- createDirectoryIfMissing True (takeDirectory b)- copyFile a b+ copyFileCreatingParents a b+ where+ copyFileCreatingParents a b =+ liftIO $ do+ createDirectoryIfMissing True (takeDirectory b)+ copyFile a b
src/Ema/Helper/FileSystem.hs view
@@ -1,86 +1,9 @@-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE TypeApplications #-} --- | 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- ( filesMatching,- onChange,- FileAction (..),+ ( module X, ) where -import Control.Concurrent (threadDelay)-import Control.Exception (finally)-import Control.Monad.Logger-import System.Directory (canonicalizePath)-import System.FSNotify- ( ActionPredicate,- Event (..),- StopListening,- WatchManager,- watchTree,- withManager,- )-import System.FilePath (makeRelative)-import System.FilePattern (FilePattern)-import System.FilePattern.Directory (getDirectoryFiles)-import UnliftIO (MonadUnliftIO, withRunInIO)--type FolderPath = FilePath--log :: MonadLogger m => LogLevel -> Text -> m ()-log = logWithoutLoc "Helper.FileSystem"--filesMatching :: (MonadIO m, MonadLogger m) => FolderPath -> [FilePattern] -> m [FilePath]-filesMatching parent' pats = do- 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 ::- forall m.- (MonadIO m, MonadLogger m, MonadUnliftIO 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 <- 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- liftIO $ threadDelay maxBound `finally` stop--withManagerM ::- (MonadIO m, MonadUnliftIO m) =>- (WatchManager -> m a) ->- m a-withManagerM f = do- withRunInIO $ \run ->- withManager $ \mgr -> run (f mgr)--watchTreeM ::- forall m.- (MonadIO m, MonadUnliftIO m) =>- WatchManager ->- FilePath ->- ActionPredicate ->- (Event -> m ()) ->- m StopListening-watchTreeM wm fp pr f =- withRunInIO $ \run ->- watchTree wm fp pr $ \evt -> run (f evt)+import System.UnionMount as X
+ src/Ema/Helper/Markdown.hs view
@@ -0,0 +1,139 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}++-- | Helper to deal with Markdown files+--+-- TODO: Publish this eventually to Hackage, along with wiki-link stuff from+-- emanote (maybe as separate package).+module Ema.Helper.Markdown+ ( -- Parsing+ -- TODO: Publish to Hackage as commonmark-pandoc-simple?+ parseMarkdownWithFrontMatter,+ parseMarkdown,+ fullMarkdownSpec,+ -- Utilities+ plainify,+ )+where++import qualified Commonmark as CM+import qualified Commonmark.Extensions as CE+import qualified Commonmark.Pandoc as CP+import Control.Monad.Combinators (manyTill)+import Data.Aeson (FromJSON)+import qualified Data.Yaml as Y+import qualified Text.Megaparsec as M+import qualified Text.Megaparsec.Char as M+import qualified Text.Pandoc.Builder as B+import Text.Pandoc.Definition (Pandoc (..))+import qualified Text.Pandoc.Walk as W++-- | Parse a Markdown file using commonmark-hs with all extensions enabled+parseMarkdownWithFrontMatter ::+ forall meta m il bl.+ ( FromJSON meta,+ m ~ Either CM.ParseError,+ bl ~ CP.Cm () B.Blocks,+ il ~ CP.Cm () B.Inlines+ ) =>+ CM.SyntaxSpec m il bl ->+ -- | Path to file associated with this Markdown+ FilePath ->+ -- | Markdown text to parse+ Text ->+ Either Text (Maybe meta, Pandoc)+parseMarkdownWithFrontMatter spec fn s = do+ (mMeta, markdown) <- partitionMarkdown fn s+ mMetaVal <- first show $ (Y.decodeEither' . encodeUtf8) `traverse` mMeta+ blocks <- first show $ join $ CM.commonmarkWith @(Either CM.ParseError) spec fn markdown+ let doc = Pandoc mempty $ B.toList . CP.unCm @() @B.Blocks $ blocks+ pure (mMetaVal, doc)++parseMarkdown :: FilePath -> Text -> Either Text Pandoc+parseMarkdown fn s = do+ cmBlocks <- first show $ join $ CM.commonmarkWith @(Either CM.ParseError) fullMarkdownSpec fn s+ let blocks = B.toList . CP.unCm @() @B.Blocks $ cmBlocks+ pure $ Pandoc mempty blocks++type SyntaxSpec' m il bl =+ ( Monad m,+ CM.IsBlock il bl,+ CM.IsInline il,+ Typeable m,+ Typeable il,+ Typeable bl,+ CE.HasEmoji il,+ CE.HasStrikethrough il,+ CE.HasPipeTable il bl,+ CE.HasTaskList il bl,+ CM.ToPlainText il,+ CE.HasFootnote il bl,+ CE.HasMath il,+ CE.HasDefinitionList il bl,+ CE.HasDiv bl,+ CE.HasQuoted il,+ CE.HasSpan il+ )++-- | GFM + official commonmark extensions+fullMarkdownSpec ::+ SyntaxSpec' m il bl =>+ CM.SyntaxSpec m il bl+fullMarkdownSpec =+ mconcat+ [ CE.gfmExtensions,+ CE.fancyListSpec,+ CE.footnoteSpec,+ CE.mathSpec,+ CE.smartPunctuationSpec,+ CE.definitionListSpec,+ CE.attributesSpec,+ CE.rawAttributeSpec,+ CE.fencedDivSpec,+ CE.bracketedSpanSpec,+ CE.autolinkSpec,+ CM.defaultSyntaxSpec,+ -- as the commonmark documentation states, pipeTableSpec should be placed after+ -- fancyListSpec and defaultSyntaxSpec to avoid bad results when parsing+ -- non-table lines+ CE.pipeTableSpec+ ]++-- | Identify metadata block at the top, and split it from markdown body.+--+-- FIXME: https://github.com/srid/neuron/issues/175+partitionMarkdown :: FilePath -> Text -> Either Text (Maybe Text, Text)+partitionMarkdown =+ parse (M.try splitP <|> fmap (Nothing,) M.takeRest)+ where+ separatorP :: M.Parsec Void Text ()+ separatorP =+ void $ M.string "---" <* M.eol+ splitP :: M.Parsec Void Text (Maybe Text, Text)+ splitP = do+ separatorP+ a <- toText <$> manyTill M.anySingle (M.try $ M.eol *> separatorP)+ b <- M.takeRest+ pure (Just a, b)+ parse :: M.Parsec Void Text a -> String -> Text -> Either Text a+ parse p fn s =+ first (toText . M.errorBundlePretty) $+ M.parse (p <* M.eof) fn s++-- | Convert Pandoc AST inlines to raw text.+plainify :: [B.Inline] -> Text+plainify = W.query $ \case+ B.Str x -> x+ B.Code _attr x -> x+ B.Space -> " "+ B.SoftBreak -> " "+ B.LineBreak -> " "+ B.RawInline _fmt s -> s+ B.Math _mathTyp s -> s+ -- Ignore the rest of AST nodes, as they are recursively defined in terms of+ -- `Inline` which `W.query` will traverse again.+ _ -> ""
+ src/Ema/Helper/PathTree.hs view
@@ -0,0 +1,78 @@+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeFamilies #-}++-- | Helper to deal with slug trees+module Ema.Helper.PathTree where++import qualified Data.List as List+import qualified Data.List.NonEmpty as NE+import Data.Tree (Tree (Node))+import qualified Data.Tree as Tree++-- -------------------+-- Data.Tree helpers+-- -------------------++treeInsertPath :: Eq a => NonEmpty a -> [Tree a] -> [Tree a]+treeInsertPath =+ treeInsertPathMaintainingOrder void++-- | Insert a node by path into a tree with descendants that are ordered.+--+-- Insertion will guarantee that descendants continue to be ordered as expected.+--+-- The order of descendents is determined by the given order function, which+-- takes the path to a node and return that node's order. The intention is to+-- lookup the actual order value which exists *outside* of the tree+-- datastructure itself.+treeInsertPathMaintainingOrder :: (Eq a, Ord ord) => (NonEmpty a -> ord) -> NonEmpty a -> [Tree a] -> [Tree a]+treeInsertPathMaintainingOrder ordF path t =+ orderedTreeInsertPath ordF (toList path) t []+ where+ orderedTreeInsertPath :: (Eq a, Ord b) => (NonEmpty a -> b) -> [a] -> [Tree a] -> [a] -> [Tree a]+ orderedTreeInsertPath _ [] trees _ =+ trees+ orderedTreeInsertPath pathOrder (top : rest) trees ancestors =+ case treeFindChild top trees of+ Nothing ->+ let newChild = Node top $ orderedTreeInsertPath pathOrder rest [] (top : ancestors)+ in sortChildrenOn pathOrder (trees <> one newChild)+ Just (Node _match grandChildren) ->+ let oneDead = treeDeleteChild top trees+ newChild = Node top $ orderedTreeInsertPath pathOrder rest grandChildren (top : ancestors)+ in sortChildrenOn pathOrder (oneDead <> one newChild)+ where+ treeFindChild x xs =+ List.find (\n -> Tree.rootLabel n == x) xs+ sortChildrenOn f =+ sortOn $ (\s -> f $ NE.reverse $ s :| ancestors) . Tree.rootLabel++treeDeletePath :: Eq a => NonEmpty a -> [Tree a] -> [Tree a]+treeDeletePath =+ treeDeletePathWithLastBehavingAs $ \lastInPath ts ->+ List.deleteBy (\x y -> Tree.rootLabel x == Tree.rootLabel y) (Node lastInPath []) ts++treeDeleteLeafPath :: Eq a => NonEmpty a -> [Tree a] -> [Tree a]+treeDeleteLeafPath =+ treeDeletePathWithLastBehavingAs $ \lastInPath ts ->+ case ts of+ [t] -> [t | Tree.rootLabel t /= lastInPath]+ _ -> ts++treeDeletePathWithLastBehavingAs :: forall a. Eq a => (a -> [Tree a] -> [Tree a]) -> NonEmpty a -> [Tree a] -> [Tree a]+treeDeletePathWithLastBehavingAs f slugs =+ go (toList slugs)+ where+ go :: [a] -> [Tree a] -> [Tree a]+ go [] t = t+ go [p] ts =+ f p ts+ go (p : ps) t =+ t <&> \node@(Node x xs) ->+ if x == p+ then Node x $ go ps xs+ else node++treeDeleteChild :: Eq a => a -> [Tree a] -> [Tree a]+treeDeleteChild x =+ List.deleteBy (\p q -> Tree.rootLabel p == Tree.rootLabel q) (Node x [])
src/Ema/Helper/Tailwind.hs view
@@ -9,6 +9,7 @@ layoutWith, -- * Tailwind shims+ twindShim, twindShimCdn, twindShimOfficial, twindShimUnofficial,@@ -25,7 +26,11 @@ -- | A simple and off-the-shelf layout using Tailwind CSS layout :: Ema.CLI.Action -> H.Html -> H.Html -> LByteString layout action =- layoutWith "en" "UTF-8" $ case action of+ layoutWith "en" "UTF-8" $ twindShim action++twindShim :: Ema.CLI.Action -> H.Html+twindShim action =+ case action of Ema.CLI.Generate _ -> twindShimUnofficial _ ->@@ -35,25 +40,27 @@ -- | Like @layout@, but pick your own language, encoding and tailwind shim. layoutWith :: H.AttributeValue -> H.AttributeValue -> H.Html -> H.Html -> H.Html -> LByteString-layoutWith lang encoding twindShim appHead appBody = RU.renderHtml $ do+layoutWith lang encoding tshim appHead appBody = RU.renderHtml $ do H.docType H.html ! A.lang lang $ do H.head $ do H.meta ! A.charset encoding -- This makes the site mobile friendly by default. H.meta ! A.name "viewport" ! A.content "width=device-width, initial-scale=1"+ tshim appHead- twindShim- H.body $ do+ -- The "overflow-y-scroll" makes the scrollbar visible always, so as to+ -- avoid janky shifts when switching to routes with suddenly scrollable content.+ H.body ! A.class_ "overflow-y-scroll" $ do appBody -- | Loads full tailwind CSS from CDN (not good for production) twindShimCdn :: H.Html twindShimCdn =- H.unsafeByteString . encodeUtf8 $- [text|- <link href="https://unpkg.com/tailwindcss@2.1.1/dist/tailwind.min.css" rel="stylesheet" type="text/css">- |]+ H.link+ ! A.href "https://unpkg.com/tailwindcss@latest/dist/tailwind.min.css"+ ! A.rel "stylesheet"+ ! A.type_ "text/css" -- | This shim may not work with hot reload. twindShimOfficial :: H.Html@@ -76,6 +83,9 @@ twindShimUnofficialEval = H.unsafeByteString . encodeUtf8 $ [text|- twind.setup({})- twindObserve.observe(document.documentElement)+ // Be silent to avoid complaining about non-tailwind classes+ // https://github.com/tw-in-js/twind/discussions/180#discussioncomment-678272+ console.log("ema: Twind: setup & observe")+ twind.setup({mode: 'silent'})+ window.emaTwindObs = twindObserve.observe(document.documentElement); |]
src/Ema/Route.hs view
@@ -3,25 +3,63 @@ module Ema.Route ( routeUrl,- routeFile,- Slug (unSlug),+ routeUrlWith, UrlStrategy (..), ) where -import Data.Default (def)-import Ema.Class-import Ema.Route.Slug (Slug (unSlug))-import Ema.Route.UrlStrategy- ( UrlStrategy (..),- slugFileWithStrategy,- slugUrlWithStrategy,- )+import Data.Aeson (FromJSON (parseJSON), Value)+import Data.Aeson.Types (Parser)+import qualified Data.List.NonEmpty as NE+import qualified Data.Text as T+import Ema.Class (Ema (encodeRoute))+import Ema.Route.Slug (unicodeNormalize)+import qualified Network.URI.Encode as UE -routeUrl :: forall a r. Ema a r => r -> Text-routeUrl r =- slugUrlWithStrategy def (encodeRoute @a r)+data UrlStrategy+ = UrlPretty+ | UrlDirect+ deriving (Eq, Show, Ord) -routeFile :: forall a r. Ema a r => r -> FilePath-routeFile r =- slugFileWithStrategy def (encodeRoute @a r)+instance FromJSON UrlStrategy where+ parseJSON val =+ f UrlPretty "pretty" val <|> f UrlDirect "direct" val+ where+ f :: UrlStrategy -> Text -> Value -> Parser UrlStrategy+ f c s v = do+ x <- parseJSON v+ guard $ x == s+ pure c++-- | Return the relative URL of the given route+--+-- As the returned URL is relative, you will have to either make it absolute (by+-- prepending with `/`) or set the `<base>` URL in your HTML head element.+routeUrlWith :: forall r model. Ema model r => UrlStrategy -> model -> r -> Text+routeUrlWith urlStrategy model =+ relUrlFromPath . encodeRoute model+ where+ relUrlFromPath :: FilePath -> Text+ relUrlFromPath fp =+ case T.stripSuffix (urlStrategySuffix urlStrategy) (toText fp) of+ Just htmlFp ->+ case nonEmpty (UE.encodeText . unicodeNormalize <$> T.splitOn "/" htmlFp) of+ Nothing ->+ ""+ Just (removeLastIf "index" -> partsSansIndex) ->+ T.intercalate "/" partsSansIndex+ Nothing ->+ T.intercalate "/" $ UE.encodeText . unicodeNormalize <$> T.splitOn "/" (toText fp)+ where+ removeLastIf :: Eq a => a -> NonEmpty a -> [a]+ removeLastIf x xs =+ if NE.last xs == x+ then NE.init xs+ else toList xs+ urlStrategySuffix = \case+ UrlPretty -> ".html"+ UrlDirect -> ""++routeUrl :: forall r model. Ema model r => model -> r -> Text+routeUrl =+ routeUrlWith UrlPretty
src/Ema/Route/Slug.hs view
@@ -1,16 +1,38 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE InstanceSigs #-} module Ema.Route.Slug where +import Data.Aeson (FromJSON, ToJSON)+import Data.Data (Data) import qualified Data.Text as T+import qualified Data.Text.Normalize as UT+import qualified Network.URI.Encode as UE -- | An URL path is made of multiple slugs, separated by '/' newtype Slug = Slug {unSlug :: Text}- deriving (Eq, Show)+ deriving (Eq, Show, Ord, Data, Generic, ToJSON, FromJSON) +-- | Decode an URL component into a `Slug` using `Network.URI.Encode`+decodeSlug :: Text -> Slug+decodeSlug =+ fromString . UE.decode . toString++-- | Encode a `Slug` into an URL component using `Network.URI.Encode`+encodeSlug :: Slug -> Text+encodeSlug =+ UE.encodeText . unSlug+ instance IsString Slug where fromString :: HasCallStack => String -> Slug fromString (toText -> s) = if "/" `T.isInfixOf` s then error ("Slug cannot contain a slash: " <> s)- else Slug s+ else Slug (unicodeNormalize s)++-- Normalize varying non-ascii strings (in filepaths / slugs) to one+-- representation, so that they can be reliably linked to.+unicodeNormalize :: Text -> Text+unicodeNormalize = UT.normalize UT.NFC . toText
− src/Ema/Route/UrlStrategy.hs
@@ -1,46 +0,0 @@-{-# LANGUAGE InstanceSigs #-}-{-# LANGUAGE QuasiQuotes #-}--module Ema.Route.UrlStrategy where--import Data.Default (Default, def)-import qualified Data.Text as T-import Ema.Route.Slug (Slug (unSlug))-import System.FilePath (joinPath)--data UrlStrategy- = -- | URLs always end with a slash, and correspond to index.html in that folder- UrlStrategy_FolderOnly- | -- | Pretty URLs without ugly .html ext or slash-suffix- UrlStrategy_HtmlOnlySansExt- deriving (Eq, Show, Ord)--instance Default UrlStrategy where- def = UrlStrategy_HtmlOnlySansExt--slugUrlWithStrategy :: UrlStrategy -> [Slug] -> Text-slugUrlWithStrategy strat slugs =- case strat of- UrlStrategy_FolderOnly ->- "/" <> T.replace "index.html" "" (toText $ slugFileWithStrategy strat slugs)- UrlStrategy_HtmlOnlySansExt ->- -- FIXME: This should replace only at the end, not middle- let fp = toText (slugFileWithStrategy strat slugs)- in if- | "index.html" == fp ->- "/"- | "/index.html" `T.isSuffixOf` fp ->- "/" <> T.take (T.length fp - T.length "/index.html") fp- | ".html" `T.isSuffixOf` fp ->- "/" <> T.take (T.length fp - T.length ".html") fp- | otherwise ->- "/" <> fp--slugFileWithStrategy :: UrlStrategy -> [Slug] -> FilePath-slugFileWithStrategy strat slugs =- case strat of- UrlStrategy_FolderOnly ->- joinPath $ fmap (toString . unSlug) slugs <> ["index.html"]- UrlStrategy_HtmlOnlySansExt ->- let (term :| (reverse -> parts)) = fromMaybe ("index" :| []) $ nonEmpty (reverse $ fmap unSlug slugs)- in joinPath $ fmap toString parts <> [toString term <> ".html"]
src/Ema/Server.hs view
@@ -1,7 +1,6 @@ {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TypeApplications #-} --- | TODO: Refactor this module module Ema.Server where import Control.Concurrent.Async (race)@@ -10,7 +9,8 @@ import Data.LVar (LVar) import qualified Data.LVar as LVar import qualified Data.Text as T-import Ema.Class (Ema (decodeRoute, staticAssets), MonadEma)+import Ema.Asset+import Ema.Class (Ema (..)) import GHC.IO.Unsafe (unsafePerformIO) import NeatInterpolation (text) import qualified Network.HTTP.Types as H@@ -20,21 +20,33 @@ import qualified Network.Wai.Middleware.Static as Static import Network.WebSockets (ConnectionException) import qualified Network.WebSockets as WS-import Relude.Extra.Foldable1 (foldl1')+import System.FilePath ((</>)) import Text.Printf (printf)+import UnliftIO (MonadUnliftIO) runServerWithWebSocketHotReload :: forall model route m.- (Ema model route, Show route, MonadEma m) =>+ ( Ema model route,+ Show route,+ MonadIO m,+ MonadUnliftIO m,+ MonadLoggerIO m+ ) =>+ String -> Int -> LVar model ->- (model -> route -> LByteString) ->+ (model -> route -> Asset LByteString) -> m ()-runServerWithWebSocketHotReload port model render = do- let settings = Warp.setPort port Warp.defaultSettings+runServerWithWebSocketHotReload host port model render = do+ let settings =+ Warp.defaultSettings+ & Warp.setPort port+ & Warp.setHost (fromString host) logger <- askLoggerIO - logInfoN $ "Launching Ema at http://localhost:" <> show port+ logInfoN "============================================"+ logInfoN $ "Running live server at http://" <> toText host <> ":" <> show port+ logInfoN "============================================" liftIO $ Warp.runSettings settings $ assetsMiddleware $@@ -55,16 +67,30 @@ log LevelInfo "Connected" let askClientForRoute = do msg :: Text <- liftIO $ WS.receiveData conn- let r =- msg- & pathInfoFromWsMsg- & routeFromPathInfo- & fromMaybe (error "invalid route from ws")- log LevelDebug $ "<~~ " <> show r- pure r- sendRouteHtmlToClient r s = do- liftIO $ WS.sendTextData conn $ renderWithEmaHtmlShims logger s r- log LevelDebug $ " ~~> " <> show r+ -- TODO: Let non-html routes pass through.+ let pathInfo = pathInfoFromWsMsg msg+ log LevelDebug $ "<~~ " <> show pathInfo+ pure pathInfo+ decodeRouteWithCurrentModel pathInfo = do+ val <- LVar.get model+ pure $ routeFromPathInfo val pathInfo+ sendRouteHtmlToClient pathInfo s = do+ decodeRouteWithCurrentModel pathInfo >>= \case+ Nothing ->+ liftIO $ WS.sendTextData conn $ emaErrorHtmlResponse decodeRouteNothingMsg+ Just r -> do+ case renderCatchingErrors logger s r of+ AssetStatic staticPath ->+ -- HACK: Websocket client should check for REDIRECT prefix.+ -- Not bothering with JSON to avoid having to JSON parse every HTML dump.+ liftIO $ WS.sendTextData conn $ "REDIRECT " <> toText staticPath+ AssetGenerated Html html ->+ liftIO $ WS.sendTextData conn $ html <> emaStatusHtml+ AssetGenerated Other _s ->+ -- HACK: Websocket client should check for REDIRECT prefix.+ -- Not bothering with JSON to avoid having to JSON parse every HTML dump.+ liftIO $ WS.sendTextData conn $ "REDIRECT " <> toText (encodeRoute s r)+ log LevelDebug $ " ~~> " <> show r 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@@ -72,72 +98,98 @@ -- 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+ mWatchingRoute <- askClientForRoute -- 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) (runLoggingT askClientForRoute logger) >>= \res -> flip runLoggingT logger $ case res of- Left newHtml -> do+ Left newModel -> do -- The page the user is currently viewing has changed. Send -- the new HTML to them.- sendRouteHtmlToClient watchingRoute newHtml+ sendRouteHtmlToClient mWatchingRoute newModel lift loop- Right nextRoute -> do+ Right mNextRoute -> 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).- sendRouteHtmlToClient nextRoute =<< LVar.get model+ sendRouteHtmlToClient mNextRoute =<< LVar.get model lift loop liftIO (try loop) >>= \case Right () -> pure ()- Left (err :: ConnectionException) -> do- log LevelError $ "Websocket error: " <> show err+ Left (connExc :: ConnectionException) -> do+ case connExc of+ WS.CloseRequest _ (decodeUtf8 -> reason) ->+ log LevelInfo $ "Closing websocket connection (reason: " <> reason <> ")"+ _ ->+ log LevelError $ "Websocket error: " <> show connExc LVar.removeListener model subId- assetsMiddleware = do- case nonEmpty (staticAssets $ Proxy @route) of- Nothing -> id- Just topLevelPaths ->- let assetPolicy :: Static.Policy =- foldl1' (Static.<|>) $ Static.hasPrefix <$> topLevelPaths- in Static.staticPolicy assetPolicy+ assetsMiddleware =+ Static.static httpApp logger req f = do flip runLoggingT logger $ do+ val <- LVar.get model let path = Wai.pathInfo req- mr = routeFromPathInfo path+ mr = routeFromPathInfo val path logInfoNS "HTTP" $ show path <> " as " <> show mr- (status, v) <- case mr of+ case mr of Nothing ->- pure (H.status404, "No route")+ liftIO $ f $ Wai.responseLBS H.status404 [(H.hContentType, "text/plain")] $ encodeUtf8 decodeRouteNothingMsg Just r -> do- val <- LVar.get model- let html = renderCatchingErrors logger val r- pure (H.status200, html <> emaStatusHtml <> wsClientShim)- liftIO $ f $ Wai.responseLBS status [(H.hContentType, "text/html")] v- renderWithEmaHtmlShims logger m r =- renderCatchingErrors logger m r <> emaStatusHtml+ case renderCatchingErrors logger val r of+ AssetStatic staticPath -> do+ let mimeType = Static.getMimeType staticPath+ liftIO $ f $ Wai.responseFile H.status200 [(H.hContentType, mimeType)] staticPath Nothing+ AssetGenerated Html html -> do+ let s = html <> emaStatusHtml <> wsClientShim+ liftIO $ f $ Wai.responseLBS H.status200 [(H.hContentType, "text/html")] s+ AssetGenerated Other s -> do+ let mimeType = Static.getMimeType $ encodeRoute val r+ liftIO $ f $ Wai.responseLBS H.status200 [(H.hContentType, mimeType)] s renderCatchingErrors logger m r = unsafeCatch (render m r) $ \(err :: SomeException) -> unsafePerformIO $ do -- Log the error first. flip runLoggingT logger $ logErrorNS "App" $ show @Text err pure $- encodeUtf8 $- "<html><head><meta charset=\"UTF-8\"></head><body><h1>Ema App threw an exception</h1><pre style=\"border: 1px solid; padding: 1em 1em 1em 1em;\">"- <> show @Text err- <> "</pre><p>Once you fix your code this page will automatically update.</body>"- routeFromPathInfo =- decodeRoute @model . fmap (fromString . toString)+ AssetGenerated Html . emaErrorHtml $+ show @Text err+ routeFromPathInfo m =+ decodeUrlRoute m . T.intercalate "/" -- TODO: It would be good have this also get us the stack trace. unsafeCatch :: Exception e => a -> (e -> a) -> a unsafeCatch x f = unsafePerformIO $ catch (seq x $ pure x) (pure . f) +-- | A basic error response for displaying in the browser+emaErrorHtmlResponse :: Text -> LByteString+emaErrorHtmlResponse err =+ emaErrorHtml err <> emaStatusHtml++emaErrorHtml :: Text -> LByteString+emaErrorHtml s =+ encodeUtf8 $+ "<html><head><meta charset=\"UTF-8\"></head><body><h1>Ema App threw an exception</h1><pre style=\"border: 1px solid; padding: 1em 1em 1em 1em;\">"+ <> s+ <> "</pre><p>Once you fix the source of the error, this page will automatically refresh.</body>"+ -- | Return the equivalent of WAI's @pathInfo@, from the raw path string -- (`document.location.pathname`) the browser sends us. pathInfoFromWsMsg :: Text -> [Text] pathInfoFromWsMsg = filter (/= "") . T.splitOn "/" . T.drop 1 +-- | Decode a URL path into a route+--+-- This function is used only in live server.+decodeUrlRoute :: forall model route. Ema model route => model -> Text -> Maybe route+decodeUrlRoute model (toString -> s) = do+ decodeRoute @model @route model s+ <|> decodeRoute @model @route model (s <> ".html")+ <|> decodeRoute @model @route model (s </> "index.html")++decodeRouteNothingMsg :: Text+decodeRouteNothingMsg = "Ema: 404 (decodeRoute returned Nothing)"+ -- Browser-side JavaScript code for interacting with the Haskell server wsClientShim :: LByteString wsClientShim =@@ -158,9 +210,12 @@ function setHtml(elm, html) { var htmlElem = htmlToElem(html); morphdom(elm, html);+ // Re-add <script> tags, because just DOM diff applying is not enough.+ reloadScripts(elm); }; - // FIXME: Can't make this work with tailwind shim+ // FIXME: This doesn't reliably work across all JS.+ // See also the HACK below in one of the invocations. function reloadScripts(elm) { Array.from(elm.querySelectorAll("script")).forEach(oldScript => { const newScript = document.createElement("script");@@ -197,28 +252,46 @@ document.getElementById("ema-indicator").style.display = "none"; }; + // Base URL path - for when the ema site isn't served at "/"+ const baseHref = document.getElementsByTagName("base")[0]?.href;+ const basePath = baseHref ? new URL(baseHref).pathname : "/";++ // Use TLS for websocket iff the current page is also served with TLS+ const wsProto = window.location.protocol === "https:" ? "wss://" : "ws://";+ const wsUrl = wsProto + window.location.host + basePath;+ // WebSocket logic: watching for server changes & route switching- function init() {- console.log("ema: Opening ws conn");+ function init(reconnecting) {+ // The route current DOM is displaying+ let routeVisible = document.location.pathname;++ const verb = reconnecting ? "Reopening" : "Opening";+ console.log(`ema: $${verb} conn $${wsUrl} ...`); window.connecting();- var ws = new WebSocket("ws://" + window.location.host);+ let ws = new WebSocket(wsUrl); + function sendObservePath(path) {+ const relPath = path.startsWith(basePath) ? path.slice(basePath.length - 1) : path;+ console.debug(`ema: requesting $${relPath}`);+ ws.send(relPath);+ }+ // Call this, then the server will send update *once*. Call again for // continous monitoring. function watchCurrentRoute() { console.log(`ema: ⏿ Observing changes to $${document.location.pathname}`);- ws.send(document.location.pathname);+ sendObservePath(document.location.pathname); }; function switchRoute(path) { console.log(`ema: → Switching to $${path}`);- ws.send(path);+ sendObservePath(path); } function handleRouteClicks(e) { const origin = e.target.closest("a"); if (origin) {- if (window.location.host === origin.host) {+ if (window.location.host === origin.host && origin.getAttribute("target") != "_blank") { window.history.pushState({}, "", origin.pathname); switchRoute(origin.pathname); e.preventDefault();@@ -230,8 +303,17 @@ window.addEventListener(`click`, handleRouteClicks); ws.onopen = () => {+ console.log(`ema: ... connected!`); // window.connected(); window.hideIndicator();+ if (!reconnecting) {+ // HACK: We have to reload <script>'s here on initial page load+ // here, so as to make Twind continue to function on the *next*+ // route change. This is not a problem with *subsequent* (ie. 2nd+ // or latter) route clicks, because those have already called+ // reloadScripts at least once.+ reloadScripts(document.documentElement);+ }; watchCurrentRoute(); }; @@ -247,14 +329,23 @@ // connection error (ghcid hasn't rebooted yet), which cannot be // avoided as it is impossible to trap this error and handle it. // You'll see a big ugly error in the console.- setTimeout(init, 400);+ setTimeout(function () {init(true);}, 400); }; ws.onmessage = evt => {- console.log("ema: ✍ Patching DOM")- setHtml(document.documentElement, evt.data);- // reloadScripts(document.documentElement);- watchCurrentRoute();+ if (evt.data.startsWith("REDIRECT ")) {+ console.log("ema: redirect");+ document.location.href = evt.data.slice("REDIRECT ".length);+ } else {+ console.log("ema: ✍ Patching DOM");+ setHtml(document.documentElement, evt.data);+ if (routeVisible != document.location.pathname) {+ // This is a new route switch; scroll up.+ window.scrollTo({ top: 0});+ routeVisible = document.location.pathname;+ } + watchCurrentRoute();+ }; }; window.onbeforeunload = evt => { ws.close(); }; window.onpagehide = evt => { ws.close(); };@@ -266,7 +357,7 @@ }; }; - window.onpageshow = init;+ window.onpageshow = function () { init(false) }; </script> |] @@ -286,29 +377,26 @@ > <div hidden- class="bg-green-600 w-3 h-3 rounded-full flex-none"+ class="flex-none w-3 h-3 bg-green-600 rounded-full" id="ema-connected" ></div> <div hidden- class="- animate-spin bg-gradient-to-r from-blue-300 to-blue-600- w-3 h-3 rounded-full flex-none- "+ class="flex-none w-3 h-3 rounded-full animate-spin bg-gradient-to-r from-blue-300 to-blue-600" id="ema-reloading" ></div> <div hidden- class="bg-yellow-500 w-3 h-3 rounded-full flex-none"+ class="flex-none w-3 h-3 bg-yellow-500 rounded-full" id="ema-connecting" > <div- class="animate-ping bg-yellow-500 w-3 h-3 rounded-full flex-none"+ class="flex-none w-3 h-3 bg-yellow-500 rounded-full animate-ping" ></div> </div> <div hidden- class="bg-red-500 w-3 h-3 rounded-full flex-none"+ class="flex-none w-3 h-3 bg-red-500 rounded-full" id="ema-disconnected" ></div> <p class="whitespace-nowrap" id="ema-message"></p>