{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TypeApplications #-}

module Ema.Server where

import Control.Concurrent.Async (race)
import Control.Exception (catch, try)
import Control.Monad.Logger
import Data.LVar (LVar)
import qualified Data.LVar as LVar
import qualified Data.Text as T
import Ema.Asset
import Ema.Class (Ema (..))
import GHC.IO.Unsafe (unsafePerformIO)
import NeatInterpolation (text)
import qualified Network.HTTP.Types as H
import qualified Network.Wai as Wai
import qualified Network.Wai.Handler.Warp as Warp
import qualified Network.Wai.Handler.WebSockets as WaiWs
import qualified Network.Wai.Middleware.Static as Static
import Network.WebSockets (ConnectionException)
import qualified Network.WebSockets as WS
import System.FilePath ((</>))
import Text.Printf (printf)
import UnliftIO (MonadUnliftIO)

runServerWithWebSocketHotReload ::
  forall model route m.
  ( Ema model route,
    Show route,
    MonadIO m,
    MonadUnliftIO m,
    MonadLoggerIO m
  ) =>
  String ->
  Int ->
  LVar model ->
  (model -> route -> Asset LByteString) ->
  m ()
runServerWithWebSocketHotReload :: String
-> Int
-> LVar model
-> (model -> route -> Asset LByteString)
-> m ()
runServerWithWebSocketHotReload String
host Int
port LVar model
model model -> route -> Asset LByteString
render = do
  let settings :: Settings
settings =
        Settings
Warp.defaultSettings
          Settings -> (Settings -> Settings) -> Settings
forall a b. a -> (a -> b) -> b
& Int -> Settings -> Settings
Warp.setPort Int
port
          Settings -> (Settings -> Settings) -> Settings
forall a b. a -> (a -> b) -> b
& HostPreference -> Settings -> Settings
Warp.setHost (String -> HostPreference
forall a. IsString a => String -> a
fromString String
host)
  Loc -> LogSource -> LogLevel -> LogStr -> IO ()
logger <- m (Loc -> LogSource -> LogLevel -> LogStr -> IO ())
forall (m :: * -> *).
MonadLoggerIO m =>
m (Loc -> LogSource -> LogLevel -> LogStr -> IO ())
askLoggerIO

  LogSource -> m ()
forall (m :: * -> *). MonadLogger m => LogSource -> m ()
logInfoN LogSource
"============================================"
  LogSource -> m ()
forall (m :: * -> *). MonadLogger m => LogSource -> m ()
logInfoN (LogSource -> m ()) -> LogSource -> m ()
forall a b. (a -> b) -> a -> b
$ LogSource
"Running live server at http://" LogSource -> LogSource -> LogSource
forall a. Semigroup a => a -> a -> a
<> String -> LogSource
forall a. ToText a => a -> LogSource
toText String
host LogSource -> LogSource -> LogSource
forall a. Semigroup a => a -> a -> a
<> LogSource
":" LogSource -> LogSource -> LogSource
forall a. Semigroup a => a -> a -> a
<> Int -> LogSource
forall b a. (Show a, IsString b) => a -> b
show Int
port
  LogSource -> m ()
forall (m :: * -> *). MonadLogger m => LogSource -> m ()
logInfoN LogSource
"============================================"
  IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$
    Settings -> Application -> IO ()
Warp.runSettings Settings
settings (Application -> IO ()) -> Application -> IO ()
forall a b. (a -> b) -> a -> b
$
      Middleware
assetsMiddleware Middleware -> Middleware
forall a b. (a -> b) -> a -> b
$
        ConnectionOptions -> ServerApp -> Middleware
WaiWs.websocketsOr
          ConnectionOptions
WS.defaultConnectionOptions
          ((LoggingT IO ()
 -> (Loc -> LogSource -> LogLevel -> LogStr -> IO ()) -> IO ())
-> (Loc -> LogSource -> LogLevel -> LogStr -> IO ())
-> LoggingT IO ()
-> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip LoggingT IO ()
-> (Loc -> LogSource -> LogLevel -> LogStr -> IO ()) -> IO ()
forall (m :: * -> *) a.
LoggingT m a
-> (Loc -> LogSource -> LogLevel -> LogStr -> IO ()) -> m a
runLoggingT Loc -> LogSource -> LogLevel -> LogStr -> IO ()
logger (LoggingT IO () -> IO ())
-> (PendingConnection -> LoggingT IO ()) -> ServerApp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PendingConnection -> LoggingT IO ()
forall (t :: (* -> *) -> * -> *).
(MonadTrans t, MonadLoggerIO (t IO)) =>
PendingConnection -> t IO ()
wsApp)
          ((Loc -> LogSource -> LogLevel -> LogStr -> IO ()) -> Application
forall (m :: * -> *) a.
MonadIO m =>
(Loc -> LogSource -> LogLevel -> LogStr -> IO ())
-> Request -> (Response -> IO a) -> m a
httpApp Loc -> LogSource -> LogLevel -> LogStr -> IO ()
logger)
  where
    wsApp :: PendingConnection -> t IO ()
wsApp PendingConnection
pendingConn = do
      Connection
conn :: WS.Connection <- IO Connection -> t IO Connection
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO Connection -> t IO Connection)
-> IO Connection -> t IO Connection
forall a b. (a -> b) -> a -> b
$ PendingConnection -> IO Connection
WS.acceptRequest PendingConnection
pendingConn
      Loc -> LogSource -> LogLevel -> LogStr -> IO ()
