From d366c83fc9669df10f4334fa5fd6456a709bed46 Mon Sep 17 00:00:00 2001 From: Sridhar Ratnakumar Date: Wed, 2 Jun 2021 20:01:24 -0400 Subject: [PATCH] Allow encodeRoute (thus routeUrl) take `model` as argument --- CHANGELOG.md | 1 + src/Ema/Class.hs | 4 ++-- src/Ema/Example/Ex02_Basic.hs | 10 +++++----- src/Ema/Example/Ex03_Clock.hs | 4 ++-- src/Ema/Generate.hs | 8 ++++---- src/Ema/Route.hs | 6 +++--- src/Ema/Server.hs | 4 ++-- 7 files changed, 19 insertions(+), 18 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 1dce493..fd8fce1 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -15,6 +15,7 @@ - now returns relative URLs (ie. without the leading `/`) - Use the `` tag to specify an explicit prefix for relative URLs in generated HTML. This way hosting on GitHub Pages without CNAME will continue to have functional links. - Fix: prevent encoding of non-HTML paths + - Now takes the `model` type as argument, inasmuch as `encodeRoute` takes it as as well (to accomodate scenarios where route path can only be computed depending on model state; storing slug aliases for instance) - `Ema.Slug` - Add `Ord`, `Generic`, `Data` and Aeson instances to `Slug` - Unicode normalize slugs using NFC diff --git a/src/Ema/Class.hs b/src/Ema/Class.hs index ce0ffab..27d768f 100644 --- a/src/Ema/Class.hs +++ b/src/Ema/Class.hs @@ -7,7 +7,7 @@ module Ema.Class where -- | Enrich a model to work with Ema class Ema model route | route -> model where -- | Get the filepath on disk corresponding to this route. - encodeRoute :: route -> FilePath + encodeRoute :: model -> route -> FilePath -- | Decode a filepath on disk into a route. decodeRoute :: model -> FilePath -> Maybe route @@ -23,7 +23,7 @@ class Ema model route | route -> model where -- | The unit model is useful when using Ema in pure fashion (see -- @Ema.runEmaPure@) with a single route (index.html) only. instance Ema () () where - encodeRoute () = [] + encodeRoute () () = [] decodeRoute () = \case [] -> Just () _ -> Nothing diff --git a/src/Ema/Example/Ex02_Basic.hs b/src/Ema/Example/Ex02_Basic.hs index 23ca84d..6fe3bfa 100644 --- a/src/Ema/Example/Ex02_Basic.hs +++ b/src/Ema/Example/Ex02_Basic.hs @@ -19,10 +19,10 @@ data Route | About deriving (Show, Enum, Bounded) -data Model = Model Text +newtype Model = Model {unModel :: Text} instance Ema Model Route where - encodeRoute = + encodeRoute _model = \case Index -> "index.html" About -> "about.html" @@ -39,13 +39,13 @@ main = do liftIO $ threadDelay maxBound render :: Ema.CLI.Action -> Model -> Route -> LByteString -render emaAction (Model s) r = +render emaAction model r = Tailwind.layout emaAction (H.title "Basic site" >> H.base ! A.href "/") $ H.div ! A.class_ "container mx-auto" $ do H.div ! A.class_ "mt-8 p-2 text-center" $ do case r of Index -> do - H.toHtml s + H.toHtml (unModel model) "You are on the index page. " routeElem About "Go to About" About -> do @@ -55,4 +55,4 @@ render emaAction (Model s) r = routeElem r' w = H.a ! A.class_ "text-red-500 hover:underline" ! routeHref r' $ w routeHref r' = - A.href (fromString . toString $ Ema.routeUrl r') + A.href (fromString . toString $ Ema.routeUrl model r') diff --git a/src/Ema/Example/Ex03_Clock.hs b/src/Ema/Example/Ex03_Clock.hs index 6a57530..f364b67 100644 --- a/src/Ema/Example/Ex03_Clock.hs +++ b/src/Ema/Example/Ex03_Clock.hs @@ -28,7 +28,7 @@ data Route deriving (Show, Enum, Bounded) instance Ema UTCTime Route where - encodeRoute = \case + encodeRoute _time = \case Index -> "index.html" OnlyTime -> "time.html" decodeRoute _time = \case @@ -70,7 +70,7 @@ render emaAction now r = routeElem r' w = H.a ! A.class_ "text-xl text-purple-500 hover:underline" ! routeHref r' $ w routeHref r' = - A.href (fromString . toString $ Ema.routeUrl r') + A.href (fromString . toString $ Ema.routeUrl now r') randomColor t = let epochSecs = fromMaybe 0 . readMaybe @Int $ formatTime defaultTimeLocale "%s" t colors = ["green", "gray", "purple", "red", "blue", "yellow", "black", "pink"] diff --git a/src/Ema/Generate.hs b/src/Ema/Generate.hs index 00fcb8d..215eae5 100644 --- a/src/Ema/Generate.hs +++ b/src/Ema/Generate.hs @@ -6,8 +6,8 @@ module Ema.Generate where import Control.Exception (throw) import Control.Monad.Logger -import Ema.Asset -import Ema.Class +import Ema.Asset (Asset (..)) +import Ema.Class (Ema (allRoutes, encodeRoute)) import System.Directory (copyFile, createDirectoryIfMissing, doesDirectoryExist, doesFileExist, doesPathExist) import System.FilePath (takeDirectory, ()) import System.FilePattern.Directory (getDirectoryFiles) @@ -38,7 +38,7 @@ generate dest model render = do routes <&> \r -> case render model r of AssetStatic fp -> Left (r, fp) - AssetGenerated _fmt s -> Right (encodeRoute r, s) + AssetGenerated _fmt s -> Right (encodeRoute model r, s) forM_ generatedPaths $ \(relPath, !s) -> do let fp = dest relPath log LevelInfo $ toText $ "W " <> fp @@ -50,7 +50,7 @@ generate dest model render = do True -> -- TODO: In current branch, we don't expect this to be a directory. -- Although the user may pass it, but review before merge. - copyDirRecursively (encodeRoute r) staticPath dest + copyDirRecursively (encodeRoute model r) staticPath dest False -> log LevelWarn $ toText $ "? " <> staticPath <> " (missing)" diff --git a/src/Ema/Route.hs b/src/Ema/Route.hs index 8700458..ed36986 100644 --- a/src/Ema/Route.hs +++ b/src/Ema/Route.hs @@ -19,9 +19,9 @@ import qualified Network.URI.Encode as UE -- -- TODO: Allow a way to configure disabling stripping of .html, since not all -- static site hosts support pretty URLs. -routeUrl :: forall r model. Ema model r => r -> Text -routeUrl = - relUrlFromPath . encodeRoute +routeUrl :: forall r model. Ema model r => model -> r -> Text +routeUrl model = + relUrlFromPath . encodeRoute model where relUrlFromPath :: FilePath -> Text relUrlFromPath fp = diff --git a/src/Ema/Server.hs b/src/Ema/Server.hs index 1f98d1e..c4b6ab9 100644 --- a/src/Ema/Server.hs +++ b/src/Ema/Server.hs @@ -83,7 +83,7 @@ runServerWithWebSocketHotReload port model render = do AssetGenerated Other _s -> -- HACK: Websocket client should check for REDIRECT prefix. -- Not bothering with JSON to avoid having to JSON parse every HTML dump. - liftIO $ WS.sendTextData conn $ "REDIRECT " <> toText (encodeRoute r) + liftIO $ WS.sendTextData conn $ "REDIRECT " <> toText (encodeRoute s r) log LevelDebug $ " ~~> " <> show r loop = flip runLoggingT logger $ do -- Notice that we @askClientForRoute@ in succession twice here. @@ -134,7 +134,7 @@ runServerWithWebSocketHotReload port model render = do let s = html <> emaStatusHtml <> wsClientShim liftIO $ f $ Wai.responseLBS H.status200 [(H.hContentType, "text/html")] s AssetGenerated Other s -> do - let mimeType = Static.getMimeType $ encodeRoute r + let mimeType = Static.getMimeType $ encodeRoute val r liftIO $ f $ Wai.responseLBS H.status200 [(H.hContentType, mimeType)] s renderCatchingErrors logger m r = unsafeCatch (render m r) $ \(err :: SomeException) ->