diff --git a/CHANGELOG.md b/CHANGELOG.md
--- a/CHANGELOG.md
+++ b/CHANGELOG.md
@@ -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 `
-
-
- |]
+-- 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
diff --git a/src/Ema/Server/Common.hs b/src/Ema/Server/Common.hs
new file mode 100644
--- /dev/null
+++ b/src/Ema/Server/Common.hs
@@ -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")
diff --git a/src/Ema/Server/HTTP.hs b/src/Ema/Server/HTTP.hs
new file mode 100644
--- /dev/null
+++ b/src/Ema/Server/HTTP.hs
@@ -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
diff --git a/src/Ema/Server/WebSocket.hs b/src/Ema/Server/WebSocket.hs
new file mode 100644
--- /dev/null
+++ b/src/Ema/Server/WebSocket.hs
@@ -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
diff --git a/src/Ema/Server/WebSocket/Options.hs b/src/Ema/Server/WebSocket/Options.hs
new file mode 100644
--- /dev/null
+++ b/src/Ema/Server/WebSocket/Options.hs
@@ -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|
+
+
+
+ |]
diff --git a/src/Ema/Site.hs b/src/Ema/Site.hs
--- a/src/Ema/Site.hs
+++ b/src/Ema/Site.hs
@@ -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
diff --git a/www/ema-shim.js b/www/ema-shim.js
--- a/www/ema-shim.js
+++ b/www/ema-shim.js
@@ -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