{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}

module Ema.Server where

import Control.Concurrent.Async (race)
import Control.Exception (try)
import Control.Monad.Logger
import Data.FileEmbed
import Data.LVar (LVar)
import Data.LVar qualified as LVar
import Data.Text qualified as T
import Ema.Asset (
  Asset (AssetGenerated, AssetStatic),
  Format (Html, Other),
 )
import Ema.CLI (Host (unHost))
import Ema.Route.Class (IsRoute (RouteModel, routePrism))
import Ema.Route.Prism (
  checkRoutePrismGivenFilePath,
  fromPrism_,
 )
import Ema.Route.Url (urlToFilePath)
import Ema.Site (EmaSite (siteOutput), EmaStaticSite)
import NeatInterpolation (text)
import Network.HTTP.Types qualified as H
import Network.Wai qualified as Wai
import Network.Wai.Handler.Warp (Port)
import Network.Wai.Handler.Warp qualified as Warp
import Network.Wai.Handler.WebSockets qualified as WaiWs
import Network.Wai.Middleware.Static qualified as Static
import Network.WebSockets (ConnectionException)
import Network.WebSockets qualified as WS
import Optics.Core (review)
import Text.Printf (printf)
import UnliftIO (MonadUnliftIO)
import UnliftIO.Concurrent (threadDelay)
import UnliftIO.Exception (catch)

runServerWithWebSocketHotReload ::
  forall r m.
  ( Show r
  , MonadIO m
  , MonadUnliftIO m
  , MonadLoggerIO m
  , Eq r
  , IsRoute r
  , EmaStaticSite r
  ) =>
  Host ->
  Maybe Port ->
  LVar (RouteModel r) ->
  m ()
runServerWithWebSocketHotReload :: forall r (m :: Type -> Type).
(Show r, MonadIO m, MonadUnliftIO m, MonadLoggerIO m, Eq r,
 IsRoute r, EmaStaticSite r) =>
Host -> Maybe Port -> LVar (RouteModel r) -> m ()
runServerWithWebSocketHotReload Host
host Maybe Port
mport LVar (RouteModel r)
model = do
  Loc -> Text -> LogLevel -> LogStr -> IO ()
logger <- forall (m :: Type -> Type).
MonadLoggerIO m =>
m (Loc -> Text -> LogLevel -> LogStr -> IO ())
askLoggerIO
  let runM :: LoggingT IO () -> IO ()
runM = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (m :: Type -> Type) a.
LoggingT m a -> (Loc -> Text -> LogLevel -> LogStr -> IO ()) -> m a
runLoggingT Loc -> Text -> LogLevel -> LogStr -> IO ()
logger
      settings :: Settings
settings =
        Settings
Warp.defaultSettings
          forall a b. a -> (a -> b) -> b
& HostPreference -> Settings -> Settings
Warp.setHost (forall a. IsString a => String -> a
fromString forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ToString a => a -> String
toString forall b c a. (b -> c) -> (a -> b) -> a -> c
. Host -> Text
unHost forall a b. (a -> b) -> a -> b
$ Host
host)
      app :: Application
app =
        ConnectionOptions -> ServerApp -> Application -> Application
WaiWs.websocketsOr
          ConnectionOptions
WS.defaultConnectionOptions
          (LoggingT IO () -> IO ()
runM forall b c a. (b -> c) -> (a -> b) -> a -> c
. PendingConnection -> LoggingT IO ()
wsApp)
          ((Loc -> Text -> LogLevel -> LogStr -> IO ()) -> Application
httpApp Loc -> Text -> LogLevel -> LogStr -> IO ()
logger)
      banner :: Port -> LoggingT IO ()
banner Port
port = do
        forall (m :: Type -> Type). MonadLogger m => Text -> Text -> m ()
logInfoNS Text
"ema" Text
"==============================================="
        forall (m :: Type -> Type). MonadLogger m => Text -> Text -> m ()
