{-# LANGUAGE QuasiQuotes #-}

module Ema.Server where

import Control.Concurrent.Async (race)
import Control.Exception (catch, try)
import Control.Monad.Logger
import Data.Default
import Data.LVar (LVar)
import Data.LVar qualified as LVar
import Data.Text qualified as T
import Ema.Asset
import Ema.Class (Ema (..))
import GHC.IO.Unsafe (unsafePerformIO)
import NeatInterpolation (text)
import Network.HTTP.Types qualified as H
import Network.Wai qualified as Wai
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 System.FilePath ((</>))
import Text.Printf (printf)
import UnliftIO (MonadUnliftIO)

-- | Host string to start the server on.
newtype Host = Host {Host -> Text
unHost :: Text}
  deriving newtype (Host -> Host -> Bool
(Host -> Host -> Bool) -> (Host -> Host -> Bool) -> Eq Host
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Host -> Host -> Bool
$c/= :: Host -> Host -> Bool
== :: Host -> Host -> Bool
$c== :: Host -> Host -> Bool
Eq, Int -> Host -> ShowS
[Host] -> ShowS
Host -> String
(Int -> Host -> ShowS)
-> (Host -> String) -> ([Host] -> ShowS) -> Show Host
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Host] -> ShowS
$cshowList :: [Host] -> ShowS
show :: Host -> String
$cshow :: Host -> String
showsPrec :: Int -> Host -> ShowS
$cshowsPrec :: Int -> Host -> ShowS
Show, Eq Host
Eq Host
-> (Host -> Host -> Ordering)
-> (Host -> Host -> Bool)
-> (Host -> Host -> Bool)
-> (Host -> Host -> Bool)
-> (Host -> Host -> Bool)
-> (Host -> Host -> Host)
-> (Host -> Host -> Host)
-> Ord Host
Host -> Host -> Bool
Host -> Host -> Ordering
Host -> Host -> Host
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Host -> Host -> Host
$cmin :: Host -> Host -> Host
max :: Host -> Host -> Host
$cmax :: Host -> Host -> Host
>= :: Host -> Host -> Bool
$c>= :: Host -> Host -> Bool
> :: Host -> Host -> Bool
$c> :: Host -> Host -> Bool
<= :: Host -> Host -> Bool
$c<= :: Host -> Host -> Bool
< :: Host -> Host -> Bool
$c< :: Host -> Host -> Bool
compare :: Host -> Host -> Ordering
$ccompare :: Host -> Host -> Ordering
$cp1Ord :: Eq Host
Ord, String -> Host
(String -> Host) -> IsString Host
forall a. (String -> a) -> IsString a
fromString :: String -> Host
$cfromString :: String -> Host
IsString)