logger <- t IO (Loc -> LogSource -> LogLevel -> LogStr -> IO ())
forall (m :: * -> *).
MonadLoggerIO m =>
m (Loc -> LogSource -> LogLevel -> LogStr -> IO ())
askLoggerIO
      IO () -> t IO ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO () -> t IO ()) -> IO () -> t IO ()
forall a b. (a -> b) -> a -> b
$
        Connection -> Int -> IO () -> IO () -> IO ()
forall a. Connection -> Int -> IO () -> IO a -> IO a
WS.withPingThread Connection
conn Int
30 (() -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
          (LoggingT IO ()
 -> (Loc -> LogSource -> LogLevel -> LogStr -> IO ()) -> IO ())
-> (Loc -> LogSource -> LogLevel -> LogStr -> IO ())
-> LoggingT IO ()
-> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip LoggingT IO ()
-> (Loc -> LogSource -> LogLevel -> LogStr -> IO ()) -> IO ()
forall (m :: * -> *) a.
LoggingT m a
-> (Loc -> LogSource -> LogLevel -> LogStr -> IO ()) -> m a
runLoggingT Loc -> LogSource -> LogLevel -> LogStr -> IO ()
logger (LoggingT IO () -> IO ()) -> LoggingT IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
            Int
subId <- LVar model -> LoggingT IO Int
forall (m :: * -> *) a. MonadIO m => LVar a -> m Int
LVar.addListener LVar model
model
            let log :: LogLevel -> LogSource -> m ()
log LogLevel
lvl (LogSource
s :: Text) =
                  LogSource -> LogLevel -> LogSource -> m ()
forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
LogSource -> LogLevel -> msg -> m ()
logWithoutLoc (ToText String => String -> LogSource
forall a. ToText a => a -> LogSource
toText @String (String -> LogSource) -> String -> LogSource
forall a b. (a -> b) -> a -> b
$ String -> Int -> String
forall r. PrintfType r => String -> r
printf String
"WS.Client.%.2d" Int
subId) LogLevel
lvl LogSource
s
            LogLevel -> LogSource -> LoggingT IO ()
forall (m :: * -> *).
MonadLogger m =>
LogLevel -> LogSource -> m ()
log LogLevel
LevelInfo LogSource
"Connected"
            let askClientForRoute :: LoggingT IO [LogSource]
askClientForRoute = do
                  LogSource
msg :: Text <- IO LogSource -> LoggingT IO LogSource
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO LogSource -> LoggingT IO LogSource)
-> IO LogSource -> LoggingT IO LogSource
forall a b. (a -> b) -> a -> b
$ Connection -> IO LogSource
forall a. WebSocketsData a => Connection -> IO a
WS.receiveData Connection
conn
                  -- TODO: Let non-html routes pass through.
                  let pathInfo :: [LogSource]
pathInfo = LogSource -> [LogSource]
pathInfoFromWsMsg LogSource
msg
                  LogLevel -> LogSource -> LoggingT IO ()
forall (m :: * -> *).
MonadLogger m =>
LogLevel -> LogSource -> m ()
log LogLevel
LevelDebug (LogSource -> LoggingT IO ()) -> LogSource -> LoggingT IO ()
forall a b. (a -> b) -> a -> b
$ LogSource
"<~~ " LogSource -> LogSource -> LogSource
forall a. Semigroup a => a -> a -> a
<> [LogSource] -> LogSource
forall b a. (Show a, IsString b) => a -> b
show [LogSource]
pathInfo
                  [LogSource] -> LoggingT IO [LogSource]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [LogSource]
pathInfo
                decodeRouteWithCurrentModel :: [LogSource] -> m (Maybe route)
decodeRouteWithCurrentModel [LogSource]
pathInfo = do
                  model
val <- LVar model -> m model
forall (m :: * -> *) a. MonadIO m => LVar a -> m a
LVar.get LVar model
model
                  Maybe route -> m (Maybe route)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe route -> m (Maybe route)) -> Maybe route -> m (Maybe route)
forall a b. (a -> b) -> a -> b
$ model -> [LogSource] -> Maybe route
forall model route.
Ema model route =>
model -> [LogSource] -> Maybe route
routeFromPathInfo model
val [LogSource]
pathInfo
                sendRouteHtmlToClient :: [LogSource] -> model -> m ()
sendRouteHtmlToClient [LogSource]
pathInfo model
s = do
                  [LogSource] -> m (Maybe route)
