{-# 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)
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)
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
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 ->
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 ->
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
[Text]
mWatchingRoute <- LoggingT IO [Text]
askClientForRoute
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
[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
[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
(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
"/"
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)
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>"
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
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)"
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>
|]