-- | Port number to bind the server on.
newtype Port = Port {Port -> Int
unPort :: Int}
  deriving newtype (Port -> Port -> Bool
(Port -> Port -> Bool) -> (Port -> Port -> Bool) -> Eq Port
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Port -> Port -> Bool
$c/= :: Port -> Port -> Bool
== :: Port -> Port -> Bool
$c== :: Port -> Port -> Bool
Eq, Int -> Port -> ShowS
[Port] -> ShowS
Port -> String
(Int -> Port -> ShowS)
-> (Port -> String) -> ([Port] -> ShowS) -> Show Port
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Port] -> ShowS
$cshowList :: [Port] -> ShowS
show :: Port -> String
$cshow :: Port -> String
showsPrec :: Int -> Port -> ShowS
$cshowsPrec :: Int -> Port -> ShowS
Show, Eq Port
Eq Port
-> (Port -> Port -> Ordering)
-> (Port -> Port -> Bool)
-> (Port -> Port -> Bool)
-> (Port -> Port -> Bool)
-> (Port -> Port -> Bool)
-> (Port -> Port -> Port)
-> (Port -> Port -> Port)
-> Ord Port
Port -> Port -> Bool
Port -> Port -> Ordering
Port -> Port -> Port
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Port -> Port -> Port
$cmin :: Port -> Port -> Port
max :: Port -> Port -> Port
$cmax :: Port -> Port -> Port
>= :: Port -> Port -> Bool
$c>= :: Port -> Port -> Bool
> :: Port -> Port -> Bool
$c> :: Port -> Port -> Bool
<= :: Port -> Port -> Bool
$c<= :: Port -> Port -> Bool
< :: Port -> Port -> Bool
$c< :: Port -> Port -> Bool
compare :: Port -> Port -> Ordering
$ccompare :: Port -> Port -> Ordering
$cp1Ord :: Eq Port
Ord, Integer -> Port
Port -> Port
Port -> Port -> Port
(Port -> Port -> Port)
-> (Port -> Port -> Port)
-> (Port -> Port -> Port)
-> (Port -> Port)
-> (Port -> Port)
-> (Port -> Port)
-> (Integer -> Port)
-> Num Port
forall a.
(a -> a -> a)
-> (a -> a -> a)
-> (a -> a -> a)
-> (a -> a)
-> (a -> a)
-> (a -> a)
-> (Integer -> a)
-> Num a
fromInteger :: Integer -> Port
$cfromInteger :: Integer -> Port
signum :: Port -> Port
$csignum :: Port -> Port
abs :: Port -> Port
$cabs :: Port -> Port
negate :: Port -> Port
$cnegate :: Port -> Port
* :: Port -> Port -> Port
$c* :: Port -> Port -> Port
- :: Port -> Port -> Port
$c- :: Port -> Port -> Port
+ :: Port -> Port -> Port
$c+ :: Port -> Port -> Port
Num, ReadPrec [Port]
ReadPrec Port
Int -> ReadS Port
ReadS [Port]
(Int -> ReadS Port)
-> ReadS [Port] -> ReadPrec Port -> ReadPrec [Port] -> Read Port
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Port]
$creadListPrec :: ReadPrec [Port]
readPrec :: ReadPrec Port
$creadPrec :: ReadPrec Port
readList :: ReadS [Port]
$creadList :: ReadS [Port]
readsPrec :: Int -> ReadS Port
$creadsPrec :: Int -> ReadS Port
Read)

instance Default Host where
  def :: Host
def = Host
"127.0.0.1"

instance Default Port where
  def :: Port
def = Port
8000

runServerWithWebSocketHotReload ::
  forall model route m.
  ( Ema model route,
    Show route,
    MonadIO m,
    MonadUnliftIO m,
    MonadLoggerIO m
  ) =>
  Host ->
  Port ->
  LVar model ->
  (model -> route -> Asset LByteString) ->
  m ()
runServerWithWebSocketHotReload :: Host
-> Port
-> LVar model
-> (model -> route -> Asset LByteString)
-> m ()
runServerWithWebSocketHotReload Host
host Port
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 (Port -> Int
unPort Port
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 -> HostPreference)
-> (Host -> String) -> Host -> HostPreference
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
forall a. ToString a => a -> String
toString (Text -> String) -> (Host -> Text) -> Host -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Host -> Text
unHost (Host -> HostPreference) -> Host -> HostPreference
forall a b. (a -> b) -> a -> b
$ Host
host)
  Loc -> Text -> LogLevel -> LogStr -> IO ()
logger <- m (Loc -> Text -> LogLevel -> LogStr -> IO ())
forall (m :: Type -> Type).
MonadLoggerIO m =>
m (Loc -> Text -> LogLevel -> LogStr -> IO ())
askLoggerIO

  Text -> m ()
forall (m :: Type -> Type). MonadLogger m => Text -> m ()
logInfoN Text
"=============================================="
  Text -> m ()