logInfoNS Text
"ema" forall a b. (a -> b) -> a -> b
$ Text
"Ema live server RUNNING: http://" forall a. Semigroup a => a -> a -> a
<> Host -> Text
unHost Host
host forall a. Semigroup a => a -> a -> a
<> Text
":" forall a. Semigroup a => a -> a -> a
<> forall b a. (Show a, IsString b) => a -> b
show Port
port
        forall (m :: Type -> Type). MonadLogger m => Text -> Text -> m ()
logInfoNS Text
"ema" Text
"==============================================="
  forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a.
Settings -> Maybe Port -> (Port -> IO a) -> Application -> IO ()
warpRunSettings Settings
settings Maybe Port
mport (LoggingT IO () -> IO ()
runM forall b c a. (b -> c) -> (a -> b) -> a -> c
. Port -> LoggingT IO ()
banner) Application
app
  where
    enc :: RouteModel r -> Prism_ String r
enc = forall r. IsRoute r => RouteModel r -> Prism_ String r
routePrism @r
    -- Like Warp.runSettings but takes *optional* port. When no port is set, a
    -- free (random) port is used.
    warpRunSettings :: Warp.Settings -> Maybe Port -> (Port -> IO a) -> Wai.Application -> IO ()
    warpRunSettings :: forall a.
Settings -> Maybe Port -> (Port -> IO a) -> Application -> IO ()
warpRunSettings Settings
settings Maybe Port
mPort Port -> IO a
banner Application
app = do
      case Maybe Port
mPort of
        Maybe Port
Nothing ->
          forall a. Settings -> IO Application -> (Port -> IO a) -> IO a
Warp.withApplicationSettings Settings
settings (forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Application
app) forall a b. (a -> b) -> a -> b
$ \Port
port -> do
            forall (f :: Type -> Type) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ Port -> IO a
banner Port
port
            forall (m :: Type -> Type). MonadIO m => Port -> m ()
threadDelay forall a. Bounded a => a
maxBound
        Just Port
port -> do
          forall (f :: Type -> Type) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ Port -> IO a
banner Port
port
          Settings -> Application -> IO ()
Warp.runSettings (Settings
settings forall a b. a -> (a -> b) -> b
& Port -> Settings -> Settings
Warp.setPort Port
port) Application
app
    wsApp :: PendingConnection -> LoggingT IO ()
wsApp PendingConnection
pendingConn = do
      Connection
conn :: WS.Connection <- forall (t :: (Type -> Type) -> Type -> Type) (m :: Type -> Type) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ PendingConnection -> IO Connection
WS.acceptRequest PendingConnection
pendingConn
      Loc -> Text -> LogLevel -> LogStr -> IO ()
logger <- forall (m :: Type -> Type).
MonadLoggerIO m =>
m (Loc -> Text -> LogLevel -> LogStr -> IO ())
askLoggerIO
      forall (t :: (Type -> Type) -> Type -> Type) (m :: Type -> Type) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$
        forall a. Connection -> Port -> IO () -> IO a -> IO a
WS.withPingThread Connection
conn Port
30 forall (f :: Type -> Type). Applicative f => f ()
pass forall a b. (a -> b) -> a -> b
$
          forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (m :: Type -> Type) a.
LoggingT m a -> (Loc -> Text -> LogLevel -> LogStr -> IO ()) -> m a
runLoggingT Loc -> Text -> LogLevel -> LogStr -> IO ()
logger forall a b. (a -> b) -> a -> b
$ do
            Port
subId <- forall (m :: Type -> Type) a. MonadIO m => LVar a -> m Port
LVar.addListener LVar (RouteModel r)
model
            let log :: LogLevel -> Text -> LoggingT IO ()
log LogLevel
lvl (Text
s :: Text) =
                  forall (m :: Type -> Type) msg.
(MonadLogger m, ToLogStr msg) =>
Text -> LogLevel -> msg -> m ()
logWithoutLoc (forall a. ToText a => a -> Text
toText @String forall a b. (a -> b) -> a -> b
$ forall r. PrintfType r => String -> r
printf String
"ema.ws.%.2d" Port
subId) LogLevel
lvl Text
s
            LogLevel -> Text -> LoggingT IO ()
