src/Literate/Web/Live/WebSocket.hs

   1 {-# LANGUAGE TemplateHaskell #-}
   2 {-# LANGUAGE NoRebindableSyntax #-}
   3
   4 module Literate.Web.Live.WebSocket where
   5
   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
  28 import System.IO (IO)
  29 import System.IO qualified as Sys
  30 import Text.Show (show)
  31
  32 import Literate.Web qualified as Web
  33 import Literate.Web.Live.Asset
  34 import Literate.Web.Live.Common
  35
  36 webSocketApp ::
  37   m ~ IO =>
  38   model ->
  39   STM model ->
  40   (model -> m (Map.Map Web.OutputPath (m BSL.ByteString))) ->
  41   WS.ServerApp
  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
  48           site <- siteMap model
  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)]
  52             Just contentIO -> do
  53               content <- MC.exec @IO contentIO
  54               MC.exec @IO $ routeSend [WS.Binary content]
  55     loop
  56       iniModel
  57       Web.OutputPath
  58         { Web.outputPathSegs = ["index"]
  59         , Web.outputPathExts = ["html"]
  60         }
  61
  62 withWebSocket ::
  63   WS.PendingConnection ->
  64   ((STM Web.OutputPath, [WS.DataMessage] -> IO ()) -> IO ()) ->
  65   IO ()
  66 withWebSocket pendingConn f = do
  67   var <- STM.newEmptyTMVarIO
  68   conn :: WS.Connection <- WS.acceptRequest pendingConn
  69   WS.withPingThread conn 30 (pure ()) $
  70     Async.withAsync
  71       ( let loop =
  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"
  81                 Right msg -> do
  82                   STM.atomically $ STM.writeTMVar var $ decodeOutputPath msg
  83                   loop
  84         in loop
  85       )
  86       Async.wait
  87   Exception.try @ConnectionException
  88     (f (STM.readTMVar var, WS.sendDataMessages conn))
  89     >>= \case
  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)
  99
 100 -- case connExc of
 101 --  WS.CloseRequest _ (Text.decodeUtf8 -> reason) ->
 102 --    log LevelInfo $ "Closing websocket connection (reason: " <> reason <> ")"
 103 --  _ ->
 104 --    log LevelError $ "Websocket error: " <> show connExc
 105 -- LVar.removeListener model subId
 106
 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).
 110 --
 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.
 114 --
 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
 119   }
 120
 121 webSocketHandler :: WebSocketHandler model
 122 webSocketHandler = WebSocketHandler $ \conn _model -> do
 123   msg :: Text <- MC.exec @IO $ WS.receiveData conn
 124   -- log LevelDebug $ "<~~ " <> show msg
 125   pure msg
 126
 127 -- where log lvl (t :: Text) = logWithoutLoc "ema.ws" lvl t
 128
 129 -- Browser-side JavaScript code for interacting with the Haskell server
 130 webSocketClientJS :: BSL.ByteString
 131 webSocketClientJS =
 132   mconcat
 133     [ TextL.encodeUtf8
 134         ( mconcat
 135             [ "<script type='module' src='https://cdn.jsdelivr.net/npm/morphdom@2.7.2/dist/morphdom-umd.min.js'></script>"
 136             , "<script type='module'>"
 137             ]
 138         )
 139     , BSL.fromStrict $(embedFile "www/live-shim.js")
 140     , TextL.encodeUtf8
 141         ( mconcat
 142             [ "window.onpageshow = function () { init(false) };"
 143             , "</script>"
 144             ]
 145         )
 146     ]
 147
 148 -- instance WS.WebSocketsData Web.OutputPath where
 149
 150 {-
 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"
 154     let
 155       wsHandler = unWebSocketHandler webSockH conn
 156       sendRouteHtmlToClient path s = do
 157         case Map.lookup Web.siteMap of
 158           Nothing -> routeRW.write $ liveErrorHtmlResponse "NoSuchRoute"
 159         {-
 160         decodeUrlRoute @model s path & \case
 161           Left err -> do
 162             -- log LevelError $ badRouteEncodingMsg err
 163           Right Nothing ->
 164             MC.exec @IO $ WS.sendTextData conn $ liveErrorHtmlResponse decodeRouteNothingMsg
 165           Right (Just r) -> do
 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)
 175         -}
 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 ()
 187           loop mNextRoute
 188         {-
 189         currentModel <- LVar.get model
 190         race (LVar.listenNext model subId) (wsHandler currentModel) >>= \case
 191           Left newModel -> do
 192             -- The page the user is currently viewing has changed. Send
 193             -- the new HTML to them.
 194             sendRouteHtmlToClient mWatchingRoute newModel
 195             loop mWatchingRoute
 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
 202             loop mNextRoute
 203         -}
 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
 210     --    Right () -> pass
 211     --    Left _connExc -> do
 212     --      return ()
 213 choose :: [(STM a, a -> IO ())] -> IO ()
 214 choose choices = do
 215     act <- atomically (foldr1 orElse actions)
 216     act
 217   where
 218     actions :: [STM (IO ())]
 219     actions = [ do val <- guard
 220                    return (rhs val)
 221               | (guard, rhs) <- choices ]
 222 atomicallyStubborn :: forall a. STM a -> IO a
 223 atomicallyStubborn stm = persevere
 224   where
 225     persevere :: IO a
 226     persevere =
 227         catch (atomically stm) $ \BlockedIndefinitelyOnSTM ->
 228           persevere
 229 dequeue :: TQueue (Either NetworkFailure Int) -> IO (Either NetworkFailure Int)
 230 dequeue queue = do
 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)
 232     tid <- myThreadId
 233     bracket (newStablePtr tid) freeStablePtr $ \_ ->
 234       atomically $ readTQueue queue
 235 -}