src/Literate/Web/Live.hs

   1 {-# LANGUAGE NoRebindableSyntax #-}
   2
   3 module Literate.Web.Live where
   4
   5 import Control.Applicative (Applicative (..))
   6 import Control.Concurrent (threadDelay)
   7 import Control.Concurrent.STM (STM)
   8 import Control.Concurrent.STM qualified as STM
   9 import Control.Monad (void)
  10 import Control.Monad.Classes qualified as MC
  11 import Data.ByteString.Lazy qualified as BSL
  12 import Data.Function (const, ($), (&))
  13 import Data.Map.Strict qualified as Map
  14 import Data.Maybe (Maybe (..), maybe)
  15 import Data.Monoid (Monoid (..))
  16 import Data.Text.Lazy qualified as TextL
  17 import Data.Text.Lazy.IO qualified as TextL
  18 import Network.Wai qualified as Wai
  19 import Network.Wai.Handler.Warp qualified as Warp
  20 import Network.Wai.Handler.WebSockets qualified as WaiWs
  21 import Network.WebSockets qualified as WS
  22 import System.IO (IO)
  23 import System.IO qualified as Sys
  24 import Text.Show (Show (..))
  25 import Prelude (Bounded (..))
  26
  27 import Literate.Web qualified as Web
  28 import Literate.Web.Live.HTTP
  29 import Literate.Web.Live.WebSocket
  30
  31 runLive ::
  32   m ~ IO =>
  33   MC.MonadExec IO m =>
  34   Maybe () ->
  35   Warp.HostPreference ->
  36   Maybe Warp.Port ->
  37   STM model ->
  38   (model -> m (Map.Map Web.OutputPath (IO BSL.ByteString))) ->
  39   m ()
  40 runLive mWsOpts host portMaybe modelSTM siteMap = do
  41   iniModel <- MC.exec @IO $ STM.atomically modelSTM
  42   let
  43     settings =
  44       Warp.defaultSettings
  45         & Warp.setHost host
  46     app = case mWsOpts of
  47       Nothing -> httpApp modelSTM siteMap Nothing
  48       Just () -> do
  49         WaiWs.websocketsOr
  50           WS.defaultConnectionOptions
  51           (webSocketApp iniModel modelSTM siteMap)
  52           (httpApp modelSTM siteMap (Just webSocketClientJS))
  53     banner port = do
  54       TextL.hPutStrLn Sys.stderr $
  55         TextL.unlines
  56           [ "==============================================="
  57           , mconcat
  58               [ "Live server RUNNING: http://"
  59               , TextL.pack (show host)
  60               , ":"
  61               , TextL.pack (show port)
  62               , " ("
  63               , maybe "no ws" (const "ws") mWsOpts
  64               , ")"
  65               ]
  66           , "==============================================="
  67           ]
  68   MC.exec @IO $ warpRunSettings settings portMaybe banner app
  69
  70 -- Like Warp.runSettings but takes *optional* port. When no port is set,
  71 -- a free (random) port is used.
  72 warpRunSettings :: Warp.Settings -> Maybe Warp.Port -> (Warp.Port -> IO a) -> Wai.Application -> IO ()
  73 warpRunSettings settings portMaybe banner app = do
  74   case portMaybe of
  75     Nothing ->
  76       Warp.withApplicationSettings settings (pure app) $ \port -> do
  77         void $ banner port
  78         threadDelay maxBound
  79     Just port -> do
  80       void $ banner port
  81       Warp.runSettings (Warp.setPort port settings) app