ema 0.10.2.0 → 0.12.0.0
raw patch · 17 files changed
+604/−430 lines, 17 filesdep −constraints-extrasdep −dependent-sumdep −dependent-sum-templatedep ~basedep ~lvar
Dependencies removed: constraints-extras, dependent-sum, dependent-sum-template
Dependency ranges changed: base, lvar
Files
- CHANGELOG.md +18/−4
- README.md +5/−5
- ema.cabal +9/−8
- src/Ema.hs +0/−3
- src/Ema/App.hs +35/−23
- src/Ema/CLI.hs +31/−30
- src/Ema/Generate.hs +1/−1
- src/Ema/Route/Lib/File.hs +1/−1
- src/Ema/Route/Lib/Folder.hs +1/−1
- src/Ema/Route/Url.hs +3/−3
- src/Ema/Server.hs +32/−201
- src/Ema/Server/Common.hs +98/−0
- src/Ema/Server/HTTP.hs +58/−0
- src/Ema/Server/WebSocket.hs +83/−0
- src/Ema/Server/WebSocket/Options.hs +60/−0
- src/Ema/Site.hs +2/−3
- www/ema-shim.js +167/−147
CHANGELOG.md view
@@ -1,5 +1,19 @@ # Revision history for ema +## 0.12.0.0 (2025-07-22)++- Relax `base` constraint forever+- Require `lvar` 0.2 or later ([simplified API](https://github.com/srid/lvar/pull/8))+- API changes+ - `Ema.CLI`: The `Action` type is no longer a GADT.+ - `Ema.Server`: This module has be split into several smaller modules+- Live server:+ - Shim/websocket customization ([\#152](https://github.com/srid/ema/pull/152)) @lucasvreis+ - Fix scrolling to page end when using pathname in anchor links (\#162)+ - Add `--no-ws` to disable websocket handling in live server (\#161)+ - Switch from `morphdom` to `idiomorph`+ - Allow skipping recreation of any `<script>` tag during live server update by using `data-ema-skip=true` custom attribute (\#170)+ ## 0.10.2.0 (2023-08-09) - Simply websocket route observation logic (\#154)@@ -28,7 +42,7 @@ - Represent route encoding using `Prism'` from optics-core; add `IsRoute` class to define them. - Optional generic deriving of route prisms, so you do not have to hand-write them. - Automatic isomorphism checks ensures that encoding and decoding are isomorphic (route prisms are lawful)- - Composable Ema apps + - Composable Ema apps - There are two ways of composing Ema apps. Using heterogenous lists (see `Ema.Route.Lib.Multi`), or by defining a top-level route type (see `Ex04_Multi.hs`). - Replace `LVar` with `Dynamic`. - Ema still uses `LVar` internally (for live server updates), but on the user-side one only needs to provide a `Dynamic` which is a tuple of initial value and an updating function. The [unionmount](https://github.com/srid/unionmount/pull/1) library was changed to provide this tuple.@@ -55,7 +69,7 @@ - Remove unused Cabal deps (#61) - `Tailwind.layoutWith`: don't hardcode `<body>` attrs - Tailwind: module revamped and renamed to `Tailwind.Helper.Blaze`-- `runEma` and friends: +- `runEma` and friends: - return the monadic's action's return value or generated files (dependent type) - CLI: add `run` subcommand that takes `--host` and `--port` (and remove environment hacks of $HOST and $PORT) @@ -72,12 +86,12 @@ - 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: + - `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`: +- `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.
README.md view
@@ -3,6 +3,7 @@ <img width="10%" src="https://ema.srid.ca/favicon.svg"> [](https://hackage.haskell.org/package/ema)+[](https://compass.naivete.me/ "This project follows the 'Naiveté Compass of Mood'") 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. @@ -10,9 +11,9 @@ ## Hacking -Run `bin/run`. This runs the Ex04_Multi example.+Run `just run` in the devShell. This runs the Ex04_Multi example. -To run the docs, run `nix run github:srid/emanote -- -L ./docs`.+To run the docs, run `nix run .#docs`. ## Getting Started @@ -20,7 +21,6 @@ ## Discussion -To discuss the Ema project, [join Matrix][matrix] or post in [GitHub Discussions][ghdiscuss].+To discuss the Ema project, post in [GitHub Discussions][ghdiscuss]. -[matrix]: https://matrix.to/#/#ema:matrix.org-[ghdiscuss]: https://github.com/EmaApps/ema/discussions+[ghdiscuss]: https://github.com/srid/ema/discussions
ema.cabal view
@@ -1,6 +1,6 @@ cabal-version: 2.4 name: ema-version: 0.10.2.0+version: 0.12.0.0 license: AGPL-3.0-only copyright: 2021 Sridhar Ratnakumar maintainer: srid@srid.ca@@ -28,7 +28,6 @@ common extensions default-extensions:- NoStarIsType BangPatterns ConstraintKinds DataKinds@@ -54,6 +53,7 @@ LambdaCase MultiParamTypeClasses MultiWayIf+ NoStarIsType NumericUnderscores OverloadedStrings PolyKinds@@ -79,24 +79,21 @@ build-depends: , aeson , async- , base >=4.13.0.0 && <4.17.0.0.0- , constraints-extras+ , base >=4.13.0.0 && <4.99 , data-default- , dependent-sum- , dependent-sum-template , directory , file-embed , filepath , filepattern , http-types- , lvar+ , lvar >=0.2 , monad-logger , monad-logger-extras , mtl , neat-interpolation , optics-core , optparse-applicative- , relude >=1.0+ , relude >=1.0 , sop-core , text , unliftio@@ -134,6 +131,10 @@ Ema.Route.Prism.Type Ema.Route.Url Ema.Server+ Ema.Server.Common+ Ema.Server.HTTP+ Ema.Server.WebSocket+ Ema.Server.WebSocket.Options Ema.Site hs-source-dirs: src
src/Ema.hs view
@@ -12,7 +12,4 @@ routeUrl, routeUrlWith, )-import Ema.Server as X (- emaErrorHtmlResponse,- ) import Ema.Site as X
src/Ema/App.hs view
@@ -1,18 +1,18 @@ {-# LANGUAGE AllowAmbiguousTypes #-} module Ema.App (+ SiteConfig (..), runSite, runSite_,- runSiteWithCli,+ runSiteWith, ) where import Control.Concurrent (threadDelay) import Control.Concurrent.Async (race_) import Control.Monad.Logger (LoggingT (runLoggingT), MonadLoggerIO (askLoggerIO), logInfoNS, logWarnNS) import Control.Monad.Logger.Extras (runLoggerLoggingT)-import Data.Dependent.Sum (DSum ((:=>)))+import Data.Default (Default, def) import Data.LVar qualified as LVar-import Data.Some (Some (Some)) import Ema.CLI (getLogger) import Ema.CLI qualified as CLI import Ema.Dynamic (Dynamic (Dynamic))@@ -22,6 +22,18 @@ import Ema.Site (EmaSite (SiteArg, siteInput), EmaStaticSite) import System.Directory (getCurrentDirectory) +data SiteConfig r = SiteConfig+ { siteConfigCli :: CLI.Cli+ , siteConfigWebSocketOptions :: Server.EmaWebSocketOptions r+ }++instance Default (SiteConfig r) where+ def =+ SiteConfig+ { siteConfigCli = def+ , siteConfigWebSocketOptions = def+ }+ {- | Run the given Ema site, Takes as argument the associated `SiteArg`.@@ -34,50 +46,50 @@ (Show r, Eq r, EmaStaticSite r) => -- | The input required to create the `Dynamic` of the `RouteModel` SiteArg r ->- IO [FilePath]+ IO (FilePath, [FilePath]) runSite input = do cli <- CLI.cliAction- result <- snd <$> runSiteWithCli @r cli input- case result of- CLI.Run _ :=> Identity () ->- flip runLoggerLoggingT (getLogger cli) $- CLI.crash "ema" "Live server unexpectedly stopped"- CLI.Generate _ :=> Identity fs ->- pure fs+ let cfg = SiteConfig cli def+ snd <$> runSiteWith @r cfg input -- | Like @runSite@ but discards the result runSite_ :: forall r. (Show r, Eq r, EmaStaticSite r) => SiteArg r -> IO () runSite_ = void . runSite @r -{- | Like @runSite@ but takes the CLI action. Also returns more information.+{- | Like @runSite@ but takes custom @SiteConfig@. - Useful if you are handling the CLI arguments yourself.+ Useful if you are handling the CLI arguments yourself and/or customizing the+ server websocket handler. - Use "void $ Ema.runSiteWithCli def ..." if you are running live-server only.+ Use "void $ Ema.runSiteWith def ..." if you are running live-server only. -}-runSiteWithCli ::+runSiteWith :: forall r. (Show r, Eq r, EmaStaticSite r) =>- CLI.Cli ->+ SiteConfig r -> SiteArg r -> IO ( -- The initial model value. RouteModel r- , DSum CLI.Action Identity+ , -- Out path, and the list of statically generated files+ (FilePath, [FilePath]) )-runSiteWithCli cli siteArg = do+runSiteWith cfg siteArg = do+ let opts = siteConfigWebSocketOptions cfg+ cli = siteConfigCli cfg flip runLoggerLoggingT (getLogger cli) $ do cwd <- liftIO getCurrentDirectory logInfoNS "ema" $ "Launching Ema under: " <> toText cwd Dynamic (model0 :: RouteModel r, cont) <- siteInput @r (CLI.action cli) siteArg case CLI.action cli of- Some act@(CLI.Generate dest) -> do+ CLI.Generate dest -> do fs <- generateSiteFromModel @r dest model0- pure (model0, act :=> Identity fs)- Some act@(CLI.Run (host, mport)) -> do+ pure (model0, (dest, fs))+ CLI.Run (host, mport, CLI.unNoWebSocket -> noWebSocket) -> do model <- LVar.empty LVar.set model model0 logger <- askLoggerIO+ let mWsOpts = if noWebSocket then Nothing else Just opts liftIO $ race_ ( flip runLoggingT logger $ do@@ -88,6 +100,6 @@ liftIO $ threadDelay maxBound ) ( flip runLoggingT logger $ do- Server.runServerWithWebSocketHotReload @r host mport model+ Server.runServerWithWebSocketHotReload @r mWsOpts host mport model )- pure (model0, act :=> Identity ())+ CLI.crash "ema" "Live server unexpectedly stopped"
src/Ema/CLI.hs view
@@ -1,6 +1,5 @@ {-# LANGUAGE ApplicativeDo #-} {-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE TemplateHaskell #-} module Ema.CLI where @@ -10,14 +9,7 @@ colorize, logToStdout, )-import Data.Constraint.Extras.TH (deriveArgDict) import Data.Default (Default (def))-import Data.GADT.Compare.TH (- DeriveGCompare (deriveGCompare),- DeriveGEQ (deriveGEq),- )-import Data.GADT.Show.TH (DeriveGShow (deriveGShow))-import Data.Some (Some (..)) import Network.Wai.Handler.Warp (Port) import Options.Applicative hiding (action) @@ -29,25 +21,29 @@ def = "127.0.0.1" -- | CLI subcommand-data Action result where- -- | Generate static files at the given output directory, returning the list- -- of generated files.- Generate :: FilePath -> Action [FilePath]- -- | Run the live server- Run :: (Host, Maybe Port) -> Action ()+data Action+ = -- | Generate static files at the given output directory, returning the list+ -- of generated files.+ Generate FilePath+ | -- | Run the live server+ Run (Host, Maybe Port, NoWebSocket)+ deriving stock (Eq, Show, Generic) -$(deriveGEq ''Action)-$(deriveGShow ''Action)-$(deriveGCompare ''Action)-$(deriveArgDict ''Action)+-- | Whether to disable websocket-based refresh and page loads.+newtype NoWebSocket = NoWebSocket {unNoWebSocket :: Bool}+ deriving newtype (Eq, Show)+ deriving stock (Generic) -isLiveServer :: Some Action -> Bool-isLiveServer (Some (Run _)) = True+instance Default NoWebSocket where+ def = NoWebSocket False++isLiveServer :: Action -> Bool+isLiveServer (Run _) = True isLiveServer _ = False -- | Ema's command-line interface options data Cli = Cli- { action :: Some Action+ { action :: Action -- ^ The Ema action to run , verbose :: Bool -- ^ Logging verbosity@@ -56,24 +52,25 @@ instance Default Cli where -- By default, run the live server on random port.- def = Cli (Some (Run def)) False+ def = Cli (Run def) False cliParser :: Parser Cli cliParser = do action <-- subparser- (command "gen" (info generate (progDesc "Generate static site")))- <|> subparser (command "run" (info run (progDesc "Run the live server")))- <|> pure (Some $ Run def)+ hsubparser+ ( command "gen" (info generate (progDesc "Generate static site"))+ <> command "run" (info run (progDesc "Run the live server"))+ )+ <|> pure (Run def) verbose <- switch (long "verbose" <> short 'v' <> help "Enable verbose logging") pure Cli {..} where- run :: Parser (Some Action)+ run :: Parser Action run =- fmap (Some . Run) $ (,) <$> hostParser <*> optional portParser- generate :: Parser (Some Action)+ fmap Run $ (,,) <$> hostParser <*> optional portParser <*> noWebSocketParser+ generate :: Parser Action generate =- Some . Generate <$> argument str (metavar "DEST")+ Generate <$> argument str (metavar "DEST") hostParser :: Parser Host hostParser =@@ -82,6 +79,10 @@ portParser :: Parser Port portParser = option auto (long "port" <> short 'p' <> metavar "PORT" <> help "Port to bind to")++noWebSocketParser :: Parser NoWebSocket+noWebSocketParser =+ NoWebSocket <$> switch (long "no-ws" <> help "Disable websocket") -- | Parse Ema CLI arguments passed by the user. cliAction :: IO Cli
src/Ema/Generate.hs view
@@ -28,7 +28,7 @@ import System.FilePath (takeDirectory, (</>)) import System.FilePattern.Directory (getDirectoryFiles) -log :: MonadLogger m => LogLevel -> Text -> m ()+log :: (MonadLogger m) => LogLevel -> Text -> m () log = logWithoutLoc "ema.generate" {- | Generate the static site at `dest`
src/Ema/Route/Lib/File.hs view
@@ -18,7 +18,7 @@ newtype FileRoute (filename :: Symbol) = FileRoute () deriving stock (Eq, Ord, Show, Generic) -instance KnownSymbol fn => IsRoute (FileRoute fn) where+instance (KnownSymbol fn) => IsRoute (FileRoute fn) where type RouteModel (FileRoute fn) = () routePrism () = toPrism_ $
src/Ema/Route/Lib/Folder.hs view
@@ -34,7 +34,7 @@ -- | Prefix the encoding of the given route prism. prefixRoutePrism :: forall prefix r.- KnownSymbol prefix =>+ (KnownSymbol prefix) => (RouteModel r -> Prism_ FilePath r) -> (RouteModel r -> Prism_ FilePath (FolderRoute prefix r)) prefixRoutePrism =
src/Ema/Route/Url.hs view
@@ -20,7 +20,7 @@ site's base URL or path (typically just `/`). Otherwise you must accordingly make these URLs absolute yourself. -}-routeUrlWith :: HasCallStack => UrlStrategy -> Prism' FilePath r -> r -> Text+routeUrlWith :: (HasCallStack) => UrlStrategy -> Prism' FilePath r -> r -> Text routeUrlWith urlStrategy rp = relUrlFromPath . review rp where@@ -36,7 +36,7 @@ Nothing -> T.intercalate "/" $ filepathToUrl fp where- removeLastIfOneOf :: Eq a => [a] -> NonEmpty a -> [a]+ removeLastIfOneOf :: (Eq a) => [a] -> NonEmpty a -> [a] removeLastIfOneOf x xs = if last xs `elem` x then init xs@@ -54,7 +54,7 @@ toString . T.intercalate "/" . fmap (Slug.unSlug . Slug.decodeSlug) . T.splitOn "/" -- | Like `routeUrlWith` but uses @UrlDirect@ strategy-routeUrl :: HasCallStack => Prism' FilePath r -> r -> Text+routeUrl :: (HasCallStack) => Prism' FilePath r -> r -> Text routeUrl = routeUrlWith UrlDirect
src/Ema/Server.hs view
@@ -1,42 +1,23 @@-{-# LANGUAGE AllowAmbiguousTypes #-}-{-# LANGUAGE QuasiQuotes #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE TemplateHaskell #-}--module Ema.Server where+module Ema.Server (+ EmaWebSocketOptions (..),+ runServerWithWebSocketHotReload,+) where import Control.Monad.Logger-import Data.FileEmbed import Data.LVar (LVar)-import Data.LVar qualified as LVar-import Data.Text qualified as T-import Ema.Asset (- Asset (AssetGenerated, AssetStatic),- Format (Html, Other),- ) import Ema.CLI (Host (unHost))-import Ema.Route.Class (IsRoute (RouteModel, routePrism))-import Ema.Route.Prism (- checkRoutePrismGivenFilePath,- fromPrism_,- )-import Ema.Route.Url (urlToFilePath)-import Ema.Site (EmaSite (siteOutput), EmaStaticSite)-import NeatInterpolation (text)-import Network.HTTP.Types qualified as H+import Ema.Route.Class (IsRoute (RouteModel))+import Ema.Server.HTTP (httpApp)+import Ema.Server.WebSocket (wsApp)+import Ema.Server.WebSocket.Options (EmaWebSocketOptions (..))+import Ema.Site (EmaStaticSite) import Network.Wai qualified as Wai import Network.Wai.Handler.Warp (Port) import Network.Wai.Handler.Warp qualified as Warp import Network.Wai.Handler.WebSockets qualified as WaiWs-import Network.Wai.Middleware.Static qualified as Static-import Network.WebSockets (ConnectionException) import Network.WebSockets qualified as WS-import Optics.Core (review)-import Text.Printf (printf) import UnliftIO (MonadUnliftIO)-import UnliftIO.Async (race) import UnliftIO.Concurrent (threadDelay)-import UnliftIO.Exception (catch, try) runServerWithWebSocketHotReload :: forall r m.@@ -48,191 +29,41 @@ , IsRoute r , EmaStaticSite r ) =>+ Maybe (EmaWebSocketOptions r) -> Host -> Maybe Port -> LVar (RouteModel r) -> m ()-runServerWithWebSocketHotReload host mport model = do+runServerWithWebSocketHotReload mWsOpts host mport model = do logger <- askLoggerIO let runM = flip runLoggingT logger settings = Warp.defaultSettings & Warp.setHost (fromString . toString . unHost $ host) app =- WaiWs.websocketsOr- WS.defaultConnectionOptions- (wsApp logger)- (httpApp logger)+ case mWsOpts of+ Nothing ->+ httpApp @r logger model Nothing+ Just opts ->+ WaiWs.websocketsOr+ WS.defaultConnectionOptions+ (wsApp @r logger model $ emaWebSocketServerHandler opts)+ (httpApp @r logger model $ Just $ emaWebSocketClientShim opts) banner port = do logInfoNS "ema" "==============================================="- logInfoNS "ema" $ "Ema live server RUNNING: http://" <> unHost host <> ":" <> show port+ logInfoNS "ema" $ "Ema live server RUNNING: http://" <> unHost host <> ":" <> show port <> " (" <> maybe "no ws" (const "ws") mWsOpts <> ")" logInfoNS "ema" "===============================================" liftIO $ warpRunSettings settings mport (runM . banner) app- where- enc = routePrism @r- -- Like Warp.runSettings but takes *optional* port. When no port is set, a- -- free (random) port is used.- warpRunSettings :: Warp.Settings -> Maybe Port -> (Port -> IO a) -> Wai.Application -> IO ()- warpRunSettings settings mPort banner app = do- case mPort of- Nothing ->- Warp.withApplicationSettings settings (pure app) $ \port -> do- void $ banner port- threadDelay maxBound- Just port -> do- void $ banner port- Warp.runSettings (settings & Warp.setPort port) app- wsApp logger pendingConn = do- conn :: WS.Connection <- WS.acceptRequest pendingConn- WS.withPingThread conn 30 pass $- flip runLoggingT logger $ do- subId <- LVar.addListener model- let log lvl (s :: Text) =- logWithoutLoc (toText @String $ printf "ema.ws.%.2d" subId) lvl s- log LevelInfo "Connected"- let askClientForRoute = do- msg :: Text <- liftIO $ WS.receiveData conn- log LevelDebug $ "<~~ " <> show msg- pure msg- sendRouteHtmlToClient path s = do- decodeUrlRoute s path & \case- Left err -> do- log LevelError $ badRouteEncodingMsg err- liftIO $ WS.sendTextData conn $ emaErrorHtmlResponse $ badRouteEncodingMsg err- Right Nothing ->- liftIO $ WS.sendTextData conn $ emaErrorHtmlResponse decodeRouteNothingMsg- Right (Just r) -> do- renderCatchingErrors s r >>= \case- AssetGenerated Html html ->- liftIO $ WS.sendTextData conn $ html <> toLazy wsClientHtml- -- HACK: We expect the websocket client should check for REDIRECT prefix.- -- Not bothering with JSON response to avoid having to JSON parse every HTML dump.- AssetStatic _staticPath ->- liftIO $ WS.sendTextData conn $ "REDIRECT " <> toText (review (fromPrism_ $ enc s) r)- AssetGenerated Other _s ->- liftIO $ WS.sendTextData conn $ "REDIRECT " <> toText (review (fromPrism_ $ enc s) r)- log LevelDebug $ " ~~> " <> show r- -- @mWatchingRoute@ is the route currently being watched.- loop mWatchingRoute =- -- Listen *until* either we get a new value, or the client requests- -- to switch to a new route.- race (LVar.listenNext model subId) askClientForRoute >>= \case- Left newModel -> do- -- The page the user is currently viewing has changed. Send- -- the new HTML to them.- sendRouteHtmlToClient mWatchingRoute newModel- loop mWatchingRoute- 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 mNextRoute =<< LVar.get model- loop mNextRoute- -- Wait for the client to send the first request with the initial route.- mInitialRoute <- askClientForRoute- try (loop mInitialRoute) >>= \case- Right () -> pass- 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- httpApp logger req f = do- flip runLoggingT logger $ do- val <- LVar.get model- let pathInfo = Wai.pathInfo req- path = T.intercalate "/" pathInfo- mr = decodeUrlRoute val path- logInfoNS "ema.http" $ "GET " <> path <> " as " <> show mr- case mr of- Left err -> do- logErrorNS "App" $ badRouteEncodingMsg err- let s = emaErrorHtmlResponse (badRouteEncodingMsg err) <> wsClientJS- liftIO $ f $ Wai.responseLBS H.status500 [(H.hContentType, "text/html")] s- Right Nothing -> do- let s = emaErrorHtmlResponse decodeRouteNothingMsg <> wsClientJS- liftIO $ f $ Wai.responseLBS H.status404 [(H.hContentType, "text/html")] s- Right (Just r) -> do- renderCatchingErrors val r >>= \case- 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 <> toLazy wsClientHtml <> wsClientJS- liftIO $ f $ Wai.responseLBS H.status200 [(H.hContentType, "text/html")] s- AssetGenerated Other s -> do- let mimeType = Static.getMimeType $ review (fromPrism_ $ enc val) r- liftIO $ f $ Wai.responseLBS H.status200 [(H.hContentType, mimeType)] s- renderCatchingErrors m r =- catch (siteOutput (fromPrism_ $ enc m) m r) $ \(err :: SomeException) -> do- -- Log the error first.- logErrorNS "App" $ show @Text err- pure $- AssetGenerated Html . mkHtmlErrorMsg $- show @Text err- -- Decode an URL path into a route- --- -- This function is used only in live server. If the route is not- -- isomoprhic, this returns a Left, with the mismatched encoding.- decodeUrlRoute :: RouteModel r -> Text -> Either (BadRouteEncoding r) (Maybe r)- decodeUrlRoute m (urlToFilePath -> s) = do- case checkRoutePrismGivenFilePath enc m s of- Left (r, log) -> Left $ BadRouteEncoding s r log- Right mr -> Right mr --- | A basic error response for displaying in the browser-emaErrorHtmlResponse :: Text -> LByteString-emaErrorHtmlResponse err =- mkHtmlErrorMsg err <> toLazy wsClientHtml--mkHtmlErrorMsg :: Text -> LByteString-mkHtmlErrorMsg s =- encodeUtf8 . T.replace "MESSAGE" s . decodeUtf8 $ $(embedFile "www/ema-error.html")--decodeRouteNothingMsg :: Text-decodeRouteNothingMsg = "Ema: 404 (route decoding returned Nothing)"--data BadRouteEncoding r = BadRouteEncoding- { _bre_urlFilePath :: FilePath- , _bre_decodedRoute :: r- , _bre_checkLog :: [(FilePath, Text)]- }- deriving stock (Show)--badRouteEncodingMsg :: Show r => BadRouteEncoding r -> Text-badRouteEncodingMsg BadRouteEncoding {..} =- toText $- "A route Prism' is unlawful.\n\nThe URL '"- <> toText _bre_urlFilePath- <> "' decodes to route '"- <> show _bre_decodedRoute- <> "', but it is not isomporphic on any of the allowed candidates: \n\n"- <> T.intercalate- "\n\n"- ( _bre_checkLog <&> \(candidate, log) ->- "## Candidate '" <> toText candidate <> "':\n" <> log- )- <> " \n\nYou should make the relevant routePrism lawful to fix this issue."--wsClientHtml :: ByteString-wsClientHtml = $(embedFile "www/ema-indicator.html")--wsClientJSShim :: Text-wsClientJSShim = decodeUtf8 $(embedFile "www/ema-shim.js")---- Browser-side JavaScript code for interacting with the Haskell server-wsClientJS :: LByteString-wsClientJS =- encodeUtf8- [text|- <script type="module" src="https://cdn.jsdelivr.net/npm/morphdom@2.6.1/dist/morphdom-umd.min.js"></script>-- <script type="module">- ${wsClientJSShim}- - window.onpageshow = function () { init(false) };- </script>- |]+-- Like Warp.runSettings but takes *optional* port. When no port is set, a+-- free (random) port is used.+warpRunSettings :: Warp.Settings -> Maybe Port -> (Port -> IO a) -> Wai.Application -> IO ()+warpRunSettings settings mPort banner app = do+ case mPort of+ Nothing ->+ Warp.withApplicationSettings settings (pure app) $ \port -> do+ void $ banner port+ threadDelay maxBound+ Just port -> do+ void $ banner port+ Warp.runSettings (settings & Warp.setPort port) app
+ src/Ema/Server/Common.hs view
@@ -0,0 +1,98 @@+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TemplateHaskell #-}++module Ema.Server.Common where++import Control.Monad.Logger+import Data.FileEmbed+import Data.Text qualified as T+import Ema.Asset (+ Asset (AssetGenerated),+ Format (Html),+ )+import Ema.Route.Class (IsRoute (RouteModel, routePrism))+import Ema.Route.Prism (+ checkRoutePrismGivenFilePath,+ fromPrism_,+ )+import Ema.Route.Url (urlToFilePath)+import Ema.Site (EmaSite (siteOutput), EmaStaticSite)+import UnliftIO (MonadUnliftIO)+import UnliftIO.Exception (catch)++renderCatchingErrors ::+ forall r m.+ ( MonadLoggerIO m+ , MonadUnliftIO m+ , EmaStaticSite r+ ) =>+ RouteModel r ->+ r ->+ m (Asset LByteString)+renderCatchingErrors m r =+ catch (siteOutput (fromPrism_ $ routePrism m) m r) $ \(err :: SomeException) -> do+ -- Log the error first.+ logErrorNS "App" $ show @Text err+ pure+ $ AssetGenerated Html+ . mkHtmlErrorMsg+ $ show @Text err++-- Decode an URL path into a route+--+-- This function is used only in live server. If the route is not+-- isomoprhic, this returns a Left, with the mismatched encoding.+decodeUrlRoute ::+ forall r.+ (Eq r, Show r, IsRoute r) =>+ RouteModel r ->+ Text ->+ Either (BadRouteEncoding r) (Maybe r)+decodeUrlRoute m (urlToFilePath -> s) = do+ case checkRoutePrismGivenFilePath routePrism m s of+ Left (r, log) -> Left $ BadRouteEncoding s r log+ Right mr -> Right mr++-- | A basic error response for displaying in the browser+emaErrorHtmlResponse :: Text -> LByteString+emaErrorHtmlResponse err =+ mkHtmlErrorMsg err <> toLazy wsClientHtml++mkHtmlErrorMsg :: Text -> LByteString+mkHtmlErrorMsg s =+ encodeUtf8 . T.replace "MESSAGE" s . decodeUtf8 $ emaErrorHtml++decodeRouteNothingMsg :: Text+decodeRouteNothingMsg = "Ema: 404 (route decoding returned Nothing)"++data BadRouteEncoding r = BadRouteEncoding+ { _bre_urlFilePath :: FilePath+ , _bre_decodedRoute :: r+ , _bre_checkLog :: [(FilePath, Text)]+ }+ deriving stock (Show)++badRouteEncodingMsg :: (Show r) => BadRouteEncoding r -> Text+badRouteEncodingMsg BadRouteEncoding {..} =+ toText $+ "A route Prism' is unlawful.\n\nThe URL '"+ <> toText _bre_urlFilePath+ <> "' decodes to route '"+ <> show _bre_decodedRoute+ <> "', but it is not isomporphic on any of the allowed candidates: \n\n"+ <> T.intercalate+ "\n\n"+ ( _bre_checkLog <&> \(candidate, log) ->+ "## Candidate '" <> toText candidate <> "':\n" <> log+ )+ <> " \n\nYou should make the relevant routePrism lawful to fix this issue."++emaErrorHtml :: ByteString+emaErrorHtml = $(embedFile "www/ema-error.html")++wsClientHtml :: ByteString+wsClientHtml = $(embedFile "www/ema-indicator.html")++wsClientJSShim :: Text+wsClientJSShim = decodeUtf8 $(embedFile "www/ema-shim.js")
+ src/Ema/Server/HTTP.hs view
@@ -0,0 +1,58 @@+{-# LANGUAGE AllowAmbiguousTypes #-}++module Ema.Server.HTTP where++import Control.Monad.Logger+import Data.LVar (LVar)+import Data.LVar qualified as LVar+import Data.Maybe (fromMaybe)+import Data.Text qualified as T+import Ema.Asset (+ Asset (AssetGenerated, AssetStatic),+ Format (Html, Other),+ )+import Ema.Route.Class (IsRoute (RouteModel, routePrism))+import Ema.Route.Prism (+ fromPrism_,+ )+import Ema.Server.Common+import Ema.Site (EmaStaticSite)+import Network.HTTP.Types qualified as H+import Network.Wai qualified as Wai+import Network.Wai.Middleware.Static qualified as Static+import Optics.Core (review)++httpApp ::+ forall r.+ (Eq r, Show r, IsRoute r, EmaStaticSite r) =>+ (Loc -> LogSource -> LogLevel -> LogStr -> IO ()) ->+ LVar (RouteModel r) ->+ -- The shim to include in every HTML response+ Maybe LByteString ->+ Wai.Application+httpApp logger model mShim req f = flip runLoggingT logger $ do+ let shim = fromMaybe "" mShim+ val <- LVar.get model+ let pathInfo = Wai.pathInfo req+ path = T.intercalate "/" pathInfo+ mr = decodeUrlRoute @r val path+ logInfoNS "ema.http" $ "GET " <> path <> " as " <> show mr+ case mr of+ Left err -> do+ logErrorNS "App" $ badRouteEncodingMsg err+ let s = emaErrorHtmlResponse (badRouteEncodingMsg err) <> shim+ liftIO $ f $ Wai.responseLBS H.status500 [(H.hContentType, "text/html")] s+ Right Nothing -> do+ let s = emaErrorHtmlResponse decodeRouteNothingMsg <> shim+ liftIO $ f $ Wai.responseLBS H.status404 [(H.hContentType, "text/html")] s+ Right (Just r) -> do+ renderCatchingErrors val r >>= \case+ 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 <> toLazy wsClientHtml <> shim+ liftIO $ f $ Wai.responseLBS H.status200 [(H.hContentType, "text/html")] s+ AssetGenerated Other s -> do+ let mimeType = Static.getMimeType $ review (fromPrism_ $ routePrism val) r+ liftIO $ f $ Wai.responseLBS H.status200 [(H.hContentType, mimeType)] s
+ src/Ema/Server/WebSocket.hs view
@@ -0,0 +1,83 @@+module Ema.Server.WebSocket where++import Control.Monad.Logger+import Data.LVar (LVar)+import Data.LVar qualified as LVar+import Ema.Asset (+ Asset (AssetGenerated, AssetStatic),+ Format (Html, Other),+ )+import Ema.Route.Class (IsRoute (RouteModel, routePrism))+import Ema.Route.Prism (+ fromPrism_,+ )+import Ema.Server.Common+import Ema.Server.WebSocket.Options (EmaWsHandler (..))+import Ema.Site (EmaStaticSite)+import Network.WebSockets (ConnectionException)+import Network.WebSockets qualified as WS+import Optics.Core (review)+import UnliftIO.Async (race)+import UnliftIO.Exception (try)++wsApp ::+ forall r.+ (Eq r, Show r, IsRoute r, EmaStaticSite r) =>+ (Loc -> LogSource -> LogLevel -> LogStr -> IO ()) ->+ LVar (RouteModel r) ->+ EmaWsHandler r ->+ WS.PendingConnection ->+ IO ()+wsApp logger model emaWsHandler pendingConn = do+ conn :: WS.Connection <- WS.acceptRequest pendingConn+ WS.withPingThread conn 30 pass . flip runLoggingT logger $ do+ let log lvl (s :: Text) =+ logWithoutLoc "ema.ws" lvl s+ log LevelInfo "Connected"+ let wsHandler = unEmaWsHandler emaWsHandler conn+ sendRouteHtmlToClient path s = do+ decodeUrlRoute @r s path & \case+ Left err -> do+ log LevelError $ badRouteEncodingMsg err+ liftIO $ WS.sendTextData conn $ emaErrorHtmlResponse $ badRouteEncodingMsg err+ Right Nothing ->+ liftIO $ WS.sendTextData conn $ emaErrorHtmlResponse decodeRouteNothingMsg+ Right (Just r) -> do+ renderCatchingErrors s r >>= \case+ AssetGenerated Html html ->+ liftIO $ WS.sendTextData conn $ html <> toLazy wsClientHtml+ -- HACK: We expect the websocket client should check for REDIRECT prefix.+ -- Not bothering with JSON response to avoid having to JSON parse every HTML dump.+ AssetStatic _staticPath ->+ liftIO $ WS.sendTextData conn $ "REDIRECT " <> toText (review (fromPrism_ $ routePrism s) r)+ AssetGenerated Other _s ->+ liftIO $ WS.sendTextData conn $ "REDIRECT " <> toText (review (fromPrism_ $ routePrism s) r)+ log LevelDebug $ " ~~> " <> show r+ -- @mWatchingRoute@ is the route currently being watched.+ loop mWatchingRoute = do+ -- Listen *until* either we get a new value, or the client requests+ -- to switch to a new route.+ currentModel <- LVar.get model+ race (LVar.listenNext model) (wsHandler currentModel) >>= \case+ Left newModel -> do+ -- The page the user is currently viewing has changed. Send+ -- the new HTML to them.+ sendRouteHtmlToClient mWatchingRoute newModel+ loop mWatchingRoute+ 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 mNextRoute =<< LVar.get model+ loop mNextRoute+ -- Wait for the client to send the first request with the initial route.+ mInitialRoute <- wsHandler =<< LVar.get model+ try (loop mInitialRoute) >>= \case+ Right () -> pass+ Left (connExc :: ConnectionException) -> do+ case connExc of+ WS.CloseRequest _ (decodeUtf8 -> reason) ->+ log LevelInfo $ "Closing websocket connection (reason: " <> reason <> ")"+ _ ->+ log LevelError $ "Websocket error: " <> show connExc
+ src/Ema/Server/WebSocket/Options.hs view
@@ -0,0 +1,60 @@+{-# LANGUAGE QuasiQuotes #-}++module Ema.Server.WebSocket.Options where++import Control.Monad.Logger (+ LogLevel (LevelDebug),+ LoggingT,+ logWithoutLoc,+ )+import Data.Default (Default (def))+import Ema.Route.Class (IsRoute (RouteModel))+import Ema.Server.Common (wsClientJSShim)+import NeatInterpolation (text)+import Network.WebSockets qualified as WS++{- | A handler takes a websocket connection and the current model and then watches+ for websocket messages. It must return a new route to watch (after that, the+ returned route's HTML will be sent back to the client).++ Note that this is usually a long-running thread that waits for the client's+ messages. But you can also use it to implement custom server actions, by handling+ the incoming websocket messages or other IO events in any way you like.++ Also note that whenever the model is updated, the handler action will be+ stopped and then restarted with the new model as argument.+-}+newtype EmaWsHandler r = EmaWsHandler+ { unEmaWsHandler :: WS.Connection -> RouteModel r -> LoggingT IO Text+ }++instance Default (EmaWsHandler r) where+ def = EmaWsHandler $ \conn _model -> do+ msg :: Text <- liftIO $ WS.receiveData conn+ log LevelDebug $ "<~~ " <> show msg+ pure msg+ where+ log lvl (t :: Text) = logWithoutLoc "ema.ws" lvl t++data EmaWebSocketOptions r = EmaWebSocketOptions+ { emaWebSocketClientShim :: LByteString+ , emaWebSocketServerHandler :: EmaWsHandler r+ }++instance Default (EmaWebSocketOptions r) where+ def =+ EmaWebSocketOptions wsClientJS def++-- Browser-side JavaScript code for interacting with the Haskell server+wsClientJS :: LByteString+wsClientJS =+ encodeUtf8+ [text|+ <script src="https://unpkg.com/idiomorph@0.4.0"></script>++ <script type="module">+ ${wsClientJSShim}+ + window.onpageshow = function () { init(false) };+ </script>+ |]
src/Ema/Site.hs view
@@ -6,7 +6,6 @@ ) where import Control.Monad.Logger (MonadLoggerIO)-import Data.Some (Some) import Ema.Asset (Asset) import Ema.CLI qualified as CLI import Ema.Dynamic (Dynamic)@@ -33,7 +32,7 @@ Finally, `Ema.App.runSite @r arg` (where `arg` is of type `SiteArg`) is run from the `main` entry point to run your Ema site. -}-class IsRoute r => EmaSite r where+class (IsRoute r) => EmaSite r where -- | `SiteArg` is typically settings from the environment (config file, or -- command-line arguments) that your Dynamic-producing `siteInput` function -- consumes as argument.@@ -54,7 +53,7 @@ siteInput :: forall m. (MonadIO m, MonadUnliftIO m, MonadLoggerIO m) =>- Some CLI.Action ->+ CLI.Action -> -- | The value passed by the programmer to `Ema.App.runSite` SiteArg r -> -- | Time-varying value of the model. If your model is not time-varying, use
www/ema-shim.js view
@@ -1,57 +1,55 @@-function htmlToElem(html) {- let temp = document.createElement('template');- html = html.trim(); // Never return a space text node as a result- temp.innerHTML = html;- return temp.content.firstChild;-};- // Unlike setInnerHtml, this patches the Dom in place function setHtml(elm, html) {- var htmlElem = htmlToElem(html);- window.dispatchEvent(new Event('EMABeforeMorphDOM'));- morphdom(elm, html);- window.dispatchEvent(new Event('EMABeforeScriptReload'));- // Re-add <script> tags, because just DOM diff applying is not enough.- reloadScripts(elm);- window.dispatchEvent(new Event('EMAHotReload'));-};+ window.dispatchEvent(new Event("EMABeforeMorphDOM"));+ Idiomorph.morph(elm, html);+ window.dispatchEvent(new Event("EMABeforeScriptReload"));+ // Re-add <script> tags, because just DOM diff applying is not enough.+ reloadScripts(elm);+ window.dispatchEvent(new Event("EMAHotReload"));+} // 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");- Array.from(oldScript.attributes)- .forEach(attr => newScript.setAttribute(attr.name, attr.value));- newScript.appendChild(document.createTextNode(oldScript.innerHTML));- oldScript.parentNode.replaceChild(newScript, oldScript);- });-};+ Array.from(elm.querySelectorAll("script")).forEach((oldScript) => {+ // Some scripts, like Tailwind, should not be reloaded (they are not idempotent)+ // Allow the user to skip such scripts with a data-* attribute+ if (oldScript.getAttribute("data-ema-skip") === "true") {+ return;+ }+ const newScript = document.createElement("script");+ Array.from(oldScript.attributes).forEach((attr) =>+ newScript.setAttribute(attr.name, attr.value),+ );+ newScript.appendChild(document.createTextNode(oldScript.innerHTML));+ oldScript.parentNode.replaceChild(newScript, oldScript);+ });+} // Ema Status indicator const messages = {- connected: "Connected",- reloading: "Reloading",- connecting: "Connecting to the server",- disconnected: "Disconnected - try reloading the window"+ connected: "Connected",+ reloading: "Reloading",+ connecting: "Connecting to the server",+ disconnected: "Disconnected - try reloading the window", }; function setIndicators(connected, reloading, connecting, disconnected) {- const is = { connected, reloading, connecting, disconnected }+ const is = { connected, reloading, connecting, disconnected }; - for (const i in is) {- document.getElementById(`ema-${i}`).style.display =- is[i] ? "block" : "none"- if (is[i])- document.getElementById('ema-message').innerText = messages[i]- };- document.getElementById("ema-indicator").style.display = "block";-};-window.connected = () => setIndicators(true, false, false, false)-window.reloading = () => setIndicators(false, true, false, false)-window.connecting = () => setIndicators(false, false, true, false)-window.disconnected = () => setIndicators(false, false, false, true)+ for (const i in is) {+ document.getElementById(`ema-${i}`).style.display = is[i]+ ? "block"+ : "none";+ if (is[i]) document.getElementById("ema-message").innerText = messages[i];+ }+ document.getElementById("ema-indicator").style.display = "block";+}+window.connected = () => setIndicators(true, false, false, false);+window.reloading = () => setIndicators(false, true, false, false);+window.connecting = () => setIndicators(false, false, true, false);+window.disconnected = () => setIndicators(false, false, false, true); window.hideIndicator = () => {- document.getElementById("ema-indicator").style.display = "none";+ document.getElementById("ema-indicator").style.display = "none"; }; // Base URL path - for when the ema site isn't served at "/"@@ -64,122 +62,144 @@ // WebSocket logic: watching for server changes & route switching function init(reconnecting) {- // The route current DOM is displaying- let routeVisible = document.location.pathname;+ // The route current DOM is displaying+ let routeVisible = document.location.pathname; - const verb = reconnecting ? "Reopening" : "Opening";- console.log(`ema: ${verb} conn ${wsUrl} ...`);- window.connecting();- let ws = new WebSocket(wsUrl);+ const verb = reconnecting ? "Reopening" : "Opening";+ console.log(`ema: ${verb} conn ${wsUrl} ...`);+ window.connecting();+ let ws = new WebSocket(wsUrl); - function sendObservePath(path) {- const relPath = path.startsWith(basePath) ? path.slice(basePath.length) : path;- console.debug(`ema: requesting ${relPath}`);- ws.send(relPath);- }+ function sendObservePath(path) {+ const relPath = path.startsWith(basePath)+ ? path.slice(basePath.length)+ : 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}`);- sendObservePath(document.location.pathname);- };+ // 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}`);+ sendObservePath(document.location.pathname);+ } - function switchRoute(path, hash = "") {- console.log(`ema: → Switching to ${path + hash}`);- window.history.pushState({}, "", path + hash);- sendObservePath(path);+ function switchRoute(path, hash = "") {+ console.log(`ema: → Switching to ${path + hash}`);+ window.history.pushState({}, "", path + hash);+ sendObservePath(path);+ }++ function scrollToAnchor(hash) {+ console.log(`ema: Scroll to ${hash}`);+ var el = document.querySelector(hash);+ if (el !== null) {+ el.scrollIntoView({ behavior: "smooth" }); }+ } - function scrollToAnchor(hash) {- console.log(`ema: Scroll to ${hash}`)- var el = document.querySelector(hash);- if (el !== null) {- el.scrollIntoView({ behavior: 'smooth' });- }- };+ function getAnchorIfOnPage(linkElement) {+ const url = new URL(linkElement.href); // Use URL API for parsing+ return url.host === window.location.host &&+ url.pathname === window.location.pathname &&+ url.hash+ ? url.hash.slice(1) // Return anchor name (slice off '#')+ : null; // Not an anchor on the current page+ } - function handleRouteClicks(e) {- const origin = e.target.closest("a");- if (origin) {- if (window.location.host === origin.host && origin.getAttribute("target") != "_blank") {- if (origin.getAttribute("href").startsWith("#")) {- // Switching to local anchor- window.history.pushState({}, "", window.location.pathname + origin.hash);- scrollToAnchor(window.location.hash);- e.preventDefault();- } else {- // Switching to another route- switchRoute(origin.pathname, origin.hash);- e.preventDefault();- }- };+ function handleRouteClicks(e) {+ const origin = e.target.closest("a");+ if (origin) {+ if (+ window.location.host === origin.host &&+ origin.getAttribute("target") != "_blank"+ ) {+ let anchor = getAnchorIfOnPage(origin);+ if (anchor !== null) {+ // Switching to local anchor+ window.history.pushState({}, "", origin.href);+ scrollToAnchor(window.location.hash);+ e.preventDefault();+ } else {+ // Switching to another route+ switchRoute(origin.pathname, origin.hash);+ e.preventDefault(); }- };- // Intercept route click events, and ask server for its HTML whilst- // managing history state.- 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();- };-- ws.onclose = () => {- console.log("ema: reconnecting ..");- window.removeEventListener(`click`, handleRouteClicks);- window.reloading();- // Reconnect after as small a time is possible, then retry again. - // ghcid can take 1s or more to reboot. So ideally we need an- // exponential retry logic.- // - // Note that a slow delay (200ms) may often cause websocket- // 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(function () { init(true); }, 400);- };+ }+ }+ }+ // Intercept route click events, and ask server for its HTML whilst+ // managing history state.+ 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();+ }; + ws.onclose = () => {+ console.log("ema: reconnecting ..");+ window.removeEventListener(`click`, handleRouteClicks);+ window.reloading();+ // Reconnect after as small a time is possible, then retry again.+ // ghcid can take 1s or more to reboot. So ideally we need an+ // exponential retry logic.+ //+ // Note that a slow delay (200ms) may often cause websocket+ // 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(function () {+ init(true);+ }, 400);+ }; - ws.onmessage = evt => {- 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;- }- if (window.location.hash) {- scrollToAnchor(window.location.hash);- }- };- };- window.onbeforeunload = evt => { ws.close(); };- window.onpagehide = evt => { ws.close(); };+ ws.onmessage = (evt) => {+ if (evt.data.startsWith("REDIRECT ")) {+ console.log("ema: redirect");+ document.location.href = evt.data.slice("REDIRECT ".length);+ } else if (evt.data.startsWith("SWITCH ")) {+ console.log("ema: switch");+ switchRoute(evt.data.slice("SWITCH ".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;+ }+ if (window.location.hash) {+ scrollToAnchor(window.location.hash);+ }+ }+ };+ window.onbeforeunload = (evt) => {+ ws.close();+ };+ window.onpagehide = (evt) => {+ ws.close();+ }; - // When the user clicks the back button, resume watching the URL in- // the addressback, which has the effect of loading it immediately.- window.onpopstate = function (e) {- watchCurrentRoute();- };+ // When the user clicks the back button, resume watching the URL in+ // the addressback, which has the effect of loading it immediately.+ window.onpopstate = function (e) {+ watchCurrentRoute();+ }; - // API for user invocations - window.ema = {- switchRoute: switchRoute- };-};+ // API for user invocations+ window.ema = {+ switchRoute: switchRoute,+ };+}