forall (m :: * -> *) route.
(MonadIO m, Ema model route) =>
[LogSource] -> m (Maybe route)
decodeRouteWithCurrentModel [LogSource]
pathInfo m (Maybe route) -> (Maybe route -> m ()) -> m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                    Maybe route
Nothing ->
                      IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Connection -> LByteString -> IO ()
forall a. WebSocketsData a => Connection -> a -> IO ()
WS.sendTextData Connection
conn (LByteString -> IO ()) -> LByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ LogSource -> LByteString
emaErrorHtmlResponse LogSource
decodeRouteNothingMsg
                    Just route
r -> do
                      case (Loc -> LogSource -> LogLevel -> LogStr -> IO ())
-> model -> route -> Asset LByteString
renderCatchingErrors Loc -> LogSource -> LogLevel -> LogStr -> IO ()
logger model
s route
r of
                        AssetStatic String
staticPath ->
                          -- HACK: Websocket client should check for REDIRECT prefix.
                          -- Not bothering with JSON to avoid having to JSON parse every HTML dump.
                          IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Connection -> LogSource -> IO ()
forall a. WebSocketsData a => Connection -> a -> IO ()
WS.sendTextData Connection
conn (LogSource -> IO ()) -> LogSource -> IO ()
forall a b. (a -> b) -> a -> b
$ LogSource
"REDIRECT " LogSource -> LogSource -> LogSource
forall a. Semigroup a => a -> a -> a
<> String -> LogSource
forall a. ToText a => a -> LogSource
toText String
staticPath
                        AssetGenerated Format
Html LByteString
html ->
                          IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Connection -> LByteString -> IO ()
forall a. WebSocketsData a => Connection -> a -> IO ()
WS.sendTextData Connection
conn (LByteString -> IO ()) -> LByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ LByteString
html LByteString -> LByteString -> LByteString
forall a. Semigroup a => a -> a -> a
<> LByteString
emaStatusHtml
                        AssetGenerated Format
Other LByteString
_s ->
                          -- HACK: Websocket client should check for REDIRECT prefix.
                          -- Not bothering with JSON to avoid having to JSON parse every HTML dump.
                          IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Connection -> LogSource -> IO ()
forall a. WebSocketsData a => Connection -> a -> IO ()
WS.sendTextData Connection
conn (LogSource -> IO ()) -> LogSource -> IO ()
forall a b. (a -> b) -> a -> b
$ LogSource
"REDIRECT " LogSource -> LogSource -> LogSource
forall a. Semigroup a => a -> a -> a
<> String -> LogSource
forall a. ToText a => a -> LogSource
toText (model -> route -> String
forall model route. Ema model route => model -> route -> String
encodeRoute model
s route
r)
                      LogLevel -> LogSource -> m ()
forall (m :: * -> *).
MonadLogger m =>
LogLevel -> LogSource -> m ()
log LogLevel
LevelDebug (LogSource -> m ()) -> LogSource -> m ()
forall a b. (a -> b) -> a -> b
$ LogSource
" ~~> " LogSource -> LogSource -> LogSource
forall a. Semigroup a => a -> a -> a
<> route -> LogSource
forall b a. (Show a, IsString b) => a -> b
show route
r
                loop :: IO a
loop = (LoggingT IO a
 -> (Loc -> LogSource -> LogLevel -> LogStr -> IO ()) -> IO a)
-> (Loc -> LogSource -> LogLevel -> LogStr -> IO ())
-> LoggingT IO a
-> IO a
forall a b c. (a -> b -> c) -> b -> a -> c
flip LoggingT IO a
-> (Loc -> LogSource -> LogLevel -> LogStr -> IO ()) -> IO a
forall (m :: * -> *) a.
LoggingT m a
-> (Loc -> LogSource -> LogLevel -> LogStr -> IO ()) -> m a
runLoggingT Loc -> LogSource -> LogLevel -> LogStr -> IO ()
logger (LoggingT IO a -> IO a) -> LoggingT IO a -> IO a
forall a b. (a -> b) -> a -> b
$ do
                  -- Notice that we @askClientForRoute@ in succession twice here.
                  -- The first route will be the route the client intends to observe
                  -- for changes on. The second route, *if* it is sent, indicates
                  -- that the client wants to *switch* to that route. This proecess
                  -- repeats ad infinitum: i.e., the third route is for observing
                  -- changes, the fourth route is for switching to, and so on.
                  [LogSource]
mWatchingRoute <- LoggingT IO [LogSource]
askClientForRoute
                  -- Listen *until* either we get a new value, or the client requests
                  -- to switch to a new route.
                  IO a -> LoggingT IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> LoggingT IO a) -> IO a -> LoggingT IO a
forall a b. (a -> b) -> a -> b
$ do
                    IO model -> IO [LogSource] -> IO (Either model [LogSource])
