src/Literate/Web/Live/WebSocket.hs

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