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