{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TemplateHaskell #-} module Ema.Server where 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.Async (race) import UnliftIO.Concurrent (threadDelay) import UnliftIO.Exception (catch, try) 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 host mport model = do logger <- askLoggerIO let runM = flip runLoggingT logger settings = Warp.defaultSettings & Warp.setHost (fromString . toString . unHost $ host) app = WaiWs.websocketsOr WS.defaultConnectionOptions (wsApp logger) (httpApp logger) banner port = do logInfoNS "ema" "===============================================" logInfoNS "ema" $ "Ema live server RUNNING: http://" <> unHost host <> ":" <> show port logInfoNS "ema" "===============================================" liftIO $ warpRunSettings settings mport (runM . banner) app where enc = 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 settings mPort banner app = do case mPort of Nothing -> Warp.withApplicationSettings settings (pure app) $ \port -> do void $ banner port threadDelay maxBound Just port -> do void $ banner port Warp.runSettings (settings & Warp.setPort port) app wsApp logger pendingConn = do conn :: WS.Connection <- WS.acceptRequest pendingConn WS.withPingThread conn 30 pass $ flip runLoggingT logger $ do subId <- LVar.addListener model let log lvl (s :: Text) = logWithoutLoc (toText @String $ printf "ema.ws.%.2d" subId) lvl s log LevelInfo "Connected" let askClientForRoute = do msg :: Text <- liftIO $ WS.receiveData conn log LevelDebug $ "<~~ " <> show msg pure msg sendRouteHtmlToClient path s = do decodeUrlRoute s path & \case Left err -> do log LevelError $ badRouteEncodingMsg err liftIO $ WS.sendTextData conn $ emaErrorHtmlResponse $ badRouteEncodingMsg err Right Nothing -> liftIO $ WS.sendTextData conn $ emaErrorHtmlResponse decodeRouteNothingMsg Right (Just r) -> do renderCatchingErrors s r >>= \case AssetGenerated Html html -> liftIO $ WS.sendTextData conn $ html <> toLazy 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 _staticPath -> liftIO $ WS.sendTextData conn $ "REDIRECT " <> toText (review (fromPrism_ $ enc s) r) AssetGenerated Other _s -> liftIO $ WS.sendTextData conn $ "REDIRECT " <> toText (review (fromPrism_ $ enc s) r) log LevelDebug $ " ~~> " <> show r -- @mWatchingRoute@ is the route currently being watched. loop mWatchingRoute = -- Listen *until* either we get a new value, or the client requests -- to switch to a new route. race (LVar.listenNext model subId) askClientForRoute >>= \case Left newModel -> do -- The page the user is currently viewing has changed. Send -- the new HTML to them. sendRouteHtmlToClient mWatchingRoute newModel loop mWatchingRoute Right 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). sendRouteHtmlToClient mNextRoute =<< LVar.get model loop mNextRoute -- Wait for the client to send the first request with the initial route. mInitialRoute <- askClientForRoute try (loop mInitialRoute) >>= \case Right () -> pass Left (connExc :: ConnectionException) -> do case connExc of WS.CloseRequest _ (decodeUtf8 -> reason) -> log LevelInfo $ "Closing websocket connection (reason: " <> reason <> ")" _ -> log LevelError $ "Websocket error: " <> show connExc LVar.removeListener model subId httpApp logger req f = do flip runLoggingT logger $ do val <- LVar.get model let pathInfo = Wai.pathInfo req path = T.intercalate "/" pathInfo mr = decodeUrlRoute val path logInfoNS "ema.http" $ "GET " <> path <> " as " <> show mr case mr of Left err -> do logErrorNS "App" $ badRouteEncodingMsg err let s = emaErrorHtmlResponse (badRouteEncodingMsg err) <> wsClientJS liftIO $ f $ Wai.responseLBS H.status500 [(H.hContentType, "text/html")] s Right Nothing -> do let s = emaErrorHtmlResponse decodeRouteNothingMsg <> wsClientJS liftIO $ f $ Wai.responseLBS H.status404 [(H.hContentType, "text/html")] s Right (Just r) -> do renderCatchingErrors val r >>= \case AssetStatic staticPath -> do let mimeType = Static.getMimeType staticPath liftIO $ f $ Wai.responseFile H.status200 [(H.hContentType, mimeType)] staticPath Nothing AssetGenerated Html html -> do let s = html <> toLazy wsClientHtml <> wsClientJS liftIO $ f $ Wai.responseLBS H.status200 [(H.hContentType, "text/html")] s AssetGenerated Other s -> do let mimeType = Static.getMimeType $ review (fromPrism_ $ enc val) r liftIO $ f $ Wai.responseLBS H.status200 [(H.hContentType, mimeType)] s renderCatchingErrors m r = catch (siteOutput (fromPrism_ $ enc m) m r) $ \(err :: SomeException) -> do -- Log the error first. logErrorNS "App" $ show @Text err pure $ AssetGenerated Html . mkHtmlErrorMsg $ show @Text err -- 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 m (urlToFilePath -> s) = do case checkRoutePrismGivenFilePath enc m s of Left (r, log) -> Left $ BadRouteEncoding s r log Right mr -> Right mr -- | A basic error response for displaying in the browser emaErrorHtmlResponse :: Text -> LByteString emaErrorHtmlResponse err = mkHtmlErrorMsg err <> toLazy wsClientHtml mkHtmlErrorMsg :: Text -> LByteString mkHtmlErrorMsg s = encodeUtf8 . T.replace "MESSAGE" s . decodeUtf8 $ $(embedFile "www/ema-error.html") decodeRouteNothingMsg :: Text decodeRouteNothingMsg = "Ema: 404 (route decoding returned Nothing)" data BadRouteEncoding r = BadRouteEncoding { _bre_urlFilePath :: FilePath , _bre_decodedRoute :: r , _bre_checkLog :: [(FilePath, Text)] } deriving stock (Show) badRouteEncodingMsg :: Show r => BadRouteEncoding r -> Text badRouteEncodingMsg BadRouteEncoding {..} = toText $ "A route Prism' is unlawful.\n\nThe URL '" <> toText _bre_urlFilePath <> "' decodes to route '" <> show _bre_decodedRoute <> "', but it is not isomporphic on any of the allowed candidates: \n\n" <> T.intercalate "\n\n" ( _bre_checkLog <&> \(candidate, log) -> "## Candidate '" <> toText candidate <> "':\n" <> log ) <> " \n\nYou should make the relevant routePrism lawful to fix this issue." wsClientHtml :: ByteString wsClientHtml = $(embedFile "www/ema-indicator.html") wsClientJSShim :: Text wsClientJSShim = decodeUtf8 $(embedFile "www/ema-shim.js") -- Browser-side JavaScript code for interacting with the Haskell server wsClientJS :: LByteString wsClientJS = encodeUtf8 [text| |]