forall a b. IO a -> IO b -> IO (Either a b)
race (LVar model -> Int -> IO model
forall (m :: * -> *) a. MonadIO m => LVar a -> Int -> m a
LVar.listenNext LVar model
model Int
subId) (LoggingT IO [LogSource]
-> (Loc -> LogSource -> LogLevel -> LogStr -> IO ())
-> IO [LogSource]
forall (m :: * -> *) a.
LoggingT m a
-> (Loc -> LogSource -> LogLevel -> LogStr -> IO ()) -> m a
runLoggingT LoggingT IO [LogSource]
askClientForRoute Loc -> LogSource -> LogLevel -> LogStr -> IO ()
logger) IO (Either model [LogSource])
-> (Either model [LogSource] -> IO a) -> IO a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Either model [LogSource]
res -> (LoggingT IO a
 -> (Loc -> LogSource -> LogLevel -> LogStr -> IO ()) -> IO a)
-> (Loc -> LogSource -> LogLevel -> LogStr -> IO ())
-> LoggingT IO a
-> IO a
forall a b c. (a -> b -> c) -> b -> a -> c
flip LoggingT IO a
-> (Loc -> LogSource -> LogLevel -> LogStr -> IO ()) -> IO a
forall (m :: * -> *) a.
LoggingT m a
-> (Loc -> LogSource -> LogLevel -> LogStr -> IO ()) -> m a
runLoggingT Loc -> LogSource -> LogLevel -> LogStr -> IO ()
logger (LoggingT IO a -> IO a) -> LoggingT IO a -> IO a
forall a b. (a -> b) -> a -> b
$ case Either model [LogSource]
res of
                      Left model
newModel -> do
                        -- The page the user is currently viewing has changed. Send
                        -- the new HTML to them.
                        [LogSource] -> model -> LoggingT IO ()
forall (m :: * -> *).
(MonadIO m, MonadLogger m) =>
[LogSource] -> model -> m ()
sendRouteHtmlToClient [LogSource]
mWatchingRoute model
newModel
                        IO a -> LoggingT IO a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift IO a
loop
                      Right [LogSource]
mNextRoute -> do
                        -- The user clicked on a route link; send them the HTML for
                        -- that route this time, ignoring what we are watching
                        -- currently (we expect the user to initiate a watch route
                        -- request immediately following this).
                        [LogSource] -> model -> LoggingT IO ()
forall (m :: * -> *).
(MonadIO m, MonadLogger m) =>
[LogSource] -> model -> m ()
sendRouteHtmlToClient [LogSource]
mNextRoute (model -> LoggingT IO ()) -> LoggingT IO model -> LoggingT IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< LVar model -> LoggingT IO model
forall (m :: * -> *) a. MonadIO m => LVar a -> m a
LVar.get LVar model
model
                        IO a -> LoggingT IO a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift IO a
loop
            IO (Either ConnectionException ())
-> LoggingT IO (Either ConnectionException ())
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO (Either ConnectionException ())
forall e a. Exception e => IO a -> IO (Either e a)
try IO ()
forall a. IO a
loop) LoggingT IO (Either ConnectionException ())
-> (Either ConnectionException () -> LoggingT IO ())
-> LoggingT IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
              Right () -> () -> LoggingT IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
              Left (ConnectionException
connExc :: ConnectionException) -> do
                case ConnectionException
connExc of
                  WS.CloseRequest Word16
_ (LByteString -> LogSource
forall a b. ConvertUtf8 a b => b -> a
decodeUtf8 -> LogSource
reason) ->
                    LogLevel -> LogSource -> LoggingT IO ()
forall (m :: * -> *).
MonadLogger m =>
LogLevel -> LogSource -> m ()
log LogLevel
LevelInfo (LogSource -> LoggingT IO ()) -> LogSource -> LoggingT IO ()
forall a b. (a -> b) -> a -> b
$ LogSource
"Closing websocket connection (reason: " LogSource -> LogSource -> LogSource
forall a. Semigroup a => a -> a -> a
<> LogSource
reason LogSource -> LogSource -> LogSource
forall a. Semigroup a => a -> a -> a
<> LogSource
")"
                  ConnectionException
_ ->
                    LogLevel -> LogSource -> LoggingT IO ()
forall (m :: * -> *).
MonadLogger m =>
LogLevel -> LogSource -> m ()
log LogLevel
LevelError (LogSource -> LoggingT IO ()) -> LogSource -> LoggingT IO ()
forall a b. (a -> b) -> a -> b
$ LogSource
"Websocket error: " LogSource -> LogSource -> LogSource
forall a. Semigroup a => a -> a -> a
<> ConnectionException -> LogSource
forall b a. (Show a, IsString b) => a -> b
show ConnectionException
connExc
                LVar model -> Int -> LoggingT IO ()
forall (m :: * -> *) a. MonadIO m => LVar a -> Int -> m ()
LVar.removeListener LVar model
model Int
subId
    assetsMiddleware :: Middleware
assetsMiddleware =
      Middleware
Static.static
    httpApp :: (Loc -> LogSource -> LogLevel -> LogStr -> IO ())
-> Request -> (Response -> IO a) -> m a
httpApp Loc -> LogSource -> LogLevel -> LogStr -> IO ()
logger Request
req Response -> IO a
f = do
      (LoggingT m a
 -> (Loc -> LogSource -> LogLevel -> LogStr -> IO ()) -> m a)