log LogLevel
LevelInfo Text
"Connected"
            let askClientForRoute :: LoggingT IO [Text]
askClientForRoute = do
                  Text
msg :: Text <- forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. WebSocketsData a => Connection -> IO a
WS.receiveData Connection
conn
                  -- TODO: Let non-html routes pass through.
                  let pathInfo :: [Text]
pathInfo = Text -> [Text]
pathInfoFromWsMsg Text
msg
                  LogLevel -> Text -> LoggingT IO ()
log LogLevel
LevelDebug forall a b. (a -> b) -> a -> b
$ Text
"<~~ " forall a. Semigroup a => a -> a -> a
<> forall b a. (Show a, IsString b) => a -> b
show [Text]
pathInfo
                  forall (f :: Type -> Type) a. Applicative f => a -> f a
pure [Text]
pathInfo
                decodeRouteWithCurrentModel :: [Text] -> LoggingT IO (Either (BadRouteEncoding r) (Maybe r))
decodeRouteWithCurrentModel [Text]
pathInfo = do
                  RouteModel r
val <- forall (m :: Type -> Type) a. MonadIO m => LVar a -> m a
LVar.get LVar (RouteModel r)
model
                  forall (f :: Type -> Type) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ RouteModel r -> [Text] -> Either (BadRouteEncoding r) (Maybe r)
routeFromPathInfo RouteModel r
val [Text]
pathInfo
                sendRouteHtmlToClient :: [Text] -> RouteModel r -> LoggingT IO ()
sendRouteHtmlToClient [Text]
pathInfo RouteModel r
s = do
                  [Text] -> LoggingT IO (Either (BadRouteEncoding r) (Maybe r))
decodeRouteWithCurrentModel [Text]
pathInfo forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                    Left BadRouteEncoding r
err -> do
                      LogLevel -> Text -> LoggingT IO ()
log LogLevel
LevelError forall a b. (a -> b) -> a -> b
$ forall r. Show r => BadRouteEncoding r -> Text
badRouteEncodingMsg BadRouteEncoding r
err
                      forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. WebSocketsData a => Connection -> a -> IO ()
WS.sendTextData Connection
conn forall a b. (a -> b) -> a -> b
$ Text -> LByteString
emaErrorHtmlResponse forall a b. (a -> b) -> a -> b
$ forall r. Show r => BadRouteEncoding r -> Text
badRouteEncodingMsg BadRouteEncoding r
err
                    Right Maybe r
Nothing ->
                      forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. WebSocketsData a => Connection -> a -> IO ()
WS.sendTextData Connection
conn forall a b. (a -> b) -> a -> b
$ Text -> LByteString
emaErrorHtmlResponse Text
decodeRouteNothingMsg
                    Right (Just r
r) -> do
                      RouteModel r -> r -> LoggingT IO (Asset LByteString)
renderCatchingErrors RouteModel r
s r
r forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                        AssetGenerated Format
Html LByteString
html ->
                          forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. WebSocketsData a => Connection -> a -> IO ()
WS.sendTextData Connection
conn forall a b. (a -> b) -> a -> b
$ LByteString
html forall a. Semigroup a => a -> a -> a
<> forall l s. LazyStrict l s => s -> l
toLazy ByteString
wsClientHtml
                        -- HACK: We expect the websocket client should check for REDIRECT prefix.
                        -- Not bothering with JSON response to avoid having to JSON parse every HTML dump.
                        AssetStatic String
_staticPath ->
                          forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. WebSocketsData a => Connection -> a -> IO ()
WS.sendTextData Connection
conn forall a b. (a -> b) -> a -> b
$ Text
"REDIRECT " forall a. Semigroup a => a -> a -> a
<> forall a. ToText a => a -> Text
toText (forall k (is :: IxList) t b.
Is k A_Review =>
Optic' k is t b -> b -> t
review (forall s a. Prism_ s a -> Prism' s a
fromPrism_ forall a b. (a -> b) -> a -> b
$ RouteModel r -> Prism_ String r
enc RouteModel r
s) r
r)
                        AssetGenerated Format
