Allow encodeRoute (thus routeUrl) take model as argument

CHANGELOG.md

@@ -15,6 +15,7 @@
   - now returns relative URLs (ie. without the leading `/`)
     - Use the `<base>` 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

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

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')

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"]

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)"
 

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 =

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) ->