-> (Loc -> LogSource -> LogLevel -> LogStr -> IO ())
-> LoggingT m a
-> m a
forall a b c. (a -> b -> c) -> b -> a -> c
flip LoggingT m a
-> (Loc -> LogSource -> LogLevel -> LogStr -> IO ()) -> m a
forall (m :: * -> *) a.
LoggingT m a
-> (Loc -> LogSource -> LogLevel -> LogStr -> IO ()) -> m a
runLoggingT Loc -> LogSource -> LogLevel -> LogStr -> IO ()
logger (LoggingT m a -> m a) -> LoggingT m a -> m a
forall a b. (a -> b) -> a -> b
$ do
        model
val <- LVar model -> LoggingT m model
forall (m :: * -> *) a. MonadIO m => LVar a -> m a
LVar.get LVar model
model
        let path :: [LogSource]
path = Request -> [LogSource]
Wai.pathInfo Request
req
            mr :: Maybe route
mr = model -> [LogSource] -> Maybe route
forall model route.
Ema model route =>
model -> [LogSource] -> Maybe route
routeFromPathInfo model
val [LogSource]
path
        LogSource -> LogSource -> LoggingT m ()
forall (m :: * -> *).
MonadLogger m =>
LogSource -> LogSource -> m ()
logInfoNS LogSource
"HTTP" (LogSource -> LoggingT m ()) -> LogSource -> LoggingT m ()
forall a b. (a -> b) -> a -> b
$ [LogSource] -> LogSource
forall b a. (Show a, IsString b) => a -> b
show [LogSource]
path LogSource -> LogSource -> LogSource
forall a. Semigroup a => a -> a -> a
<> LogSource
" as " LogSource -> LogSource -> LogSource
forall a. Semigroup a => a -> a -> a
<> Maybe route -> LogSource
forall b a. (Show a, IsString b) => a -> b
show Maybe route
mr
        case Maybe route
mr of
          Maybe route
Nothing ->
            IO a -> LoggingT m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> LoggingT m a) -> IO a -> LoggingT m a
forall a b. (a -> b) -> a -> b
$ Response -> IO a
f (Response -> IO a) -> Response -> IO a
forall a b. (a -> b) -> a -> b
$ Status -> ResponseHeaders -> LByteString -> Response
Wai.responseLBS Status
H.status404 [(HeaderName
H.hContentType, ByteString
"text/plain")] (LByteString -> Response) -> LByteString -> Response
forall a b. (a -> b) -> a -> b
$ LogSource -> LByteString
forall a b. ConvertUtf8 a b => a -> b
encodeUtf8 LogSource
decodeRouteNothingMsg
          Just route
r -> do
            case (Loc -> LogSource -> LogLevel -> LogStr -> IO ())
-> model -> route -> Asset LByteString
renderCatchingErrors Loc -> LogSource -> LogLevel -> LogStr -> IO ()
logger model
val route
r of
              AssetStatic String
staticPath -> do
                let mimeType :: ByteString
mimeType = String -> ByteString
Static.getMimeType String
staticPath
                IO a -> LoggingT m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> LoggingT m a) -> IO a -> LoggingT m a
forall a b. (a -> b) -> a -> b
$ Response -> IO a
f (Response -> IO a) -> Response -> IO a
forall a b. (a -> b) -> a -> b
$ Status -> ResponseHeaders -> String -> Maybe FilePart -> Response
Wai.responseFile Status
H.status200 [(HeaderName
H.hContentType, ByteString
mimeType)] String
staticPath Maybe FilePart
forall a. Maybe a
Nothing
              AssetGenerated Format
Html LByteString
html -> do
                let s :: LByteString
s = LByteString
html LByteString -> LByteString -> LByteString
forall a. Semigroup a => a -> a -> a
<> LByteString
emaStatusHtml LByteString -> LByteString -> LByteString
forall a. Semigroup a => a -> a -> a
<> LByteString
wsClientShim
                IO a -> LoggingT m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> LoggingT m a) -> IO a -> LoggingT m a
forall a b. (a -> b) -> a -> b
$ Response -> IO a
f (Response -> IO a) -> Response -> IO a
forall a b. (a -> b) -> a -> b
$ Status -> ResponseHeaders -> LByteString -> Response
Wai.responseLBS Status
H.status200 [(HeaderName
H.hContentType, ByteString
"text/html")] LByteString
s
              AssetGenerated Format
Other LByteString
s -> do
                let mimeType :: ByteString
mimeType = String -> ByteString
Static.getMimeType (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ model -> route -> String
forall model route. Ema model route => model -> route -> String
encodeRoute model
val route
r
                IO a -> LoggingT m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> LoggingT m a) -> IO a -> LoggingT m a