Other LByteString
_s ->
                          forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. WebSocketsData a => Connection -> a -> IO ()
WS.sendTextData Connection
conn forall a b. (a -> b) -> a -> b
$ Text
"REDIRECT " forall a. Semigroup a => a -> a -> a
<> forall a. ToText a => a -> Text
toText (forall k (is :: IxList) t b.
Is k A_Review =>
Optic' k is t b -> b -> t
review (forall s a. Prism_ s a -> Prism' s a
fromPrism_ forall a b. (a -> b) -> a -> b
$ RouteModel r -> Prism_ String r
enc RouteModel r
s) r
r)
                      LogLevel -> Text -> LoggingT IO ()
log LogLevel
LevelDebug forall a b. (a -> b) -> a -> b
$ Text
" ~~> " forall a. Semigroup a => a -> a -> a
<> forall b a. (Show a, IsString b) => a -> b
show r
r
                loop :: IO ()
loop = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (m :: Type -> Type) a.
LoggingT m a -> (Loc -> Text -> LogLevel -> LogStr -> IO ()) -> m a
runLoggingT Loc -> Text -> LogLevel -> LogStr -> IO ()
logger 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.
                  [Text]
mWatchingRoute <- LoggingT IO [Text]
askClientForRoute
                  -- Listen *until* either we get a new value, or the client requests
                  -- to switch to a new route.
                  forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
                    forall a b. IO a -> IO b -> IO (Either a b)
race (forall (m :: Type -> Type) a. MonadIO m => LVar a -> Port -> m a
LVar.listenNext LVar (RouteModel r)
model Port
subId) (forall (m :: Type -> Type) a.
LoggingT m a -> (Loc -> Text -> LogLevel -> LogStr -> IO ()) -> m a
runLoggingT LoggingT IO [Text]
askClientForRoute Loc -> Text -> LogLevel -> LogStr -> IO ()
logger) forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Either (RouteModel r) [Text]
res -> forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (m :: Type -> Type) a.
LoggingT m a -> (Loc -> Text -> LogLevel -> LogStr -> IO ()) -> m a
runLoggingT Loc -> Text -> LogLevel -> LogStr -> IO ()
logger forall a b. (a -> b) -> a -> b
$ case Either (RouteModel r) [Text]
res of
                      Left RouteModel r
newModel -> do
                        -- The page the user is currently viewing has changed. Send
                        -- the new HTML to them.
                        [Text] -> RouteModel r -> LoggingT IO ()
sendRouteHtmlToClient [Text]
mWatchingRoute RouteModel r
newModel
                        forall (t :: (Type -> Type) -> Type -> Type) (m :: Type -> Type) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift IO ()
loop
                      Right [Text]
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).
                        [Text] -> RouteModel r -> LoggingT IO ()
sendRouteHtmlToClient [Text]
mNextRoute forall (m :: Type -> Type) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: Type -> Type) a. MonadIO m => LVar a -> m a
LVar.get LVar (RouteModel r)
model
                        forall (t :: (Type -> Type) -> Type -> Type) (m :: Type -> Type) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift IO ()
loop
            forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (forall e a. Exception e => IO a -> IO (Either e a)
try IO ()
loop) forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
              Right () -> forall (f :: Type -> Type). Applicative f => f ()
pass
              Left (ConnectionException
connExc :: ConnectionException) -> do
                case ConnectionException
connExc of
                  WS.CloseRequest Word16
_ (forall a b. ConvertUtf8 a b => b -> a
decodeUtf8 -> Text
reason) ->
                    LogLevel -> Text -> LoggingT IO ()
log LogLevel
LevelInfo forall a b. (a -> b) -> a -> b
$ Text
"Closing websocket connection (reason: " forall a. Semigroup a => a -> a -> a
<> Text
reason forall a. Semigroup a => a -> a -> a
<> Text
")"
                  ConnectionException
_ ->
                    LogLevel -> Text -> LoggingT IO ()
log LogLevel
LevelError forall a b. (a -> b) -> a -> b
$ Text
"Websocket error: " forall a. Semigroup a => a -> a -> a
<> forall b a. (Show a, IsString b) => a -> b
show ConnectionException
connExc
                forall (m :: Type -> Type) a. MonadIO m => LVar a -> Port -> m ()