forall (m :: Type -> Type). MonadLogger m => Text -> m ()
logInfoN (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Text
"Ema live server running: http://" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Host -> Text
unHost Host
host Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
":" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Port -> Text
forall b a. (Show a, IsString b) => a -> b
show Port
port
  Text -> m ()
forall (m :: Type -> Type). MonadLogger m => Text -> m ()
logInfoN Text
"=============================================="
  IO () -> m ()
forall (m :: Type -> Type) 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 -> Text -> LogLevel -> LogStr -> IO ()) -> IO ())
-> (Loc -> Text -> LogLevel -> LogStr -> IO ())
-> LoggingT IO ()
-> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip LoggingT IO ()
-> (Loc -> Text -> LogLevel -> LogStr -> IO ()) -> IO ()
forall (m :: Type -> Type) a.
LoggingT m a -> (Loc -> Text -> LogLevel -> LogStr -> IO ()) -> m a
runLoggingT Loc -> Text -> LogLevel -> LogStr -> IO ()
logger (LoggingT IO () -> IO ())
-> (PendingConnection -> LoggingT IO ()) -> ServerApp
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)
  where
    wsApp :: PendingConnection -> LoggingT IO ()
wsApp PendingConnection
pendingConn = do
      Connection
conn :: WS.Connection <- IO Connection -> LoggingT IO Connection
forall (t :: (Type -> Type) -> Type -> Type) (m :: Type -> Type) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO Connection -> LoggingT IO Connection)
-> IO Connection -> LoggingT IO Connection
forall a b. (a -> b) -> a -> b
$ PendingConnection -> IO Connection
WS.acceptRequest PendingConnection
pendingConn
      Loc -> Text -> LogLevel -> LogStr -> IO ()
logger <- LoggingT IO (Loc -> Text -> LogLevel -> LogStr -> IO ())
forall (m :: Type -> Type).
MonadLoggerIO m =>
m (Loc -> Text -> LogLevel -> LogStr -> IO ())
askLoggerIO
      IO () -> LoggingT IO ()
forall (t :: (Type -> Type) -> Type -> Type) (m :: Type -> Type) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO () -> LoggingT IO ()) -> IO () -> LoggingT 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 :: Type -> Type) a. Applicative f => a -> f a
pure ()) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
          (LoggingT IO ()
 -> (Loc -> Text -> LogLevel -> LogStr -> IO ()) -> IO ())
-> (Loc -> Text -> LogLevel -> LogStr -> IO ())
-> LoggingT IO ()
-> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip LoggingT IO ()
-> (Loc -> Text -> LogLevel -> LogStr -> IO ()) -> IO ()
forall (m :: Type -> Type) a.
LoggingT m a -> (Loc -> Text -> LogLevel -> LogStr -> IO ()) -> m a
runLoggingT Loc -> Text -> 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 :: Type -> Type) a. MonadIO m => LVar a -> m Int
LVar.addListener LVar model
model
            let log :: LogLevel -> Text -> LoggingT IO ()
log LogLevel
lvl (Text
s :: Text) =
                  Text -> LogLevel -> Text -> LoggingT IO ()
forall (m :: Type -> Type) msg.
(MonadLogger m, ToLogStr msg) =>
Text -> LogLevel -> msg -> m ()
logWithoutLoc (ToText String => String -> Text
forall a. ToText a => a -> Text
toText @String (String -> Text) -> String -> Text
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 Text
s
            LogLevel -> Text -> LoggingT IO ()
log LogLevel
LevelInfo Text
"Connected"
            let askClientForRoute :: LoggingT IO [Text]
askClientForRoute = do
                  Text
msg :: Text <- IO Text -> LoggingT IO Text
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO Text -> LoggingT IO Text) -> IO Text -> LoggingT IO Text
forall a b. (a -> b) -> a -> b
$ Connection -> IO Text
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 (Text -> LoggingT IO ()) -> Text -> LoggingT IO ()
forall a b. (a -> b) -> a -> b
$ Text
"<~~ " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
forall b a. (Show a, IsString b) => a -> b
show [Text]
pathInfo
                  [Text] -> LoggingT IO [Text]
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure [Text]
pathInfo
                decodeRouteWithCurrentModel :: [Text] -> LoggingT IO (Maybe route)