forall a b. (a -> b) -> a -> b
$ Response -> IO a
f (Response -> IO a) -> Response -> IO a
forall a b. (a -> b) -> a -> b
$ Status -> ResponseHeaders -> LByteString -> Response
Wai.responseLBS Status
H.status200 [(HeaderName
H.hContentType, ByteString
mimeType)] LByteString
s
    renderCatchingErrors :: (Loc -> LogSource -> LogLevel -> LogStr -> IO ())
-> model -> route -> Asset LByteString
renderCatchingErrors Loc -> LogSource -> LogLevel -> LogStr -> IO ()
logger model
m route
r =
      Asset LByteString
-> (SomeException -> Asset LByteString) -> Asset LByteString
forall e a. Exception e => a -> (e -> a) -> a
unsafeCatch (model -> route -> Asset LByteString
render model
m route
r) ((SomeException -> Asset LByteString) -> Asset LByteString)
-> (SomeException -> Asset LByteString) -> Asset LByteString
forall a b. (a -> b) -> a -> b
$ \(SomeException
err :: SomeException) ->
        IO (Asset LByteString) -> Asset LByteString
forall a. IO a -> a
unsafePerformIO (IO (Asset LByteString) -> Asset LByteString)
-> IO (Asset LByteString) -> Asset LByteString
forall a b. (a -> b) -> a -> b
$ do
          -- Log the error first.
          (LoggingT IO ()
 -> (Loc -> LogSource -> LogLevel -> LogStr -> IO ()) -> IO ())
-> (Loc -> LogSource -> LogLevel -> LogStr -> IO ())
-> LoggingT IO ()
-> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip LoggingT IO ()
-> (Loc -> LogSource -> LogLevel -> LogStr -> IO ()) -> IO ()
forall (m :: * -> *) a.
LoggingT m a
-> (Loc -> LogSource -> LogLevel -> LogStr -> IO ()) -> m a
runLoggingT Loc -> LogSource -> LogLevel -> LogStr -> IO ()
logger (LoggingT IO () -> IO ()) -> LoggingT IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ LogSource -> LogSource -> LoggingT IO ()
forall (m :: * -> *).
MonadLogger m =>
LogSource -> LogSource -> m ()
logErrorNS LogSource
"App" (LogSource -> LoggingT IO ()) -> LogSource -> LoggingT IO ()
forall a b. (a -> b) -> a -> b
$ SomeException -> LogSource
forall b a. (Show a, IsString b) => a -> b
show @Text SomeException
err
          Asset LByteString -> IO (Asset LByteString)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Asset LByteString -> IO (Asset LByteString))
-> Asset LByteString -> IO (Asset LByteString)
forall a b. (a -> b) -> a -> b
$
            Format -> LByteString -> Asset LByteString
forall a. Format -> a -> Asset a
AssetGenerated Format
Html (LByteString -> Asset LByteString)
-> (LogSource -> LByteString) -> LogSource -> Asset LByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LogSource -> LByteString
emaErrorHtml (LogSource -> Asset LByteString) -> LogSource -> Asset LByteString
forall a b. (a -> b) -> a -> b
$
              SomeException -> LogSource
forall b a. (Show a, IsString b) => a -> b
show @Text SomeException
err
    routeFromPathInfo :: model -> [LogSource] -> Maybe route
routeFromPathInfo model
m =
      model -> LogSource -> Maybe route
forall model route.
Ema model route =>
model -> LogSource -> Maybe route
decodeUrlRoute model
m (LogSource -> Maybe route)
-> ([LogSource] -> LogSource) -> [LogSource] -> Maybe route
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LogSource -> [LogSource] -> LogSource
T.intercalate LogSource
"/"
    -- TODO: It would be good have this also get us the stack trace.
    unsafeCatch :: Exception e => a -> (e -> a) -> a
    unsafeCatch :: a -> (e -> a) -> a
unsafeCatch a
x e -> a
f = IO a -> a
forall a. IO a -> a
unsafePerformIO (IO a -> a) -> IO a -> a
forall a b. (a -> b) -> a -> b
$ IO a -> (e -> IO a) -> IO a
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
catch (a -> IO a -> IO a
seq a
x (IO a -> IO a) -> IO a -> IO a
forall a b. (a -> b) -> a -> b
$ a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x) (a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> IO a) -> (e -> a) -> e -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. e -> a
f)

-- | A basic error response for displaying in the browser
emaErrorHtmlResponse :: Text -> LByteString
emaErrorHtmlResponse :: LogSource -> LByteString
emaErrorHtmlResponse LogSource
err =
  LogSource -> LByteString
emaErrorHtml LogSource
err LByteString -> LByteString -> LByteString
forall a. Semigroup a => a -> a -> a
<> LByteString
emaStatusHtml

emaErrorHtml :: Text -> LByteString
emaErrorHtml :: LogSource -> LByteString
emaErrorHtml LogSource
s =
  LogSource -> LByteString
forall a b. ConvertUtf8 a b => a -> b
encodeUtf8 (LogSource -> LByteString) -> LogSource -> LByteString
forall a b. (a -> b) -> a -> b
$
    LogSource