LVar.removeListener LVar (RouteModel r)
model Port
subId
    httpApp :: (Loc -> Text -> LogLevel -> LogStr -> IO ()) -> Application
httpApp Loc -> Text -> LogLevel -> LogStr -> IO ()
logger Request
req Response -> IO ResponseReceived
f = do
      forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (m :: Type -> Type) a.
LoggingT m a -> (Loc -> Text -> LogLevel -> LogStr -> IO ()) -> m a
runLoggingT Loc -> Text -> LogLevel -> LogStr -> IO ()
logger forall a b. (a -> b) -> a -> b
$ do
        RouteModel r
val <- forall (m :: Type -> Type) a. MonadIO m => LVar a -> m a
LVar.get LVar (RouteModel r)
model
        let path :: [Text]
path = Request -> [Text]
Wai.pathInfo Request
req
            mr :: Either (BadRouteEncoding r) (Maybe r)
mr = RouteModel r -> [Text] -> Either (BadRouteEncoding r) (Maybe r)
routeFromPathInfo RouteModel r
val [Text]
path
        forall (m :: Type -> Type). MonadLogger m => Text -> Text -> m ()
logInfoNS Text
"ema.http" forall a b. (a -> b) -> a -> b
$ Text
"GET " forall a. Semigroup a => a -> a -> a
<> (Text
"/" forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
T.intercalate Text
"/" [Text]
path) forall a. Semigroup a => a -> a -> a
<> Text
" as " forall a. Semigroup a => a -> a -> a
<> forall b a. (Show a, IsString b) => a -> b
show Either (BadRouteEncoding r) (Maybe r)
mr
        case Either (BadRouteEncoding r) (Maybe r)
mr of
          Left BadRouteEncoding r
err -> do
            forall (m :: Type -> Type). MonadLogger m => Text -> Text -> m ()
logErrorNS Text
"App" forall a b. (a -> b) -> a -> b
$ forall r. Show r => BadRouteEncoding r -> Text
badRouteEncodingMsg BadRouteEncoding r
err
            let s :: LByteString
s = Text -> LByteString
emaErrorHtmlResponse (forall r. Show r => BadRouteEncoding r -> Text
badRouteEncodingMsg BadRouteEncoding r
err) forall a. Semigroup a => a -> a -> a
<> LByteString
wsClientJS
            forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Response -> IO ResponseReceived
f forall a b. (a -> b) -> a -> b
$ Status -> ResponseHeaders -> LByteString -> Response
Wai.responseLBS Status
H.status500 [(HeaderName
H.hContentType, ByteString
"text/html")] LByteString
s
          Right Maybe r
Nothing -> do
            let s :: LByteString
s = Text -> LByteString
emaErrorHtmlResponse Text
decodeRouteNothingMsg forall a. Semigroup a => a -> a -> a
<> LByteString
wsClientJS
            forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Response -> IO ResponseReceived
f forall a b. (a -> b) -> a -> b
$ Status -> ResponseHeaders -> LByteString -> Response
Wai.responseLBS Status
H.status404 [(HeaderName
H.hContentType, ByteString
"text/html")] LByteString
s
          Right (Just r
r) -> do
            RouteModel r -> r -> LoggingT IO (Asset LByteString)
renderCatchingErrors RouteModel r
val r
r forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
              AssetStatic String
staticPath -> do
                let mimeType :: ByteString
mimeType = String -> ByteString
Static.getMimeType String
staticPath
                forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Response -> IO ResponseReceived
f 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 forall a. Maybe a
Nothing
              AssetGenerated Format
Html LByteString
html -> do
                let s :: LByteString
s = LByteString
html forall a. Semigroup a => a -> a -> a
<> forall l s. LazyStrict l s => s -> l
toLazy ByteString
wsClientHtml forall a. Semigroup a => a -> a -> a
<> LByteString
wsClientJS
                forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Response -> IO ResponseReceived
