diff --git a/bin/run-via-tmux b/bin/run-via-tmux index 494763a..24c3448 100755 --- a/bin/run-via-tmux +++ b/bin/run-via-tmux @@ -1,4 +1,4 @@ #!/usr/bin/env bash set -xe PROJECT=$(basename `pwd`) -tmux new-session -A -s $PROJECT bin/run +exec tmux new-session -A -s $PROJECT bin/run diff --git a/src/Ema/Example/Ex03_Diary.hs b/src/Ema/Example/Ex03_Diary.hs index 8d5d224..ddb9897 100644 --- a/src/Ema/Example/Ex03_Diary.hs +++ b/src/Ema/Example/Ex03_Diary.hs @@ -110,7 +110,7 @@ mainWith folder = do render :: Diary -> Route -> LByteString render diary r = do - Tailwind.layout (H.title "My Diary") $ + Tailwind.layout (H.title pageTitle) $ H.div ! A.class_ "container mx-auto" $ do let heading = H.header @@ -125,7 +125,13 @@ render diary r = do heading $ show day routeElem Index "Back to Index" maybe "not found" renderOrg (Map.lookup day diary) + H.footer ! A.class_ "mt-2 text-center border-t-2 text-gray-500" $ do + "Powered by " + H.a ! A.href "https://github.com/srid/ema" ! A.target "blank_" $ "Ema" where + pageTitle = case r of + Index -> "My Diary" + OnDay day -> show day <> " -- My Diary" routeElem r' w = H.a ! A.class_ "text-xl text-purple-500 hover:underline" ! routeHref r' $ w routeHref r' = diff --git a/src/Ema/Server.hs b/src/Ema/Server.hs index eac9ff3..4cb472e 100644 --- a/src/Ema/Server.hs +++ b/src/Ema/Server.hs @@ -4,6 +4,7 @@ -- | TODO: Refactor this module module Ema.Server where +import Control.Concurrent.Async (race) import Control.Exception (try) import Data.LVar (LVar) import qualified Data.LVar as LVar @@ -33,19 +34,42 @@ runServerWithWebSocketHotReload port model render = do WS.withPingThread conn 30 (pure ()) $ do subId <- LVar.addListener model let log s = putTextLn $ "[" <> show subId <> "] :: " <> s - log "ws connected" - let loop = do - msg <- WS.receiveData conn - let r :: route = - msg - & pathInfoFromWsMsg - & routeFromPathInfo - & fromMaybe (error "invalid route from ws") - log $ "Browser requests next HTML for: " <> show r - val <- LVar.listenNext model subId - WS.sendTextData conn $ routeHtml val r - log $ "Sent HTML for " <> show r - loop + log "ws:connected" + let askClientForRoute = do + msg :: Text <- WS.receiveData conn + pure $ + msg + & pathInfoFromWsMsg + & routeFromPathInfo + & fromMaybe (error "invalid route from ws") + loop = 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. + watchingRoute <- askClientForRoute + log $ "[Watch]: <~~ " <> show watchingRoute + -- 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 newHtml -> do + -- The page the user is currently viewing has changed. Send + -- the new HTML to them. + WS.sendTextData conn $ routeHtml newHtml watchingRoute + log $ "[Watch]: ~~> " <> show watchingRoute + loop + Right nextRoute -> 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). + log $ "[Switch]: <~~ " <> show nextRoute + html <- LVar.get model + WS.sendTextData conn $ routeHtml html nextRoute + log $ "[Switch]: ~~> " <> show nextRoute + loop try loop >>= \case Right () -> pure () Left (err :: ConnectionException) -> do @@ -77,6 +101,11 @@ wsClientShim = encodeUtf8 [text|