From 4ae0024ed94b21afa1a35f5300e93c8a7fc6f6cc Mon Sep 17 00:00:00 2001 From: Julien Moutinho Date: Sun, 8 Sep 2024 01:16:02 +0200 Subject: [PATCH] feat(live): init `Literate.Web.Live` --- literate-web.cabal | 47 +++--- src/Literate/Web/Live.hs | 81 ++++++++++ src/Literate/Web/Live/Asset.hs | 41 +++++ src/Literate/Web/Live/Common.hs | 99 ++++++++++++ src/Literate/Web/Live/HTTP.hs | 74 +++++++++ src/Literate/Web/Live/WebSocket.hs | 235 +++++++++++++++++++++++++++++ www/live-error.html | 16 ++ www/live-indicator.html | 103 +++++++++++++ www/live-shim.js | 196 ++++++++++++++++++++++++ 9 files changed, 871 insertions(+), 21 deletions(-) create mode 100644 src/Literate/Web/Live.hs create mode 100644 src/Literate/Web/Live/Asset.hs create mode 100644 src/Literate/Web/Live/Common.hs create mode 100644 src/Literate/Web/Live/HTTP.hs create mode 100644 src/Literate/Web/Live/WebSocket.hs create mode 100644 www/live-error.html create mode 100644 www/live-indicator.html create mode 100644 www/live-shim.js diff --git a/literate-web.cabal b/literate-web.cabal index edffc51..0cda8bf 100644 --- a/literate-web.cabal +++ b/literate-web.cabal @@ -11,12 +11,12 @@ license-file: LICENSES/AGPL-3.0-or-later.txt -- 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. . @@ -25,13 +25,16 @@ description: * 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: @@ -39,13 +42,14 @@ source-repository head 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 @@ -64,21 +68,13 @@ common boilerplate 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 @@ -86,15 +82,17 @@ common library-deps , 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 @@ -109,6 +107,7 @@ common library-deps , warp , websockets >=0.12 +-- , reflection -- , mvc -- , mvc-updates -- , pipes @@ -116,11 +115,17 @@ common library-deps -- , 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 @@ -135,7 +140,7 @@ library --Literate.Web.MIME -- library relactive --- import: boilerplate, library-deps +-- import: haskell-variant, library-deps -- hs-source-dirs: src -- build-depends: -- , async @@ -154,7 +159,7 @@ library 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 @@ -184,7 +189,7 @@ test-suite literate-web-tests -- , 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 @@ -200,7 +205,7 @@ test-suite literate-web-tests -- 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: @@ -215,7 +220,7 @@ test-suite literate-web-tests -- , weigh -- -- executable async --- import: boilerplate, library-deps +-- import: haskell-variant, library-deps -- hs-source-dirs: executables/async -- main-is: Main.hs -- build-depends: @@ -230,7 +235,7 @@ test-suite literate-web-tests -- -- , relude >= 1 -- -- executable fsnotify --- import: boilerplate, library-deps +-- import: haskell-variant, library-deps -- hs-source-dirs: executables/fsnotify -- main-is: Main.hs -- build-depends: diff --git a/src/Literate/Web/Live.hs b/src/Literate/Web/Live.hs new file mode 100644 index 0000000..fad84aa --- /dev/null +++ b/src/Literate/Web/Live.hs @@ -0,0 +1,81 @@ +{-# 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 diff --git a/src/Literate/Web/Live/Asset.hs b/src/Literate/Web/Live/Asset.hs new file mode 100644 index 0000000..35eab52 --- /dev/null +++ b/src/Literate/Web/Live/Asset.hs @@ -0,0 +1,41 @@ +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) diff --git a/src/Literate/Web/Live/Common.hs b/src/Literate/Web/Live/Common.hs new file mode 100644 index 0000000..2ffdbe2 --- /dev/null +++ b/src/Literate/Web/Live/Common.hs @@ -0,0 +1,99 @@ +{-# 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." +-} diff --git a/src/Literate/Web/Live/HTTP.hs b/src/Literate/Web/Live/HTTP.hs new file mode 100644 index 0000000..166b259 --- /dev/null +++ b/src/Literate/Web/Live/HTTP.hs @@ -0,0 +1,74 @@ +{-# 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 +-} diff --git a/src/Literate/Web/Live/WebSocket.hs b/src/Literate/Web/Live/WebSocket.hs new file mode 100644 index 0000000..1846c63 --- /dev/null +++ b/src/Literate/Web/Live/WebSocket.hs @@ -0,0 +1,235 @@ +{-# 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 + [ "" + , "" + ] + ) + ] + +-- 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 +-} diff --git a/www/live-error.html b/www/live-error.html new file mode 100644 index 0000000..c6f454d --- /dev/null +++ b/www/live-error.html @@ -0,0 +1,16 @@ + + + + + + Literate.Web.Live exception + + + +

Literate.Web.Live threw an exception

+ 
MESSAGE
+

Once you fix the source of the error, this page will automatically refresh. + + + diff --git a/www/live-indicator.html b/www/live-indicator.html new file mode 100644 index 0000000..04978fd --- /dev/null +++ b/www/live-indicator.html @@ -0,0 +1,103 @@ + + +

+
+ + + + +

+
+
diff --git a/www/live-shim.js b/www/live-shim.js new file mode 100644 index 0000000..2831eae --- /dev/null +++ b/www/live-shim.js @@ -0,0 +1,196 @@ +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