f 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 forall a b. (a -> b) -> a -> b
$ forall k (is :: IxList) t b.
Is k A_Review =>
Optic' k is t b -> b -> t
review (forall s a. Prism_ s a -> Prism' s a
fromPrism_ forall a b. (a -> b) -> a -> b
$ RouteModel r -> Prism_ String r
enc RouteModel r
val) r
r
                forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Response -> IO ResponseReceived
f forall a b. (a -> b) -> a -> b
$ Status -> ResponseHeaders -> LByteString -> Response
Wai.responseLBS Status
H.status200 [(HeaderName
H.hContentType, ByteString
mimeType)] LByteString
s
    renderCatchingErrors :: RouteModel r -> r -> LoggingT IO (Asset LByteString)
renderCatchingErrors RouteModel r
m r
r =
      forall (m :: Type -> Type) e a.
(MonadUnliftIO m, Exception e) =>
m a -> (e -> m a) -> m a
catch (forall r (m :: Type -> Type).
(EmaSite r, MonadIO m, MonadLoggerIO m) =>
Prism' String r -> RouteModel r -> r -> m (SiteOutput r)
siteOutput (forall s a. Prism_ s a -> Prism' s a
fromPrism_ forall a b. (a -> b) -> a -> b
$ RouteModel r -> Prism_ String r
enc RouteModel r
m) RouteModel r
m r
r) forall a b. (a -> b) -> a -> b
$ \(SomeException
err :: SomeException) -> do
        -- Log the error first.
        forall (m :: Type -> Type). MonadLogger m => Text -> Text -> m ()
logErrorNS Text
"App" forall a b. (a -> b) -> a -> b
$ forall b a. (Show a, IsString b) => a -> b
show @Text SomeException
err
        forall (f :: Type -> Type) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
          forall a. Format -> a -> Asset a
AssetGenerated Format
Html forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> LByteString
mkHtmlErrorMsg forall a b. (a -> b) -> a -> b
$
            forall b a. (Show a, IsString b) => a -> b
show @Text SomeException
err
    routeFromPathInfo :: RouteModel r -> [Text] -> Either (BadRouteEncoding r) (Maybe r)
routeFromPathInfo RouteModel r
m =
      RouteModel r -> Text -> Either (BadRouteEncoding r) (Maybe r)
decodeUrlRoute RouteModel r
m forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text] -> Text
T.intercalate Text
"/"
    -- Decode an URL path into a route
    --
    -- This function is used only in live server. If the route is not
    -- isomoprhic, this returns a Left, with the mismatched encoding.
    decodeUrlRoute :: RouteModel r -> Text -> Either (BadRouteEncoding r) (Maybe r)
    decodeUrlRoute :: RouteModel r -> Text -> Either (BadRouteEncoding r) (Maybe r)
decodeUrlRoute RouteModel r
m (Text -> String
urlToFilePath -> String
s) = do
      case forall r a.
(HasCallStack, Eq r, Show r) =>
(a -> Prism_ String r)
-> a -> String -> Either (r, [(String, Text)]) (Maybe r)
checkRoutePrismGivenFilePath RouteModel r -> Prism_ String r
enc RouteModel r
m String
s of
        Left (r
r, [(String, Text)]
log) -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ forall r. String -> r -> [(String, Text)] -> BadRouteEncoding r
BadRouteEncoding String
s r
r [(String, Text)]
log
        Right Maybe r
mr -> forall a b. b -> Either a b
Right Maybe r
mr

-- | A basic error response for displaying in the browser
emaErrorHtmlResponse :: Text -> LByteString
emaErrorHtmlResponse :: Text -> LByteString
emaErrorHtmlResponse Text
err =
  Text -> LByteString
mkHtmlErrorMsg Text
err forall a. Semigroup a => a -> a -> a
<> forall l s. LazyStrict l s => s -> l
toLazy ByteString
wsClientHtml

mkHtmlErrorMsg :: Text -> LByteString
mkHtmlErrorMsg :: Text -> LByteString
mkHtmlErrorMsg Text
s =
  forall a b. ConvertUtf8 a b => a -> b
