Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Enable IO in siteOutput #124

Merged
merged 1 commit into from
Aug 2, 2022
Merged
Show file tree
Hide file tree
Changes from all commits
Commits
File filter

Filter by extension

Filter by extension

Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
2 changes: 1 addition & 1 deletion src/Ema/Example/Ex00_Hello.hs
Original file line number Diff line number Diff line change
Expand Up @@ -15,7 +15,7 @@ instance EmaSite Route where
siteInput _ _ =
pure $ pure ()
siteOutput _ _ _ =
Ema.AssetGenerated Ema.Html "<b>Hello</b>, Ema"
pure $ Ema.AssetGenerated Ema.Html "<b>Hello</b>, Ema"

main :: IO ()
main = void $ Ema.runSite @Route ()
2 changes: 1 addition & 1 deletion src/Ema/Example/Ex01_Basic.hs
Original file line number Diff line number Diff line change
Expand Up @@ -23,7 +23,7 @@ deriveIsRoute ''Route [t|'[]|]
instance EmaSite Route where
siteInput _ _ = pure $ pure ()
siteOutput rp () r =
Ema.AssetGenerated Ema.Html $
pure . Ema.AssetGenerated Ema.Html $
tailwindLayout (H.title "Basic site" >> H.base ! A.href "/") $
H.div ! A.class_ "container mx-auto mt-8 p-2" $ do
H.h1 ! A.class_ "text-3xl font-bold" $ "Basic site"
Expand Down
2 changes: 1 addition & 1 deletion src/Ema/Example/Ex02_Clock.hs
Original file line number Diff line number Diff line change
Expand Up @@ -45,7 +45,7 @@ instance EmaSite Route where
logDebugNS "Ex02" "Updating clock..."
setModel t
siteOutput rp m r =
Ema.AssetGenerated Ema.Html $ render rp m r
pure $ Ema.AssetGenerated Ema.Html $ render rp m r

main :: IO ()
main = do
Expand Down
2 changes: 1 addition & 1 deletion src/Ema/Example/Ex03_Store.hs
Original file line number Diff line number Diff line change
Expand Up @@ -136,7 +136,7 @@ instance EmaSite Route where
log :: MonadLogger m => Text -> m ()
log = logInfoNS "Ex03_Store"
siteOutput rp (Model storeName ps cats) r =
Ema.AssetGenerated Ema.Html $
pure . Ema.AssetGenerated Ema.Html $
tailwindLayout (H.title ("Store example: " <> H.toHtml storeName) >> H.base ! A.href "/") $
H.div ! A.class_ "container mx-auto mt-8 p-2" $ do
H.h1 ! A.class_ "text-3xl font-bold" $ H.toHtml storeName
Expand Down
2 changes: 1 addition & 1 deletion src/Ema/Example/Ex04_Multi.hs
Original file line number Diff line number Diff line change
Expand Up @@ -72,7 +72,7 @@ instance EmaSite R where
pure $ liftA3 M x1 x2 x3
siteOutput rp m = \case
R_Index ->
Ema.AssetGenerated Ema.Html $ renderIndex rp m
pure $ Ema.AssetGenerated Ema.Html $ renderIndex rp m
R_Hello r ->
siteOutput (rp % (_As @"R_Hello")) m2 r
R_Basic r ->
Expand Down
2 changes: 1 addition & 1 deletion src/Ema/Example/Ex05_MultiRoute.hs
Original file line number Diff line number Diff line change
Expand Up @@ -34,7 +34,7 @@ newtype TopRoute = TopRoute ()
instance EmaSite TopRoute where
siteInput _ _ = pure $ pure ()
siteOutput _enc _ _ =
Ema.AssetGenerated Ema.Html renderIndex
pure $ Ema.AssetGenerated Ema.Html renderIndex

main :: IO ()
main = do
Expand Down
2 changes: 1 addition & 1 deletion src/Ema/Generate.hs
Original file line number Diff line number Diff line change
Expand Up @@ -84,7 +84,7 @@ generateSiteFromModel' dest model = do
log LevelInfo $ "Writing " <> show (length routes) <> " routes"
fmap concat . forM routes $ \r -> do
let fp = dest </> review rp r
case siteOutput rp model r of
siteOutput rp model r >>= \case
AssetStatic staticPath -> do
liftIO (doesPathExist staticPath) >>= \case
True ->
Expand Down
6 changes: 3 additions & 3 deletions src/Ema/Route/Generic/Example.hs
Original file line number Diff line number Diff line change
Expand Up @@ -47,7 +47,7 @@ instance IsRoute NumRoute where

instance EmaSite R where
siteInput _ () = pure $ pure (42, 21, "inner")
siteOutput _ m r = Asset.AssetGenerated Asset.Html $ show r <> show m
siteOutput _ m r = pure $ Asset.AssetGenerated Asset.Html $ show r <> show m

-- --warnings -c "cabal repl ema -f with-examples" -T Ema.Route.Generic.main --setup ":set args gen /tmp"
main :: IO ()
Expand All @@ -70,7 +70,7 @@ instance EmaSite TR where
pure $ fmap (,"TOP") m1
siteOutput rp m = \case
r@TR_Index ->
Asset.AssetGenerated Asset.Html $ show r <> show m
pure $ Asset.AssetGenerated Asset.Html $ show r <> show m
TR_Inner r ->
-- Might as well provide a `innerSiteOutput (_As @TR_Inner)`?
siteOutput @R (rp % _As @"TR_Inner") (trInnerModel m) r
Expand Down Expand Up @@ -100,7 +100,7 @@ data BarRoute = BarRoute

instance EmaSite R2 where
siteInput _ () = pure $ pure (21, "inner")
siteOutput _ m r = Asset.AssetGenerated Asset.Html $ show r <> show m
siteOutput _ m r = pure $ Asset.AssetGenerated Asset.Html $ show r <> show m

mainConst :: IO ()
mainConst = Ema.runSite_ @R2 ()
Expand Down
4 changes: 2 additions & 2 deletions src/Ema/Route/Lib/Extra/MarkdownRoute.hs
Original file line number Diff line number Diff line change
Expand Up @@ -105,9 +105,9 @@ instance EmaSite MarkdownRoute where
siteInput _ arg = do
docsDyn <- markdownFilesDyn (argBaseDir arg)
pure $ Model arg <$> docsDyn
siteOutput _ model r =
siteOutput _ model r = do
let pandoc = Map.findWithDefault (throw $ MarkdownError_Missing r) r $ modelPandocs model
in (pandoc, MarkdownHtml . renderHtml (argWriterOpts $ modelArg model))
pure (pandoc, MarkdownHtml . renderHtml (argWriterOpts $ modelArg model))

markdownFilesDyn :: (MonadIO m, MonadUnliftIO m, MonadLogger m, MonadLoggerIO m) => FilePath -> m (Dynamic m (Map MarkdownRoute Pandoc))
markdownFilesDyn baseDir = do
Expand Down
2 changes: 1 addition & 1 deletion src/Ema/Route/Lib/Extra/StaticRoute.hs
Original file line number Diff line number Diff line change
Expand Up @@ -52,7 +52,7 @@ instance KnownSymbol baseDir => EmaSite (StaticRoute baseDir) where
files <- staticFilesDynamic $ symbolVal (Proxy @baseDir)
pure $ Model cliAct <$> files
siteOutput _ _ (StaticRoute path) =
Ema.AssetStatic $ symbolVal (Proxy @baseDir) </> path
pure $ Ema.AssetStatic $ symbolVal (Proxy @baseDir) </> path

staticFilesDynamic ::
forall m.
Expand Down
26 changes: 11 additions & 15 deletions src/Ema/Server.hs
Original file line number Diff line number Diff line change
Expand Up @@ -5,7 +5,7 @@
module Ema.Server where

import Control.Concurrent.Async (race)
import Control.Exception (catch, try)
import Control.Exception (try)
import Control.Monad.Logger
import Data.LVar (LVar)
import Data.LVar qualified as LVar
Expand All @@ -22,7 +22,6 @@ import Ema.Route.Prism (
)
import Ema.Route.Url (urlToFilePath)
import Ema.Site (EmaSite (siteOutput), EmaStaticSite)
import GHC.IO.Unsafe (unsafePerformIO)
import NeatInterpolation (text)
import Network.HTTP.Types qualified as H
import Network.Wai qualified as Wai
Expand All @@ -36,6 +35,7 @@ import Optics.Core (review)
import Text.Printf (printf)
import UnliftIO (MonadUnliftIO)
import UnliftIO.Concurrent (threadDelay)
import UnliftIO.Exception (catch)

runServerWithWebSocketHotReload ::
forall r m.
Expand Down Expand Up @@ -108,7 +108,7 @@ runServerWithWebSocketHotReload host mport model = do
Right Nothing ->
liftIO $ WS.sendTextData conn $ emaErrorHtmlResponse decodeRouteNothingMsg
Right (Just r) -> do
case renderCatchingErrors logger s r of
renderCatchingErrors s r >>= \case
AssetStatic staticPath ->
-- HACK: Websocket client should check for REDIRECT prefix.
-- Not bothering with JSON to avoid having to JSON parse every HTML dump.
Expand Down Expand Up @@ -168,7 +168,7 @@ runServerWithWebSocketHotReload host mport model = do
let s = emaErrorHtmlResponse decodeRouteNothingMsg <> wsClientJS
liftIO $ f $ Wai.responseLBS H.status404 [(H.hContentType, "text/html")] s
Right (Just r) -> do
case renderCatchingErrors logger val r of
renderCatchingErrors val r >>= \case
AssetStatic staticPath -> do
let mimeType = Static.getMimeType staticPath
liftIO $ f $ Wai.responseFile H.status200 [(H.hContentType, mimeType)] staticPath Nothing
Expand All @@ -178,19 +178,15 @@ runServerWithWebSocketHotReload host mport model = do
AssetGenerated Other s -> do
let mimeType = Static.getMimeType $ review (fromPrism_ $ enc val) r
liftIO $ f $ Wai.responseLBS H.status200 [(H.hContentType, mimeType)] s
renderCatchingErrors logger m r =
unsafeCatch (siteOutput (fromPrism_ $ enc m) m r) $ \(err :: SomeException) ->
unsafePerformIO $ do
-- Log the error first.
flip runLoggingT logger $ logErrorNS "App" $ show @Text err
pure $
AssetGenerated Html . mkHtmlErrorMsg $
show @Text err
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
routeFromPathInfo m =
decodeUrlRoute m . T.intercalate "/"
-- TODO: It would be good have this also get us the stack trace.
unsafeCatch :: forall x e. Exception e => x -> (e -> x) -> x
unsafeCatch x f = unsafePerformIO $ catch (seq x $ pure x) (pure . f)
-- Decode an URL path into a route
--
-- This function is used only in live server. If the route is not
Expand Down
8 changes: 7 additions & 1 deletion src/Ema/Site.hs
Original file line number Diff line number Diff line change
Expand Up @@ -62,7 +62,13 @@ class IsRoute r => EmaSite r where
m (Dynamic m (RouteModel r))

-- | Return the output (typically an `Asset`) for the given route and model.
siteOutput :: Prism' FilePath r -> RouteModel r -> r -> SiteOutput r
siteOutput ::
forall m.
(MonadIO m, MonadLoggerIO m) =>
Prism' FilePath r ->
RouteModel r ->
r ->
m (SiteOutput r)

-- | Like `EmaSite` but `SiteOutput` is a bytestring `Asset`.
type EmaStaticSite r = (EmaSite r, SiteOutput r ~ Asset LByteString)