ema 0.10.0.0 → 0.10.2.0
raw patch · 5 files changed
+72/−92 lines, 5 files
Files
- CHANGELOG.md +4/−0
- README.md +1/−3
- ema.cabal +1/−1
- src/Ema/Server.hs +65/−86
- www/ema-shim.js +1/−2
CHANGELOG.md view
@@ -1,5 +1,9 @@ # Revision history for ema +## 0.10.2.0 (2023-08-09)++- Simply websocket route observation logic (\#154)+ ## 0.10.0.0 (2022-11-20) - Split Ema into multiple packages:
README.md view
@@ -10,11 +10,9 @@ ## Hacking -*NOTE: `flake.nix` uses GHC 9.2 which is not yet the default in `nixpkgs`, so you may want to use the [garnix cache](https://garnix.io/docs/caching) to avoid long compilation times.*- Run `bin/run`. This runs the Ex04_Multi example. -To run the docs, run `nix run github:EmaApps/emanote -- -L ./docs`.+To run the docs, run `nix run github:srid/emanote -- -L ./docs`. ## Getting Started
ema.cabal view
@@ -1,6 +1,6 @@ cabal-version: 2.4 name: ema-version: 0.10.0.0+version: 0.10.2.0 license: AGPL-3.0-only copyright: 2021 Sridhar Ratnakumar maintainer: srid@srid.ca
src/Ema/Server.hs view
@@ -5,8 +5,6 @@ module Ema.Server where -import Control.Concurrent.Async (race)-import Control.Exception (try) import Control.Monad.Logger import Data.FileEmbed import Data.LVar (LVar)@@ -36,8 +34,9 @@ import Optics.Core (review) import Text.Printf (printf) import UnliftIO (MonadUnliftIO)+import UnliftIO.Async (race) import UnliftIO.Concurrent (threadDelay)-import UnliftIO.Exception (catch)+import UnliftIO.Exception (catch, try) runServerWithWebSocketHotReload :: forall r m.@@ -62,7 +61,7 @@ app = WaiWs.websocketsOr WS.defaultConnectionOptions- (runM . wsApp)+ (wsApp logger) (httpApp logger) banner port = do logInfoNS "ema" "==============================================="@@ -83,82 +82,71 @@ Just port -> do void $ banner port Warp.runSettings (settings & Warp.setPort port) app- wsApp pendingConn = do- conn :: WS.Connection <- lift $ WS.acceptRequest pendingConn- logger <- askLoggerIO- lift $- 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- -- TODO: Let non-html routes pass through.- let pathInfo = pathInfoFromWsMsg msg- log LevelDebug $ "<~~ " <> show pathInfo- pure pathInfo- decodeRouteWithCurrentModel pathInfo = do- val <- LVar.get model- pure $ routeFromPathInfo val pathInfo- sendRouteHtmlToClient pathInfo s = do- decodeRouteWithCurrentModel pathInfo >>= \case- 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- loop = flip runLoggingT logger $ do- -- Notice that we @askClientForRoute@ in succession twice here.- -- The first route will be the route the client intends to observe- -- for changes on. The second route, *if* it is sent, indicates- -- that the client wants to *switch* to that route. This proecess- -- repeats ad infinitum: i.e., the third route is for observing- -- changes, the fourth route is for switching to, and so on.- mWatchingRoute <- askClientForRoute- -- Listen *until* either we get a new value, or the client requests- -- to switch to a new route.- liftIO $ do- race (LVar.listenNext model subId) (runLoggingT askClientForRoute logger) >>= \res -> flip runLoggingT logger $ case res of- Left newModel -> do- -- The page the user is currently viewing has changed. Send- -- the new HTML to them.- sendRouteHtmlToClient mWatchingRoute newModel- lift loop- 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- lift loop- liftIO (try loop) >>= \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+ 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 path = Wai.pathInfo req- mr = routeFromPathInfo val path- logInfoNS "ema.http" $ "GET " <> ("/" <> T.intercalate "/" path) <> " as " <> show mr+ 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@@ -185,8 +173,6 @@ pure $ AssetGenerated Html . mkHtmlErrorMsg $ show @Text err- routeFromPathInfo m =- decodeUrlRoute m . T.intercalate "/" -- Decode an URL path into a route -- -- This function is used only in live server. If the route is not@@ -205,13 +191,6 @@ mkHtmlErrorMsg :: Text -> LByteString mkHtmlErrorMsg s = encodeUtf8 . T.replace "MESSAGE" s . decodeUtf8 $ $(embedFile "www/ema-error.html")--{- | Return the equivalent of WAI's @pathInfo@, from the raw path string- (`document.location.pathname`) the browser sends us.--}-pathInfoFromWsMsg :: Text -> [Text]-pathInfoFromWsMsg =- filter (/= "") . T.splitOn "/" . T.drop 1 decodeRouteNothingMsg :: Text decodeRouteNothingMsg = "Ema: 404 (route decoding returned Nothing)"
www/ema-shim.js view
@@ -73,7 +73,7 @@ let ws = new WebSocket(wsUrl); function sendObservePath(path) {- const relPath = path.startsWith(basePath) ? path.slice(basePath.length - 1) : path;+ const relPath = path.startsWith(basePath) ? path.slice(basePath.length) : path; console.debug(`ema: requesting ${relPath}`); ws.send(relPath); }@@ -167,7 +167,6 @@ if (window.location.hash) { scrollToAnchor(window.location.hash); }- watchCurrentRoute(); }; }; window.onbeforeunload = evt => { ws.close(); };