"<html><head><meta charset=\"UTF-8\"></head><body><h1>Ema App threw an exception</h1><pre style=\"border: 1px solid; padding: 1em 1em 1em 1em;\">"
      LogSource -> LogSource -> LogSource
forall a. Semigroup a => a -> a -> a
<> LogSource
s
      LogSource -> LogSource -> LogSource
forall a. Semigroup a => a -> a -> a
<> LogSource
"</pre><p>Once you fix the source of the error, this page will automatically refresh.</body>"

-- | Return the equivalent of WAI's @pathInfo@, from the raw path string
-- (`document.location.pathname`) the browser sends us.
pathInfoFromWsMsg :: Text -> [Text]
pathInfoFromWsMsg :: LogSource -> [LogSource]
pathInfoFromWsMsg =
  (LogSource -> Bool) -> [LogSource] -> [LogSource]
forall a. (a -> Bool) -> [a] -> [a]
filter (LogSource -> LogSource -> Bool
forall a. Eq a => a -> a -> Bool
/= LogSource
"") ([LogSource] -> [LogSource])
-> (LogSource -> [LogSource]) -> LogSource -> [LogSource]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LogSource -> LogSource -> [LogSource]
T.splitOn LogSource
"/" (LogSource -> [LogSource])
-> (LogSource -> LogSource) -> LogSource -> [LogSource]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> LogSource -> LogSource
T.drop Int
1

-- | Decode a URL path into a route
--
-- This function is used only in live server.
decodeUrlRoute :: forall model route. Ema model route => model -> Text -> Maybe route
decodeUrlRoute :: model -> LogSource -> Maybe route
decodeUrlRoute model
model (LogSource -> String
forall a. ToString a => a -> String
toString -> String
s) = do
  model -> String -> Maybe route
forall model route.
Ema model route =>
model -> String -> Maybe route
decodeRoute @model @route model
model String
s
    Maybe route -> Maybe route -> Maybe route
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> model -> String -> Maybe route
forall model route.
Ema model route =>
model -> String -> Maybe route
decodeRoute @model @route model
model (String
s String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
".html")
    Maybe route -> Maybe route -> Maybe route
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> model -> String -> Maybe route
forall model route.
Ema model route =>
model -> String -> Maybe route
decodeRoute @model @route model
model (String
s String -> String -> String
</> String
"index.html")

decodeRouteNothingMsg :: Text
decodeRouteNothingMsg :: LogSource
decodeRouteNothingMsg = LogSource
"Ema: 404 (decodeRoute returned Nothing)"

-- Browser-side JavaScript code for interacting with the Haskell server
wsClientShim :: LByteString
wsClientShim :: LByteString
wsClientShim =
  LogSource -> LByteString