decodeRouteWithCurrentModel [Text]
pathInfo = do
                  model
val <- LVar model -> LoggingT IO model
forall (m :: Type -> Type) a. MonadIO m => LVar a -> m a
LVar.get LVar model
model
                  Maybe route -> LoggingT IO (Maybe route)
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Maybe route -> LoggingT IO (Maybe route))
-> Maybe route -> LoggingT IO (Maybe route)
forall a b. (a -> b) -> a -> b
$ model -> [Text] -> Maybe route
forall {model} {route}.
Ema model route =>
model -> [Text] -> Maybe route
routeFromPathInfo model
val [Text]
pathInfo
                sendRouteHtmlToClient :: [Text] -> model -> LoggingT IO ()
sendRouteHtmlToClient [Text]
pathInfo model
s = do
                  [Text] -> LoggingT IO (Maybe route)
decodeRouteWithCurrentModel [Text]
pathInfo LoggingT IO (Maybe route)
-> (Maybe route -> LoggingT IO ()) -> LoggingT IO ()
forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                    Maybe route
Nothing ->
                      IO () -> LoggingT IO ()
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> LoggingT IO ()) -> IO () -> LoggingT IO ()
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
$ Text -> LByteString
emaErrorHtmlResponse Text
decodeRouteNothingMsg
                    Just route
r -> do
                      case (Loc -> Text -> LogLevel -> LogStr -> IO ())
-> model -> route -> Asset LByteString
renderCatchingErrors Loc -> Text -> 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 () -> LoggingT IO ()
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> LoggingT IO ()) -> IO () -> LoggingT IO ()
forall a b. (a -> b) -> a -> b
$ Connection -> Text -> IO ()
forall a. WebSocketsData a => Connection -> a -> IO ()
WS.sendTextData Connection
conn (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
"REDIRECT " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
forall a. ToText a => a -> Text
toText String
staticPath
                        AssetGenerated Format
Html LByteString
html ->
                          IO () -> LoggingT IO ()
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> LoggingT IO ()) -> IO () -> LoggingT IO ()
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 () -> LoggingT IO ()
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> LoggingT IO ()) -> IO () -> LoggingT IO ()
forall a b. (a -> b) -> a -> b
$ Connection -> Text -> IO ()
forall a. WebSocketsData a => Connection -> a -> IO ()
WS.sendTextData Connection
conn (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
"REDIRECT " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
forall a. ToText a => a -> Text
toText (model -> route -> String
forall model route. Ema model route => model -> route -> String
encodeRoute model
s route
r)
                      LogLevel -> Text -> LoggingT IO ()
log LogLevel
LevelDebug (Text -> LoggingT IO ()) -> Text -> LoggingT IO ()
forall a b. (a -> b) -> a -> b
$ Text
" ~~> " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> route -> Text
forall b a. (Show a, IsString b) => a -> b
show route
r
                loop :: IO ()
loop = (LoggingT IO ()
 -> (Loc -> Text -> LogLevel -> LogStr -> IO ()) -> IO ())
-> (Loc -> Text -> LogLevel -> LogStr -> IO ())
-> LoggingT IO ()
-> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip LoggingT IO ()
-> (Loc -> Text -> LogLevel -> LogStr -> IO ()) -> IO ()
forall (m :: Type -> Type) a.
LoggingT m a -> (Loc -> Text -> LogLevel -> LogStr -> IO ()) -> m a
runLoggingT Loc -> Text -> LogLevel -> LogStr -> IO ()
logger (LoggingT IO () -> IO ()) -> LoggingT IO () -> IO ()
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.
                  IO () -> LoggingT IO ()
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> LoggingT IO ()) -> IO () -> LoggingT IO ()
forall a b. (a -> b) -> a -> b
$ do
                    IO model -> IO [Text] -> IO (Either model [Text])