encodeUtf8 forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text -> Text -> Text
T.replace Text
"MESSAGE" Text
s forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. ConvertUtf8 a b => b -> a
decodeUtf8 forall a b. (a -> b) -> a -> b
$ $(embedFile "www/ema-error.html")

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

decodeRouteNothingMsg :: Text
decodeRouteNothingMsg :: Text
decodeRouteNothingMsg = Text
"Ema: 404 (route decoding returned Nothing)"

data BadRouteEncoding r = BadRouteEncoding
  { forall r. BadRouteEncoding r -> String
_bre_urlFilePath :: FilePath
  , forall r. BadRouteEncoding r -> r
_bre_decodedRoute :: r
  , forall r. BadRouteEncoding r -> [(String, Text)]
_bre_checkLog :: [(FilePath, Text)]
  }
  deriving stock (Port -> BadRouteEncoding r -> ShowS
forall r. Show r => Port -> BadRouteEncoding r -> ShowS
forall r. Show r => [BadRouteEncoding r] -> ShowS
forall r. Show r => BadRouteEncoding r -> String
forall a.
(Port -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [BadRouteEncoding r] -> ShowS
$cshowList :: forall r. Show r => [BadRouteEncoding r] -> ShowS
show :: BadRouteEncoding r -> String
$cshow :: forall r. Show r => BadRouteEncoding r -> String
showsPrec :: Port -> BadRouteEncoding r -> ShowS
$cshowsPrec :: forall r. Show r => Port -> BadRouteEncoding r -> ShowS
Show)

badRouteEncodingMsg :: Show r => BadRouteEncoding r -> Text
badRouteEncodingMsg :: forall r. Show r => BadRouteEncoding r -> Text
badRouteEncodingMsg BadRouteEncoding {r
String
[(String, Text)]
_bre_checkLog :: [(String, Text)]
_bre_decodedRoute :: r
_bre_urlFilePath :: String
_bre_checkLog :: forall r. BadRouteEncoding r -> [(String, Text)]
_bre_decodedRoute :: forall r. BadRouteEncoding r -> r
_bre_urlFilePath :: forall r. BadRouteEncoding r -> String
..} =
  forall a. ToText a => a -> Text
toText forall a b. (a -> b) -> a -> b
$
    Text
"A route Prism' is unlawful.\n\nThe URL '"
      forall a. Semigroup a => a -> a -> a
<> forall a. ToText a => a -> Text
toText String
_bre_urlFilePath
      forall a. Semigroup a => a -> a -> a
<> Text
"' decodes to route '"
      forall a. Semigroup a => a -> a -> a
<> forall b a. (Show a, IsString b) => a -> b
show r
_bre_decodedRoute
      forall a. Semigroup a => a -> a -> a
<> Text
"', but it is not isomporphic on any of the allowed candidates: \n\n"
      forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
T.intercalate
        Text
"\n\n"
        ( [(String, Text)]
_bre_checkLog forall (f :: Type -> Type) a b. Functor f => f a -> (a -> b) -> f b
<&> \(String
candidate, Text
log) ->
            Text
"## Candidate '" forall a. Semigroup a => a -> a -> a
<> forall a. ToText a => a -> Text
toText String
candidate forall a. Semigroup a => a -> a -> a
<> Text
"':\n" forall a. Semigroup a => a -> a -> a
<> Text
log
        )
      forall a. Semigroup a => a -> a -> a
<> Text
" \n\nYou should make the relevant routePrism lawful to fix this issue."

wsClientHtml :: ByteString
wsClientHtml :: ByteString
wsClientHtml = $(embedFile "www/ema-indicator.html")

wsClientJSShim :: Text
wsClientJSShim :: Text
wsClientJSShim = forall a b. ConvertUtf8 a b => b -> a
decodeUtf8 $(embedFile "www/ema-shim.js")

-- Browser-side JavaScript code for interacting with the Haskell server
wsClientJS :: LByteString
wsClientJS :: LByteString
wsClientJS =
  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">
        ${wsClientJSShim}
        
        window.onpageshow = function () { init(false) };
        </script>
    |]