-- PVP: +-+------- breaking API changes
-- | | +----- non-breaking API additions
-- | | | +--- code changes with no API change
-version: 0.0.0.20221117
+version: 0.0.0.20240908
stability: experimental
category: Web
synopsis: Haskell-website compiler
description:
- Exploring the design space of compile-time website generator
+ Exploring the design space of static, live and dynamic website generators
by using a domain-specific language (DSL)
embedded into the Haskell language.
.
* <https://hackage.haskell.org/package/ema ema>
build-type: Simple
-tested-with: GHC ==9.2.4
+tested-with: GHC ==9.6.7
extra-doc-files: ChangeLog.md
extra-source-files:
.envrc
cabal.project
flake.lock
flake.nix
+ www/live-error.html
+ www/live-indicator.html
+ www/live-shim.js
extra-tmp-files:
type: git
location: git://git.sourcephile.fr/haskell/literate-web.git
-common boilerplate
+common haskell-variant
default-language: Haskell2010
default-extensions:
BlockArguments
DataKinds
DefaultSignatures
DeriveDataTypeable
+ DeriveFunctor
DeriveGeneric
DerivingVia
FlexibleContexts
TypeApplications
TypeFamilies
TypeOperators
+ ViewPatterns
ghc-options:
-Wall -Wincomplete-record-updates -Wincomplete-uni-patterns
-Wmonomorphism-restriction -Wpartial-fields
-fprint-potential-instances
--- -dshow-passes
--- -ddump-to-file
--- -ddump-simpl
--- -dsuppress-coercions
--- -dsuppress-module-prefixes
--- -dsuppress-type-applications
--- -O0
--- -fmax-simplifier-iterations=0
-
common library-deps
build-depends:
, async >=2.2
, bytestring >=0.10
, containers >=0.5
, directory >=1.3
+ , file-embed
, filepath >=1.4
, filepattern >=0.1
, ghc-prim
, hashable
, http-client >=0.6
, http-media >=0.7
+ , http-types
, monad-classes
, peano
- , reflection
+ , stm
, symantic-base >=0.5
, template-haskell
, text
, warp
, websockets >=0.12
+-- , reflection
-- , mvc
-- , mvc-updates
-- , pipes
-- , pipes-group
-- , pipes-parse
-- , pipes-safe
+
library
- import: boilerplate, library-deps
+ import: haskell-variant, library-deps
hs-source-dirs: src
exposed-modules:
Literate.Web
+ Literate.Web.Live
+ Literate.Web.Live.Asset
+ Literate.Web.Live.Common
+ Literate.Web.Live.HTTP
+ Literate.Web.Live.WebSocket
Literate.Web.Semantics.Addresser
Literate.Web.Semantics.Compiler
Literate.Web.Syntaxes
--Literate.Web.MIME
-- library relactive
--- import: boilerplate, library-deps
+-- import: haskell-variant, library-deps
-- hs-source-dirs: src
-- build-depends:
-- , async
test-suite literate-web-tests
-- library-deps is only to have ghcid reloaded on changes in src
- import: boilerplate, library-deps
+ import: haskell-variant, library-deps
type: exitcode-stdio-1.0
hs-source-dirs: tests
main-is: Main.hs
-- , relude >=1 && <2
-- benchmark time
--- import: boilerplate, library-deps
+-- import: haskell-variant, library-deps
-- type: exitcode-stdio-1.0
-- hs-source-dirs: benchmarks/time
-- main-is: Main.hs
-- ghc-options: -with-rtsopts=-A32m
--
-- benchmark weigh
--- import: boilerplate, library-deps
+-- import: haskell-variant, library-deps
-- type: exitcode-stdio-1.0
-- hs-source-dirs: benchmarks/weigh src
-- build-depends:
-- , weigh
--
-- executable async
--- import: boilerplate, library-deps
+-- import: haskell-variant, library-deps
-- hs-source-dirs: executables/async
-- main-is: Main.hs
-- build-depends:
-- -- , relude >= 1
--
-- executable fsnotify
--- import: boilerplate, library-deps
+-- import: haskell-variant, library-deps
-- hs-source-dirs: executables/fsnotify
-- main-is: Main.hs
-- build-depends:
--- /dev/null
+{-# LANGUAGE NoRebindableSyntax #-}
+
+module Literate.Web.Live where
+
+import Control.Applicative (Applicative (..))
+import Control.Concurrent (threadDelay)
+import Control.Concurrent.STM (STM)
+import Control.Concurrent.STM qualified as STM
+import Control.Monad (void)
+import Control.Monad.Classes qualified as MC
+import Data.ByteString.Lazy qualified as BSL
+import Data.Function (const, ($), (&))
+import Data.Map.Strict qualified as Map
+import Data.Maybe (Maybe (..), maybe)
+import Data.Monoid (Monoid (..))
+import Data.Text.Lazy qualified as TextL
+import Data.Text.Lazy.IO qualified as TextL
+import Network.Wai qualified as Wai
+import Network.Wai.Handler.Warp qualified as Warp
+import Network.Wai.Handler.WebSockets qualified as WaiWs
+import Network.WebSockets qualified as WS
+import System.IO (IO)
+import System.IO qualified as Sys
+import Text.Show (Show (..))
+import Prelude (Bounded (..))
+
+import Literate.Web qualified as Web
+import Literate.Web.Live.HTTP
+import Literate.Web.Live.WebSocket
+
+runLive ::
+ m ~ IO =>
+ MC.MonadExec IO m =>
+ Maybe () ->
+ Warp.HostPreference ->
+ Maybe Warp.Port ->
+ STM model ->
+ (model -> m (Map.Map Web.OutputPath (IO BSL.ByteString))) ->
+ m ()
+runLive mWsOpts host portMaybe modelSTM siteMap = do
+ iniModel <- MC.exec @IO $ STM.atomically modelSTM
+ let
+ settings =
+ Warp.defaultSettings
+ & Warp.setHost host
+ app = case mWsOpts of
+ Nothing -> httpApp modelSTM siteMap Nothing
+ Just () -> do
+ WaiWs.websocketsOr
+ WS.defaultConnectionOptions
+ (webSocketApp iniModel modelSTM siteMap)
+ (httpApp modelSTM siteMap (Just webSocketClientJS))
+ banner port = do
+ TextL.hPutStrLn Sys.stderr $
+ TextL.unlines
+ [ "==============================================="
+ , mconcat
+ [ "Live server RUNNING: http://"
+ , TextL.pack (show host)
+ , ":"
+ , TextL.pack (show port)
+ , " ("
+ , maybe "no ws" (const "ws") mWsOpts
+ , ")"
+ ]
+ , "==============================================="
+ ]
+ MC.exec @IO $ warpRunSettings settings portMaybe banner app
+
+-- Like Warp.runSettings but takes *optional* port. When no port is set,
+-- a free (random) port is used.
+warpRunSettings :: Warp.Settings -> Maybe Warp.Port -> (Warp.Port -> IO a) -> Wai.Application -> IO ()
+warpRunSettings settings portMaybe banner app = do
+ case portMaybe of
+ Nothing ->
+ Warp.withApplicationSettings settings (pure app) $ \port -> do
+ void $ banner port
+ threadDelay maxBound
+ Just port -> do
+ void $ banner port
+ Warp.runSettings (Warp.setPort port settings) app
--- /dev/null
+module Literate.Web.Live.Asset where
+
+import Data.Eq (Eq (..))
+import Data.Function ((.))
+import Data.Functor (Functor, (<$>))
+import Data.Ord (Ord)
+import Data.Text (Text)
+import Data.Text qualified as Text
+import GHC.Generics (Generic)
+import Literate.Web qualified as Web
+import System.FilePath qualified as File
+import System.IO (FilePath)
+import Text.Show (Show)
+
+-- | 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 stock (Eq, Show, Ord, Functor, Generic)
+
+-- | The format of a generated asset.
+data Format
+ = -- | Html assets are served by the live server with hot-reload
+ Html
+ | -- | Other assets are served by the live server as static files.
+ Other
+ deriving stock (Eq, Show, Ord, Generic)
+
+decodeOutputPath :: Text -> Web.OutputPath
+decodeOutputPath p =
+ Web.OutputPath
+ { Web.outputPathSegs = Web.decodePathSegment . Text.pack <$> File.splitDirectories segs
+ , Web.outputPathExts = Web.decodePathSegment <$> Text.split (== '.') (Text.pack case exts of '.' : e -> e; _ -> exts)
+ }
+ where
+ (segs, exts) = File.splitExtensions (Text.unpack p)
--- /dev/null
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE TemplateHaskell #-}
+
+module Literate.Web.Live.Common where
+
+import Data.ByteString qualified as BS
+import Data.ByteString.Lazy qualified as BSL
+import Data.FileEmbed
+import Data.Function (($), (.))
+import Data.Functor ((<$>))
+import Data.Semigroup (Semigroup (..))
+import Data.Text (Text)
+import Data.Text qualified as Text
+import Data.Text.Encoding qualified as Text
+import Data.Text.Lazy qualified as TextL
+import Data.Text.Lazy.Encoding qualified as TextL
+import System.IO qualified as Sys
+
+import Literate.Web qualified as Web
+import Text.Show (Show)
+
+{-
+renderCatchingErrors ::
+ forall r m.
+ ( MonadLoggerIO m
+ , MonadUnliftIO m
+ , EmaStaticSite r
+ ) =>
+ RouteModel r ->
+ r ->
+ m (Asset BSL.ByteString)
+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
+liveErrorHtmlResponse :: Text -> BSL.ByteString
+liveErrorHtmlResponse err = mkHtmlErrorMsg err <> BSL.fromStrict wsClientHtml
+
+urlToFilePath :: Text -> Sys.FilePath
+urlToFilePath = Text.unpack . Text.intercalate "/" . (Web.encodePathSegment . Web.decodePathSegment <$>) . Text.splitOn "/"
+
+mkHtmlErrorMsg :: Text -> BSL.ByteString
+mkHtmlErrorMsg s = TextL.encodeUtf8 $ TextL.replace "MESSAGE" (TextL.fromStrict s) $ TextL.fromStrict $ Text.decodeUtf8 $ emaErrorHtml
+
+emaErrorHtml :: BS.ByteString
+emaErrorHtml = $(embedFile "www/live-error.html")
+
+decodeRouteNothingMsg :: Text
+decodeRouteNothingMsg = "Literate.Web.Live: 404 (route decoding returned Nothing)"
+
+data BadRouteEncoding r = BadRouteEncoding
+ { _bre_urlFilePath :: Sys.FilePath
+ , _bre_decodedRoute :: r
+ , _bre_checkLog :: [(Sys.FilePath, Text)]
+ }
+ deriving stock (Show)
+
+wsClientHtml :: BS.ByteString
+wsClientHtml = $(embedFile "www/live-indicator.html")
+
+{-
+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"
+ <> Text.intercalate
+ "\n\n"
+ ( _bre_checkLog <&> \(candidate, log) ->
+ "## Candidate '" <> toText candidate <> "':\n" <> log
+ )
+ <> " \n\nYou should make the relevant routePrism lawful to fix this issue."
+-}
--- /dev/null
+{-# LANGUAGE NoRebindableSyntax #-}
+{-# OPTIONS_GHC -Wno-type-defaults #-}
+
+module Literate.Web.Live.HTTP where
+
+-- import Network.Wai.Middleware.Static qualified as Static
+import Control.Concurrent.STM (STM)
+import Control.Concurrent.STM qualified as STM
+import Control.Monad.Classes qualified as MC
+import Data.ByteString.Lazy qualified as BSL
+import Data.Function (($))
+import Data.Map.Strict qualified as Map
+import Data.Maybe (Maybe (..), fromMaybe)
+import Data.Semigroup (Semigroup (..))
+import Data.Text qualified as Text
+import Data.Text.Lazy qualified as TextL
+import Data.Text.Lazy.IO qualified as TextL
+import Literate.Web qualified as Web
+import Network.HTTP.Types qualified as H
+import Network.Wai qualified as Wai
+import System.IO (IO)
+import System.IO qualified as Sys
+
+import Literate.Web.Live.Asset
+import Literate.Web.Live.Common
+
+httpApp ::
+ m ~ IO =>
+ STM model ->
+ (model -> m (Map.Map Web.OutputPath (m BSL.ByteString))) ->
+ -- The shim to include in every HTML response
+ Maybe BSL.ByteString ->
+ Wai.Application
+httpApp modelSTM siteMap mShim req res = do
+ let shim = fromMaybe "" mShim
+ let path = Text.intercalate "/" $ Wai.pathInfo req
+ model <- STM.atomically modelSTM
+ TextL.hPutStrLn Sys.stderr $ "httpApp: GET " <> TextL.fromStrict path
+ site <- siteMap model
+ Sys.hPrint
+ Sys.stderr
+ ( ["httpApp"] :: [TextL.Text]
+ , ("path", decodeOutputPath path)
+ , ("site" :: TextL.Text, (Map.keys site))
+ )
+ case Map.lookup (decodeOutputPath path) site of
+ Nothing -> do
+ let s = liveErrorHtmlResponse decodeRouteNothingMsg <> shim
+ res $ Wai.responseLBS H.status404 [(H.hContentType, "text/html")] s
+ Just contentIO -> do
+ content <- MC.exec @IO contentIO
+ res $ Wai.responseLBS H.status200 [(H.hContentType, "text/html")] content
+
+{-
+case mr of
+ Left err -> do
+ logErrorNS "App" $ badRouteEncodingMsg err
+ let s = liveErrorHtmlResponse (badRouteEncodingMsg err) <> shim
+ liftIO $ res $ Wai.responseLBS H.status500 [(H.hContentType, "text/html")] s
+ Right Nothing -> do
+ let s = liveErrorHtmlResponse decodeRouteNothingMsg <> shim
+ liftIO $ res $ 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 $ res $ Wai.responseFile H.status200 [(H.hContentType, mimeType)] staticPath Nothing
+ AssetGenerated Html html -> do
+ let s = html <> toLazy wsClientHtml <> shim
+ liftIO $ res $ Wai.responseLBS H.status200 [(H.hContentType, "text/html")] s
+ AssetGenerated Other s -> do
+ let mimeType = Static.getMimeType $ review (fromPrism_ $ routePrism val) r
+ liftIO $ res $ Wai.responseLBS H.status200 [(H.hContentType, mimeType)] s
+-}
--- /dev/null
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE NoRebindableSyntax #-}
+
+module Literate.Web.Live.WebSocket where
+
+import Control.Applicative (Alternative (..), Applicative (..))
+import Control.Concurrent.Async qualified as Async
+import Control.Concurrent.STM (STM)
+import Control.Concurrent.STM qualified as STM
+import Control.Exception qualified as Exception
+import Control.Monad (Monad (..))
+import Control.Monad.Classes qualified as MC
+import Data.ByteString.Lazy qualified as BSL
+import Data.Either (Either (..))
+import Data.FileEmbed (embedFile)
+import Data.Function (($))
+import Data.Functor ((<$>))
+import Data.Map.Strict qualified as Map
+import Data.Maybe (Maybe (..))
+import Data.Monoid (mconcat)
+import Data.Semigroup (Semigroup (..))
+import Data.Text (Text)
+import Data.Text.Lazy qualified as TextL
+import Data.Text.Lazy.Encoding qualified as TextL
+import Data.Text.Lazy.IO qualified as TextL
+import Network.WebSockets (ConnectionException)
+import Network.WebSockets qualified as WS
+import System.IO (IO)
+import System.IO qualified as Sys
+import Text.Show (show)
+
+import Literate.Web qualified as Web
+import Literate.Web.Live.Asset
+import Literate.Web.Live.Common
+
+webSocketApp ::
+ m ~ IO =>
+ model ->
+ STM model ->
+ (model -> m (Map.Map Web.OutputPath (m BSL.ByteString))) ->
+ WS.ServerApp
+webSocketApp iniModel modelSTM siteMap pendingConn =
+ withWebSocket pendingConn $ \(routeSTM, routeSend) -> do
+ let loop model route = do
+ STM.atomically (Left <$> modelSTM <|> Right <$> routeSTM) >>= \case
+ Left newModel -> loop newModel route
+ Right newRoute -> loop model newRoute
+ site <- siteMap model
+ TextL.hPutStrLn Sys.stderr $ "webSocketApp: route: " <> TextL.pack (show route)
+ case Map.lookup route site of
+ Nothing -> MC.exec @IO $ routeSend [WS.Binary (liveErrorHtmlResponse decodeRouteNothingMsg)]
+ Just contentIO -> do
+ content <- MC.exec @IO contentIO
+ MC.exec @IO $ routeSend [WS.Binary content]
+ loop
+ iniModel
+ Web.OutputPath
+ { Web.outputPathSegs = ["index"]
+ , Web.outputPathExts = ["html"]
+ }
+
+withWebSocket ::
+ WS.PendingConnection ->
+ ((STM Web.OutputPath, [WS.DataMessage] -> IO ()) -> IO ()) ->
+ IO ()
+withWebSocket pendingConn f = do
+ var <- STM.newEmptyTMVarIO
+ conn :: WS.Connection <- WS.acceptRequest pendingConn
+ WS.withPingThread conn 30 (pure ()) $
+ Async.withAsync
+ ( let loop =
+ Exception.try @ConnectionException (WS.receiveData @Text conn) >>= \case
+ Left (WS.CloseRequest _ (TextL.decodeUtf8 -> reason)) -> do
+ TextL.hPutStrLn Sys.stderr $ "WebSocket.CloseRequest, reason: " <> reason
+ Left WS.ConnectionClosed -> do
+ Sys.hPrint Sys.stderr (["withWebSocket", "loop", "ConnectionClosed"] :: [Text])
+ Left WS.ParseException{} -> do
+ TextL.hPutStrLn Sys.stderr $ "WebSocket.ParseException"
+ Left WS.UnicodeException{} -> do
+ TextL.hPutStrLn Sys.stderr $ "WebSocket.UnicodeException"
+ Right msg -> do
+ STM.atomically $ STM.writeTMVar var $ decodeOutputPath msg
+ loop
+ in loop
+ )
+ Async.wait
+ Exception.try @ConnectionException
+ (f (STM.readTMVar var, WS.sendDataMessages conn))
+ >>= \case
+ Left (WS.CloseRequest _ (TextL.decodeUtf8 -> reason)) -> do
+ TextL.hPutStrLn Sys.stderr $ "WebSocket.CloseRequest, reason: " <> reason
+ Left WS.ConnectionClosed -> do
+ Sys.hPrint Sys.stderr (["withWebSocket", "f", "ConnectionClosed"] :: [Text])
+ Left WS.ParseException{} -> do
+ TextL.hPutStrLn Sys.stderr $ "WebSocket.ParseException"
+ Left WS.UnicodeException{} -> do
+ TextL.hPutStrLn Sys.stderr $ "WebSocket.UnicodeException"
+ Right () -> WS.sendClose conn ("Bye!" :: Text)
+
+-- case connExc of
+-- WS.CloseRequest _ (Text.decodeUtf8 -> reason) ->
+-- log LevelInfo $ "Closing websocket connection (reason: " <> reason <> ")"
+-- _ ->
+-- log LevelError $ "Websocket error: " <> show connExc
+-- LVar.removeListener model subId
+
+-- | 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 WebSocketHandler model = WebSocketHandler
+ { unWebSocketHandler :: WS.Connection {-RO IO-} -> model -> IO Text
+ }
+
+webSocketHandler :: WebSocketHandler model
+webSocketHandler = WebSocketHandler $ \conn _model -> do
+ msg :: Text <- MC.exec @IO $ WS.receiveData conn
+ -- log LevelDebug $ "<~~ " <> show msg
+ pure msg
+
+-- where log lvl (t :: Text) = logWithoutLoc "ema.ws" lvl t
+
+-- Browser-side JavaScript code for interacting with the Haskell server
+webSocketClientJS :: BSL.ByteString
+webSocketClientJS =
+ mconcat
+ [ TextL.encodeUtf8
+ ( mconcat
+ [ "<script type='module' src='https://cdn.jsdelivr.net/npm/morphdom@2.7.2/dist/morphdom-umd.min.js'></script>"
+ , "<script type='module'>"
+ ]
+ )
+ , BSL.fromStrict $(embedFile "www/live-shim.js")
+ , TextL.encodeUtf8
+ ( mconcat
+ [ "window.onpageshow = function () { init(false) };"
+ , "</script>"
+ ]
+ )
+ ]
+
+-- instance WS.WebSocketsData Web.OutputPath where
+
+{-
+ --subId <- LVar.addListener model
+ -- let log lvl (s :: Text) = logWithoutLoc (toText @String $ printf "ema.ws.%.2d" subId) lvl s
+ -- log LevelInfo "Connected"
+ let
+ wsHandler = unWebSocketHandler webSockH conn
+ sendRouteHtmlToClient path s = do
+ case Map.lookup Web.siteMap of
+ Nothing -> routeRW.write $ liveErrorHtmlResponse "NoSuchRoute"
+ {-
+ decodeUrlRoute @model s path & \case
+ Left err -> do
+ -- log LevelError $ badRouteEncodingMsg err
+ Right Nothing ->
+ MC.exec @IO $ WS.sendTextData conn $ liveErrorHtmlResponse decodeRouteNothingMsg
+ Right (Just r) -> do
+ renderCatchingErrors s r >>= \case
+ AssetGenerated Html html ->
+ MC.exec @IO $ 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 ->
+ MC.exec @IO $ WS.sendTextData conn $ "REDIRECT " <> toText (review (fromPrism_ $ routePrism s) r)
+ AssetGenerated Other _s ->
+ MC.exec @IO $ 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.
+ wsHandler currentModel >>= \mNextRoute ->
+ -- 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 ()
+ loop mNextRoute
+ {-
+ currentModel <- LVar.get model
+ race (LVar.listenNext model subId) (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.
+ --modelRO.React.onWrite $ \model -> do
+ -- sendRouteHtmlToClient <$> routeRO.React.read <*> pure model
+ --routeRO.React.onWrite $ \route ->
+ -- sendRouteHtmlToClient <$> route <*> modelRO.React.read
+ -- Exception.try @ConnectionException (loop mInitialRoute) >>= \case
+ -- Right () -> pass
+ -- Left _connExc -> do
+ -- return ()
+choose :: [(STM a, a -> IO ())] -> IO ()
+choose choices = do
+ act <- atomically (foldr1 orElse actions)
+ act
+ where
+ actions :: [STM (IO ())]
+ actions = [ do val <- guard
+ return (rhs val)
+ | (guard, rhs) <- choices ]
+atomicallyStubborn :: forall a. STM a -> IO a
+atomicallyStubborn stm = persevere
+ where
+ persevere :: IO a
+ persevere =
+ catch (atomically stm) $ \BlockedIndefinitelyOnSTM ->
+ persevere
+dequeue :: TQueue (Either NetworkFailure Int) -> IO (Either NetworkFailure Int)
+dequeue queue = do
+ -- consider the write thread to be a GC root when it is blocked on the TQueue; this way it will not be considered as stalled, and nor will any other threads that depend on it (such as the fourth thread in the example above). We can do this by providing creating a stable pointer to the thread (this workaround is due to Simon Marlow)
+ tid <- myThreadId
+ bracket (newStablePtr tid) freeStablePtr $ \_ ->
+ atomically $ readTQueue queue
+-}
--- /dev/null
+<html lang="en">
+
+<head>
+ <meta charset="UTF-8">
+ <meta name="viewport" content="width=device-width, initial-scale=1" />
+ <title>Literate.Web.Live exception</title>
+</head>
+
+<body class="overflow-y: scroll;">
+ <h1>Literate.Web.Live threw an exception</h1>
+ <pre
+ style="font-family: monospace; border: 1px solid; padding: 1em 1em 1em 1em; overflow-wrap: anywhere;">MESSAGE</pre>
+ <p>Once you fix the source of the error, this page will automatically refresh.
+</body>
+
+</html>
--- /dev/null
+<!--
+The inline CSS here is roughly analogous to the ones generated by Tailwind.
+See the original version based on Tailwind`: https://gist.github.com/srid/2471813953a6df9b24909b9bb1d3cd2b
+-->
+
+<div style="
+ display: none;
+ position: absolute;
+ top: 0px;
+ left: 0px;
+ padding: 0.5rem;
+ font-size: 12px;
+ line-height: 18px;
+ tab-size: 4;
+ text-size-adjust: 100%;
+" id="live-indicator">
+ <div style="
+ display: flex;
+ overflow: hidden;
+ font-size: 0.75rem;
+ align-items: center;
+ gap: 0.5rem;
+ padding: 0.5rem;
+ height: 2rem;
+ width: 2rem;
+ box-sizing: border-box;
+ border-style: solid;
+ border-width: 2px;
+ border-color: rgb(229 231 235);
+ background-color: rgb(255 255 255);
+ border-radius: 9999px;
+ box-shadow: 0 10px 15px -3px rgb(0 0 0 / 0.1), 0 4px 6px -4px rgb(0 0 0 / 0.1);
+ transition-property: width, height;
+ transition-duration: 500ms;
+ transition-timing-function: cubic-bezier(0.4, 0, 0.2, 1);
+ " onMouseOver="this.style.width='100%'" onMouseOut="this.style.width='2rem'" id="live-status" title="Live Status">
+ <div hidden style="
+ flex: none;
+ width: 0.75rem;
+ height: 0.75rem;
+ background-color: rgb(22 163 74);
+ border-radius: 9999px;
+ " id="live-connected"></div>
+ <div hidden style="
+ flex: none;
+ width: 0.75rem;
+ height: 0.75rem;
+ border-radius: 9999px;
+ animation: spin 1s linear infinite;
+ background-image: linear-gradient(to right, var(--tw-gradient-stops));
+ --tw-gradient-from: #93c5fd;
+ --tw-gradient-stops: var(--tw-gradient-from), var(--tw-gradient-to);
+ --tw-gradient-to: #2563eb;
+ " id="live-reloading">
+ <style>
+ @keyframes spin {
+ from {
+ transform: rotate(0deg);
+ }
+
+ to {
+ transform: rotate(360deg);
+ }
+ }
+ </style>
+ </div>
+ <div hidden style="
+ flex: none;
+ width: 0.75rem;
+ height: 0.75rem;
+ border-radius: 9999px;
+ background-color: rgb(234 179 8);
+ " id="live-connecting">
+ <div style="
+ flex: none;
+ width: 0.75rem;
+ height: 0.75rem;
+ border-radius: 9999px;
+ background-color: rgb(234 179 8);
+ animation: ping 1s cubic-bezier(0, 0, 0.2, 1) infinite;
+ ">
+ <style>
+ @keyframes ping {
+
+ 75%,
+ 100% {
+ transform: scale(2);
+ opacity: 0;
+ }
+ }
+ </style>
+ </div>
+ </div>
+ <div hidden style="
+ flex: none;
+ width: 0.75rem;
+ height: 0.75rem;
+ border-radius: 9999px;
+ background-color: rgb(239 68 68);
+ " id="live-disconnected"></div>
+ <p style="white-space: nowrap;" id="live-message"></p>
+ </div>
+</div>
--- /dev/null
+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('LiveBeforeMorphDOM'));
+ morphdom(elm, html);
+ window.dispatchEvent(new Event('LiveBeforeScriptReload'));
+ // Re-add <script> tags, because just DOM diff applying is not enough.
+ reloadScripts(elm);
+ window.dispatchEvent(new Event('LiveHotReload'));
+};
+
+// 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);
+ });
+};
+
+// Live Status indicator
+const messages = {
+ 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 }
+
+ for (const i in is) {
+ document.getElementById(`live-${i}`).style.display =
+ is[i] ? "block" : "none"
+ if (is[i])
+ document.getElementById('live-message').innerText = messages[i]
+ };
+ document.getElementById("live-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("live-indicator").style.display = "none";
+};
+
+// Base URL path - for when the live 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(reconnecting) {
+ // The route current DOM is displaying
+ let routeVisible = document.location.pathname;
+
+ const verb = reconnecting ? "Reopening" : "Opening";
+ console.log(`live: ${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(`live: requesting ${relPath}`);
+ ws.send(relPath);
+ }
+
+ // Call this, then the server will send update *once*. Call again for
+ // continous monitoring.
+ function watchCurrentRoute() {
+ console.log(`live: ⏿ Observing changes to ${document.location.pathname}`);
+ sendObservePath(document.location.pathname);
+ };
+
+ function switchRoute(path, hash = "") {
+ console.log(`live: → Switching to ${path + hash}`);
+ window.history.pushState({}, "", path + hash);
+ sendObservePath(path);
+ }
+
+ function scrollToAnchor(hash) {
+ console.log(`live: 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") {
+ 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(`live: ... 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("live: 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("live: redirect");
+ document.location.href = evt.data.slice("REDIRECT ".length);
+ } else if (evt.data.startsWith("SWITCH ")) {
+ console.log("live: switch");
+ switchRoute(evt.data.slice("SWITCH ".length));
+ } else {
+ console.log("live: ✍ 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();
+ };
+
+ // API for user invocations
+ window.live = {
+ switchRoute: switchRoute
+ };
+};
sourcephile / git / haskell / literate-web.git / commitdiff