forall a b. IO a -> IO b -> IO (Either a b)
race (LVar model -> Int -> IO model
forall (m :: Type -> Type) a. MonadIO m => LVar a -> Int -> m a
LVar.listenNext LVar model
model Int
subId) (LoggingT IO [Text]
-> (Loc -> Text -> LogLevel -> LogStr -> IO ()) -> IO [Text]
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) IO (Either model [Text]) -> (Either model [Text] -> IO ()) -> IO ()
forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Either model [Text]
res -> (LoggingT IO ()
 -> (Loc -> Text -> LogLevel -> LogStr -> IO ()) -> IO ())
-> (Loc -> Text -> LogLevel -> LogStr -> IO ())
-> LoggingT IO ()
-> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip LoggingT IO ()
-> (Loc -> Text -> LogLevel -> LogStr -> IO ()) -> IO ()
forall (m :: Type -> Type) a.
LoggingT m a -> (Loc -> Text -> LogLevel -> LogStr -> IO ()) -> m a
runLoggingT Loc -> Text -> LogLevel -> LogStr -> IO ()
logger (LoggingT IO () -> IO ()) -> LoggingT IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ case Either model [Text]
res of
                      Left model
newModel -> do
                        -- The page the user is currently viewing has changed. Send
                        -- the new HTML to them.
                        [Text] -> model -> LoggingT IO ()
sendRouteHtmlToClient [Text]
mWatchingRoute model
newModel
                        IO () -> LoggingT IO ()
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] -> model -> LoggingT IO ()
sendRouteHtmlToClient [Text]
mNextRoute (model -> LoggingT IO ()) -> LoggingT IO model -> LoggingT IO ()
forall (m :: Type -> Type) a b. Monad m => (a -> m b) -> m a -> m b
=<< LVar model -> LoggingT IO model
forall (m :: Type -> Type) a. MonadIO m => LVar a -> m a
LVar.get LVar model
model
                        IO () -> LoggingT IO ()
forall (t :: (Type -> Type) -> Type -> Type) (m :: Type -> Type) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift IO ()
loop
            IO (Either ConnectionException ())
-> LoggingT IO (Either ConnectionException ())
forall (m :: Type -> Type) 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 ()
loop) LoggingT IO (Either ConnectionException ())
-> (Either ConnectionException () -> LoggingT IO ())
-> LoggingT IO ()
forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
              Right () -> () -> LoggingT IO ()
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ()
              Left (ConnectionException
connExc :: ConnectionException) -> do
                case ConnectionException
connExc of
                  WS.CloseRequest Word16
_ (LByteString -> Text
forall a b. ConvertUtf8 a b => b -> a
decodeUtf8 -> Text
reason) ->
                    LogLevel -> Text -> LoggingT IO ()
log LogLevel
LevelInfo (Text -> LoggingT IO ()) -> Text -> LoggingT IO ()
forall a b. (a -> b) -> a -> b
$ Text
"Closing websocket connection (reason: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
reason Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")"
                  ConnectionException
_ ->
                    LogLevel -> Text -> LoggingT IO ()
log LogLevel
LevelError (Text -> LoggingT IO ()) -> Text -> LoggingT IO ()
forall a b. (a -> b) -> a -> b
$ Text
"Websocket error: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ConnectionException -> Text
forall b a. (Show a, IsString b) => a -> b
show ConnectionException
connExc
                LVar model -> Int -> LoggingT IO ()
forall (m :: Type -> Type) a. MonadIO m => LVar a -> Int -> m ()
LVar.removeListener LVar model
model Int
subId
    assetsMiddleware :: Middleware
assetsMiddleware =
      Middleware
Static.static
    httpApp :: (Loc -> Text -> LogLevel -> LogStr -> IO ()) -> Application