forall a b. ConvertUtf8 a b => a -> b
encodeUtf8
    [text|
        <script type="module" src="https://cdn.jsdelivr.net/npm/morphdom@2.6.1/dist/morphdom-umd.min.js"></script>

        <script type="module">

        function htmlToElem(html) {
          let temp = document.createElement('template');
          html = html.trim(); // Never return a space text node as a result
          temp.innerHTML = html;
          return temp.content.firstChild;
        };

        // Unlike setInnerHtml, this patches the Dom in place
        function setHtml(elm, html) {
          var htmlElem = htmlToElem(html);
          morphdom(elm, html);
          // Re-add <script> tags, because just DOM diff applying is not enough.
          reloadScripts(elm);
        };

        // FIXME: This doesn't reliably work across all JS.
        // See also the HACK below in one of the invocations.
        function reloadScripts(elm) {
          Array.from(elm.querySelectorAll("script")).forEach(oldScript => {
            const newScript = document.createElement("script");
            Array.from(oldScript.attributes)
              .forEach(attr => newScript.setAttribute(attr.name, attr.value));
            newScript.appendChild(document.createTextNode(oldScript.innerHTML));
            oldScript.parentNode.replaceChild(newScript, oldScript);
          });
        };

        // Ema Status indicator
        const messages = {
          connected: "Connected",
          reloading: "Reloading",
          connecting: "Connecting to the server",
          disconnected: "Disconnected - try reloading the window"
        };
        function setIndicators(connected, reloading, connecting, disconnected) {
          const is = { connected, reloading, connecting, disconnected }

          for (const i in is) {
            document.getElementById(`ema-$${i}`).style.display =
              is[i] ? "block" : "none"
            if(is[i])
              document.getElementById('ema-message').innerText = messages[i]
          };
          document.getElementById("ema-indicator").style.display = "block";
        };
        window.connected    = () => setIndicators(true,  false, false, false)
        window.reloading    = () => setIndicators(false, true,  false, false)
        window.connecting   = () => setIndicators(false, false, true,  false)
        window.disconnected = () => setIndicators(false, false, false, true)
        window.hideIndicator = () => {
          document.getElementById("ema-indicator").style.display = "none";
        };

        // Base URL path - for when the ema site isn't served at "/"
        const baseHref = document.getElementsByTagName("base")[0]?.href;
        const basePath = baseHref ? new URL(baseHref).pathname : "/";

        // Use TLS for websocket iff the current page is also served with TLS
        const wsProto = window.location.protocol === "https:" ? "wss://" : "ws://";
        const wsUrl = wsProto + window.location.host + basePath;

        // WebSocket logic: watching for server changes & route switching
        function init(reconnecting) {
          // The route current DOM is displaying
          let routeVisible = document.location.pathname;

          const verb = reconnecting ? "Reopening" : "Opening";
          console.log(`ema: $${verb} conn $${wsUrl} ...`);
          window.connecting();
          let ws = new WebSocket(wsUrl);

          function sendObservePath(path) {
            const relPath = path.startsWith(basePath) ? path.slice(basePath.length - 1) : path;
            console.debug(`ema: requesting $${relPath}`);
            ws.send(relPath);
          }

          // Call this, then the server will send update *once*. Call again for
          // continous monitoring.
          function watchCurrentRoute() {
            console.log(`ema: ⏿ Observing changes to $${document.location.pathname}`);
            sendObservePath(document.location.pathname);
          };

          function switchRoute(path) {
             console.log(`ema: → Switching to $${path}`);
             sendObservePath(path);
          }

          function handleRouteClicks(e) {
              const origin = e.target.closest("a");
              if (origin) {
                if (window.location.host === origin.host && origin.getAttribute("target") != "_blank") {
                  window.history.pushState({}, "", origin.pathname);
                  switchRoute(origin.pathname);
                  e.preventDefault();
                };
              }
            };
          // Intercept route click events, and ask server for its HTML whilst
          // managing history state.
          window.addEventListener(`click`, handleRouteClicks);

          ws.onopen = () => {
            console.log(`ema: ... connected!`);
            // window.connected();
            window.hideIndicator();
            if (!reconnecting) {
              // HACK: We have to reload <script>'s here on initial page load
              // here, so as to make Twind continue to function on the *next*
              // route change. This is not a problem with *subsequent* (ie. 2nd
              // or latter) route clicks, because those have already called
              // reloadScripts at least once.
              reloadScripts(document.documentElement);
            };
            watchCurrentRoute();
          };

          ws.onclose = () => {
            console.log("ema: reconnecting ..");
            window.removeEventListener(`click`, handleRouteClicks);
            window.reloading();
            // Reconnect after as small a time is possible, then retry again. 
            // ghcid can take 1s or more to reboot. So ideally we need an
            // exponential retry logic.
            // 
            // Note that a slow delay (200ms) may often cause websocket
            // connection error (ghcid hasn't rebooted yet), which cannot be
            // avoided as it is impossible to trap this error and handle it.
            // You'll see a big ugly error in the console.
            setTimeout(function () {init(true);}, 400);
          };

          ws.onmessage = evt => {
            if (evt.data.startsWith("REDIRECT ")) {
              console.log("ema: redirect");
              document.location.href = evt.data.slice("REDIRECT ".length);
            } else {
              console.log("ema: ✍ Patching DOM");
              setHtml(document.documentElement, evt.data);
              if (routeVisible != document.location.pathname) {
                // This is a new route switch; scroll up.
                window.scrollTo({ top: 0});
                routeVisible = document.location.pathname;
              } 
              watchCurrentRoute();
            };
          };
          window.onbeforeunload = evt => { ws.close(); };
          window.onpagehide = evt => { ws.close(); };

          // When the user clicks the back button, resume watching the URL in
          // the addressback, which has the effect of loading it immediately.
          window.onpopstate = function(e) {
            watchCurrentRoute();
          };
        };
        
        window.onpageshow = function () { init(false) };
        </script>
    |]

emaStatusHtml :: LByteString
emaStatusHtml :: LByteString
emaStatusHtml =
  LogSource -> LByteString
forall a b. ConvertUtf8 a b => a -> b
encodeUtf8
    [text|
      <div class="absolute top-0 left-0 p-2" style="display: none;" id="ema-indicator">
        <div
          class="
            flex overflow-hidden items-center p-2 text-xs gap-2
            h-8 border-2 border-gray-200 bg-white rounded-full shadow-lg
            transition-[width,height] duration-500 ease-in-out w-8 hover:w-full
          "
          id="ema-status"
          title="Ema Status"
        >
          <div
            hidden
            class="flex-none w-3 h-3 bg-green-600 rounded-full"
            id="ema-connected"
          ></div>
          <div
            hidden
            class="flex-none w-3 h-3 rounded-full animate-spin bg-gradient-to-r from-blue-300 to-blue-600"
            id="ema-reloading"
          ></div>
          <div
            hidden
            class="flex-none w-3 h-3 bg-yellow-500 rounded-full"
            id="ema-connecting"
          >
            <div
              class="flex-none w-3 h-3 bg-yellow-500 rounded-full animate-ping"
            ></div>
          </div>
          <div
            hidden
            class="flex-none w-3 h-3 bg-red-500 rounded-full"
            id="ema-disconnected"
          ></div>
          <p class="whitespace-nowrap" id="ema-message"></p>
        </div>
      </div>
  |]