1 {-# LANGUAGE TemplateHaskell #-}
2 {-# LANGUAGE NoRebindableSyntax #-}
4 module Literate.Web.Live.WebSocket where
6 import Control.Applicative (Alternative (..), Applicative (..))
7 import Control.Concurrent.Async qualified as Async
8 import Control.Concurrent.STM (STM)
9 import Control.Concurrent.STM qualified as STM
10 import Control.Exception qualified as Exception
11 import Control.Monad (Monad (..))
12 import Control.Monad.Classes qualified as MC
13 import Data.ByteString.Lazy qualified as BSL
14 import Data.Either (Either (..))
15 import Data.FileEmbed (embedFile)
16 import Data.Function (($))
17 import Data.Functor ((<$>))
18 import Data.Map.Strict qualified as Map
19 import Data.Maybe (Maybe (..))
20 import Data.Monoid (mconcat)
21 import Data.Semigroup (Semigroup (..))
22 import Data.Text (Text)
23 import Data.Text.Lazy qualified as TextL
24 import Data.Text.Lazy.Encoding qualified as TextL
25 import Data.Text.Lazy.IO qualified as TextL
26 import Network.WebSockets (ConnectionException)
27 import Network.WebSockets qualified as WS
29 import System.IO qualified as Sys
30 import Text.Show (show)
32 import Literate.Web qualified as Web
33 import Literate.Web.Live.Asset
34 import Literate.Web.Live.Common
40 (model -> m (Map.Map Web.OutputPath (m BSL.ByteString))) ->
42 webSocketApp iniModel modelSTM siteMap pendingConn =
43 withWebSocket pendingConn $ \(routeSTM, routeSend) -> do
44 let loop model route = do
45 STM.atomically (Left <$> modelSTM <|> Right <$> routeSTM) >>= \case
46 Left newModel -> loop newModel route
47 Right newRoute -> loop model newRoute
49 TextL.hPutStrLn Sys.stderr $ "webSocketApp: route: " <> TextL.pack (show route)
50 case Map.lookup route site of
51 Nothing -> MC.exec @IO $ routeSend [WS.Binary (liveErrorHtmlResponse decodeRouteNothingMsg)]
53 content <- MC.exec @IO contentIO
54 MC.exec @IO $ routeSend [WS.Binary content]
58 { Web.outputPathSegs = ["index"]
59 , Web.outputPathExts = ["html"]
63 WS.PendingConnection ->
64 ((STM Web.OutputPath, [WS.DataMessage] -> IO ()) -> IO ()) ->
66 withWebSocket pendingConn f = do
67 var <- STM.newEmptyTMVarIO
68 conn :: WS.Connection <- WS.acceptRequest pendingConn
69 WS.withPingThread conn 30 (pure ()) $
72 Exception.try @ConnectionException (WS.receiveData @Text conn) >>= \case
73 Left (WS.CloseRequest _ (TextL.decodeUtf8 -> reason)) -> do
74 TextL.hPutStrLn Sys.stderr $ "WebSocket.CloseRequest, reason: " <> reason
75 Left WS.ConnectionClosed -> do
76 Sys.hPrint Sys.stderr (["withWebSocket", "loop", "ConnectionClosed"] :: [Text])
77 Left WS.ParseException{} -> do
78 TextL.hPutStrLn Sys.stderr $ "WebSocket.ParseException"
79 Left WS.UnicodeException{} -> do
80 TextL.hPutStrLn Sys.stderr $ "WebSocket.UnicodeException"
82 STM.atomically $ STM.writeTMVar var $ decodeOutputPath msg
87 Exception.try @ConnectionException
88 (f (STM.readTMVar var, WS.sendDataMessages conn))
90 Left (WS.CloseRequest _ (TextL.decodeUtf8 -> reason)) -> do
91 TextL.hPutStrLn Sys.stderr $ "WebSocket.CloseRequest, reason: " <> reason
92 Left WS.ConnectionClosed -> do
93 Sys.hPrint Sys.stderr (["withWebSocket", "f", "ConnectionClosed"] :: [Text])
94 Left WS.ParseException{} -> do
95 TextL.hPutStrLn Sys.stderr $ "WebSocket.ParseException"
96 Left WS.UnicodeException{} -> do
97 TextL.hPutStrLn Sys.stderr $ "WebSocket.UnicodeException"
98 Right () -> WS.sendClose conn ("Bye!" :: Text)
101 -- WS.CloseRequest _ (Text.decodeUtf8 -> reason) ->
102 -- log LevelInfo $ "Closing websocket connection (reason: " <> reason <> ")"
104 -- log LevelError $ "Websocket error: " <> show connExc
105 -- LVar.removeListener model subId
107 -- | A handler takes a websocket connection and the current model and then watches
108 -- for websocket messages. It must return a new route to watch (after that, the
109 -- returned route's HTML will be sent back to the client).
111 -- Note that this is usually a long-running thread that waits for the client's
112 -- messages. But you can also use it to implement custom server actions, by handling
113 -- the incoming websocket messages or other IO events in any way you like.
115 -- Also note that whenever the model is updated, the handler action will be
116 -- stopped and then restarted with the new model as argument.
117 newtype WebSocketHandler model = WebSocketHandler
118 { unWebSocketHandler :: WS.Connection {-RO IO-} -> model -> IO Text
121 webSocketHandler :: WebSocketHandler model
122 webSocketHandler = WebSocketHandler $ \conn _model -> do
123 msg :: Text <- MC.exec @IO $ WS.receiveData conn
124 -- log LevelDebug $ "<~~ " <> show msg
127 -- where log lvl (t :: Text) = logWithoutLoc "ema.ws" lvl t
129 -- Browser-side JavaScript code for interacting with the Haskell server
130 webSocketClientJS :: BSL.ByteString
135 [ "<script type='module' src='https://cdn.jsdelivr.net/npm/morphdom@2.7.2/dist/morphdom-umd.min.js'></script>"
136 , "<script type='module'>"
139 , BSL.fromStrict $(embedFile "www/live-shim.js")
142 [ "window.onpageshow = function () { init(false) };"
148 -- instance WS.WebSocketsData Web.OutputPath where
151 --subId <- LVar.addListener model
152 -- let log lvl (s :: Text) = logWithoutLoc (toText @String $ printf "ema.ws.%.2d" subId) lvl s
153 -- log LevelInfo "Connected"
155 wsHandler = unWebSocketHandler webSockH conn
156 sendRouteHtmlToClient path s = do
157 case Map.lookup Web.siteMap of
158 Nothing -> routeRW.write $ liveErrorHtmlResponse "NoSuchRoute"
160 decodeUrlRoute @model s path & \case
162 -- log LevelError $ badRouteEncodingMsg err
164 MC.exec @IO $ WS.sendTextData conn $ liveErrorHtmlResponse decodeRouteNothingMsg
166 renderCatchingErrors s r >>= \case
167 AssetGenerated Html html ->
168 MC.exec @IO $ WS.sendTextData conn $ html <> toLazy wsClientHtml
169 -- HACK: We expect the websocket client should check for REDIRECT prefix.
170 -- Not bothering with JSON response to avoid having to JSON parse every HTML dump.
171 AssetStatic _staticPath ->
172 MC.exec @IO $ WS.sendTextData conn $ "REDIRECT " <> toText (review (fromPrism_ $ routePrism s) r)
173 AssetGenerated Other _s ->
174 MC.exec @IO $ WS.sendTextData conn $ "REDIRECT " <> toText (review (fromPrism_ $ routePrism s) r)
176 -- log LevelDebug $ " ~~> " <> show r
177 -- @mWatchingRoute@ is the route currently being watched.
178 loop mWatchingRoute = do
179 -- Listen *until* either we get a new value, or the client requests
180 -- to switch to a new route.
181 wsHandler currentModel >>= \mNextRoute ->
182 -- The user clicked on a route link; send them the HTML for
183 -- that route this time, ignoring what we are watching
184 -- currently (we expect the user to initiate a watch route
185 -- request immediately following this).
186 sendRouteHtmlToClient mNextRoute ()
189 currentModel <- LVar.get model
190 race (LVar.listenNext model subId) (wsHandler currentModel) >>= \case
192 -- The page the user is currently viewing has changed. Send
193 -- the new HTML to them.
194 sendRouteHtmlToClient mWatchingRoute newModel
196 Right mNextRoute -> do
197 -- The user clicked on a route link; send them the HTML for
198 -- that route this time, ignoring what we are watching
199 -- currently (we expect the user to initiate a watch route
200 -- request immediately following this).
201 sendRouteHtmlToClient mNextRoute =<< LVar.get model
204 -- Wait for the client to send the first request with the initial route.
205 --modelRO.React.onWrite $ \model -> do
206 -- sendRouteHtmlToClient <$> routeRO.React.read <*> pure model
207 --routeRO.React.onWrite $ \route ->
208 -- sendRouteHtmlToClient <$> route <*> modelRO.React.read
209 -- Exception.try @ConnectionException (loop mInitialRoute) >>= \case
211 -- Left _connExc -> do
213 choose :: [(STM a, a -> IO ())] -> IO ()
215 act <- atomically (foldr1 orElse actions)
218 actions :: [STM (IO ())]
219 actions = [ do val <- guard
221 | (guard, rhs) <- choices ]
222 atomicallyStubborn :: forall a. STM a -> IO a
223 atomicallyStubborn stm = persevere
227 catch (atomically stm) $ \BlockedIndefinitelyOnSTM ->
229 dequeue :: TQueue (Either NetworkFailure Int) -> IO (Either NetworkFailure Int)
231 -- 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)
233 bracket (newStablePtr tid) freeStablePtr $ \_ ->
234 atomically $ readTQueue queue