httpApp Loc -> Text -> LogLevel -> LogStr -> IO ()
logger Request
req Response -> IO ResponseReceived
f = do
      (LoggingT IO ResponseReceived
 -> (Loc -> Text -> LogLevel -> LogStr -> IO ())
 -> IO ResponseReceived)
-> (Loc -> Text -> LogLevel -> LogStr -> IO ())
-> LoggingT IO ResponseReceived
-> IO ResponseReceived
forall a b c. (a -> b -> c) -> b -> a -> c
flip LoggingT IO ResponseReceived
-> (Loc -> Text -> LogLevel -> LogStr -> IO ())
-> IO ResponseReceived
forall (m :: Type -> Type) a.
LoggingT m a -> (Loc -> Text -> LogLevel -> LogStr -> IO ()) -> m a
runLoggingT Loc -> Text -> LogLevel -> LogStr -> IO ()
logger (LoggingT IO ResponseReceived -> IO ResponseReceived)
-> LoggingT IO ResponseReceived -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ do
        model
val <- LVar model -> LoggingT IO model
forall (m :: Type -> Type) a. MonadIO m => LVar a -> m a
LVar.get LVar model
model
        let path :: [Text]
path = Request -> [Text]
Wai.pathInfo Request
req
            mr :: Maybe route
mr = model -> [Text] -> Maybe route
forall {model} {route}.
Ema model route =>
model -> [Text] -> Maybe route
routeFromPathInfo model
val [Text]
path
        Text -> Text -> LoggingT IO ()
forall (m :: Type -> Type). MonadLogger m => Text -> Text -> m ()
logInfoNS Text
"HTTP" (Text -> LoggingT IO ()) -> Text -> LoggingT IO ()
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
forall b a. (Show a, IsString b) => a -> b
show [Text]
path Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" as " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Maybe route -> Text
forall b a. (Show a, IsString b) => a -> b
show Maybe route
mr
        case Maybe route
mr of
          Maybe route
Nothing ->
            IO ResponseReceived -> LoggingT IO ResponseReceived
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO ResponseReceived -> LoggingT IO ResponseReceived)
-> IO ResponseReceived -> LoggingT IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ Response -> IO ResponseReceived
f (Response -> IO ResponseReceived)
-> Response -> IO ResponseReceived
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
$ Text -> LByteString
forall a b. ConvertUtf8 a b => a -> b
encodeUtf8 Text
decodeRouteNothingMsg
          Just route
r -> do
            case (Loc -> Text -> LogLevel -> LogStr -> IO ())
-> model -> route -> Asset LByteString
renderCatchingErrors Loc -> Text -> LogLevel -> LogStr -> IO ()
logger model
val route
r of
              AssetStatic String
staticPath -> do
                let mimeType :: ByteString
mimeType = String -> ByteString
Static.getMimeType String
staticPath
                IO ResponseReceived -> LoggingT IO ResponseReceived
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO ResponseReceived -> LoggingT IO ResponseReceived)
-> IO ResponseReceived -> LoggingT IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ Response -> IO ResponseReceived
f (Response -> IO ResponseReceived)
-> Response -> IO ResponseReceived
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 ResponseReceived -> LoggingT IO ResponseReceived
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO ResponseReceived -> LoggingT IO ResponseReceived)
-> IO ResponseReceived -> LoggingT IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ Response -> IO ResponseReceived
f (Response -> IO ResponseReceived)
-> Response -> IO ResponseReceived
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 ResponseReceived -> LoggingT IO ResponseReceived
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO ResponseReceived -> LoggingT IO ResponseReceived)
-> IO ResponseReceived -> LoggingT IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ Response -> IO ResponseReceived
f (Response -> IO ResponseReceived)
-> Response -> IO ResponseReceived
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 -> Text -> LogLevel -> LogStr -> IO ())
-> model -> route -> Asset LByteString
renderCatchingErrors Loc -> Text -> 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 -> Text -> LogLevel -> LogStr -> IO ()) -> IO ())
-> (Loc -> Text -> LogLevel -> LogStr -> IO ())
-> LoggingT IO ()
-> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip LoggingT IO ()
-> (Loc -> Text -> LogLevel -> LogStr -> IO ()) -> IO ()
forall (m :: Type -> Type) a.
LoggingT m a -> (Loc -> Text -> LogLevel -> LogStr -> IO ()) -> m a
runLoggingT Loc -> Text -> LogLevel -> LogStr -> IO ()
logger (LoggingT IO () -> IO ()) -> LoggingT IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> Text -> LoggingT IO ()
forall (m :: Type -> Type). MonadLogger m => Text -> Text -> m ()
logErrorNS Text
"App" (Text -> LoggingT IO ()) -> Text -> LoggingT IO ()
forall a b. (a -> b) -> a -> b
$ SomeException -> Text
forall b a. (Show a, IsString b) => a -> b
show @Text SomeException
err
          Asset LByteString -> IO (Asset LByteString)
forall (f :: Type -> Type) 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)
-> (Text -> LByteString) -> Text -> Asset LByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> LByteString
emaErrorHtml (Text -> Asset LByteString) -> Text -> Asset LByteString
forall a b. (a -> b) -> a -> b
$
              SomeException -> Text
forall b a. (Show a, IsString b) => a -> b
show @Text SomeException
err
    routeFromPathInfo :: model -> [Text] -> Maybe route
routeFromPathInfo model
m =
      model -> Text -> Maybe route
forall model route. Ema model route => model -> Text -> Maybe route
decodeUrlRoute model
m (Text -> Maybe route) -> ([Text] -> Text) -> [Text] -> Maybe route
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text] -> Text
T.intercalate Text
"/"
    -- 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 :: Type -> Type) a. Applicative f => a -> f a
pure a
x) (a -> IO a
forall (f :: Type -> Type) 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 :: Text -> LByteString
emaErrorHtmlResponse Text
err =
  Text -> LByteString
emaErrorHtml Text
err LByteString -> LByteString -> LByteString
forall a. Semigroup a => a -> a -> a
<> LByteString
emaStatusHtml

emaErrorHtml :: Text -> LByteString
emaErrorHtml :: Text -> LByteString
emaErrorHtml Text
s =
  Text -> LByteString
forall a b. ConvertUtf8 a b => a -> b
encodeUtf8 (Text -> LByteString) -> Text -> LByteString
forall a b. (a -> b) -> a -> b
$
    Text
"<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;\">"
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
s
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"</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 :: Text -> [Text]
pathInfoFromWsMsg =
  (Text -> Bool) -> [Text] -> [Text]
forall a. (a -> Bool) -> [a] -> [a]
filter (Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
/= Text
"") ([Text] -> [Text]) -> (Text -> [Text]) -> Text -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text -> [Text]
T.splitOn Text
"/" (Text -> [Text]) -> (Text -> Text) -> Text -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Text -> Text
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 -> Text -> Maybe route
decodeUrlRoute model
model (Text -> 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 :: Type -> Type) 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 -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
".html")
    Maybe route -> Maybe route -> Maybe route
forall (f :: Type -> Type) 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 -> ShowS
</> String
"index.html")

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

-- Browser-side JavaScript code for interacting with the Haskell server
wsClientShim :: LByteString
wsClientShim :: LByteString
wsClientShim =
  Text -> 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}`);
             window.history.pushState({}, "", path);
             sendObservePath(path);
          }

          function handleRouteClicks(e) {
              const origin = e.target.closest("a");
              if (origin) {
                if (window.location.host === origin.host && origin.getAttribute("target") != "_blank") {
                  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();
          };

          // API for user invocations 
          window.ema = {
            switchRoute: switchRoute
          };
        };
        
        window.onpageshow = function () { init(false) };
        </script>
    |]

emaStatusHtml :: LByteString
emaStatusHtml :: LByteString
emaStatusHtml =
  Text -> 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>
  |]