Simplify FileRoute further by using FilePath instead of [Slug]

ema.cabal

@@ -115,7 +115,6 @@ library
     Ema.Generate
     Ema.Route
     Ema.Route.Slug
-    Ema.Route.UrlStrategy
     Ema.Server
 
   if flag(with-examples)

src/Ema/Example/Ex02_Basic.hs

@@ -26,13 +26,13 @@ data Route
 data Model = Model Text
 
 instance FileRoute Route where
-  encodeRoute =
+  encodeFileRoute =
-    Ema.htmlSlugs . \case
+    \case
-      Index -> mempty
+      Index -> "index.html"
-      About -> one "about"
+      About -> "about.html"
-  decodeRoute = \case
+  decodeFileRoute = \case
-    [] -> Just Index
+    "index.html" -> Just Index
-    ["about"] -> Just About
+    "about.html" -> Just About
     _ -> Nothing
 
 main :: IO ()

src/Ema/Example/Ex03_Clock.hs

@@ -27,13 +27,12 @@ data Route
   deriving (Show, Enum, Bounded)
 
 instance FileRoute Route where
-  encodeRoute =
+  encodeFileRoute = \case
-    Ema.htmlSlugs . \case
+    Index -> "index.html"
-      Index -> mempty
+    OnlyTime -> "time.html"
-      OnlyTime -> one "time"
+  decodeFileRoute = \case
-  decodeRoute = \case
+    "index.html" -> Just Index
-    [] -> Just Index
+    "time.html" -> Just OnlyTime
-    ["time"] -> Just OnlyTime
     _ -> Nothing
 
 main :: IO ()

src/Ema/Generate.hs

@@ -6,7 +6,7 @@ module Ema.Generate where
 
 import Control.Exception (throw)
 import Control.Monad.Logger
-import Ema.Route (FileRoute, routeFile)
+import Ema.Route (FileRoute (encodeFileRoute))
 import System.Directory (copyFile, createDirectoryIfMissing, doesDirectoryExist, doesFileExist, doesPathExist)
 import System.FilePath (takeDirectory, (</>))
 import System.FilePattern.Directory (getDirectoryFiles)
@@ -33,7 +33,7 @@ generate dest model staticAssets routes render = do
     error $ "Destination does not exist: " <> toText dest
   log LevelInfo $ "Writing " <> show (length routes) <> " routes"
   forM_ routes $ \r -> do
-    let fp = dest </> routeFile r
+    let fp = dest </> encodeFileRoute r
     log LevelInfo $ toText $ "W " <> fp
     let !s = render model r
     liftIO $ do

src/Ema/Helper/FileSystem.hs

@@ -35,7 +35,7 @@ import System.FSNotify
     withManager,
   )
 import System.FilePath (isRelative, makeRelative)
-import System.FilePattern (FilePattern, matchMany, (?==))
+import System.FilePattern (FilePattern, (?==))
 import System.FilePattern.Directory (getDirectoryFilesIgnore)
 import UnliftIO (MonadUnliftIO, toIO, withRunInIO)
 

src/Ema/Route.hs

@@ -3,52 +3,66 @@
 
 module Ema.Route
   ( FileRoute (..),
-    htmlSlugs,
     routeUrl,
-    routeFile,
+    decodeUrlRoute,
     Slug (unSlug),
     decodeSlug,
     encodeSlug,
-    UrlStrategy (..),
   )
 where
 
-import Data.Default (def)
+import qualified Data.List.NonEmpty as NE
-import Ema.Route.Slug (Slug (unSlug), decodeSlug, encodeSlug)
+import qualified Data.Text as T
-import Ema.Route.UrlStrategy
+import Ema.Route.Slug (Slug (unSlug), decodeSlug, encodeSlug, unicodeNormalize)
-  ( UrlStrategy (..),
+import qualified Network.URI.Encode as UE
-    slugFileWithStrategy,
+import System.FilePath ((</>))
-    slugRelUrlWithStrategy,
-  )
 
 -- | Route to a generated file.
 class FileRoute route where
   -- | Slug path as well as the extension of the file corresponding to this
   -- route.
-  encodeRoute :: route -> ([Slug], String)
+  encodeFileRoute :: route -> FilePath
 
   -- | Decode a slug path into a route. The final component of the slug path
   -- will contain the extension if there is any.
-  decodeRoute :: [Slug] -> Maybe route
+  decodeFileRoute :: FilePath -> Maybe route
-
-htmlSlugs :: [Slug] -> ([Slug], String)
-htmlSlugs = (,".html")
 
 -- | The unit model is useful when using Ema in pure fashion (see @Ema.runEmaPure@) with a single route (index.html) only.
 instance FileRoute () where
-  encodeRoute () = ([], ".html")
+  encodeFileRoute () = "index.html"
-  decodeRoute = \case
+  decodeFileRoute = \case
-    [] -> Just ()
+    "index.html" -> Just ()
     _ -> Nothing
 
+-- | Decode a URL path into a route
+decodeUrlRoute :: FileRoute route => Text -> Maybe route
+decodeUrlRoute (toString -> s) =
+  decodeFileRoute s
+    <|> decodeFileRoute (s <> ".html")
+    <|> decodeFileRoute (s </> "index.html")
+
 -- | Return the relative URL of the given route
 --
 -- As the returned URL is relative, you will have to either make it absolute (by
 -- prepending with `/`) or set the `<base>` URL in your HTML head element.
 routeUrl :: forall r. FileRoute r => r -> Text
-routeUrl r =
+routeUrl =
-  slugRelUrlWithStrategy def (encodeRoute r)
+  relUrlFromPath . encodeFileRoute
-
+  where
-routeFile :: forall r. FileRoute r => r -> FilePath
+    relUrlFromPath :: FilePath -> Text
-routeFile r =
+    relUrlFromPath fp =
-  slugFileWithStrategy def (encodeRoute r)
+      case T.stripSuffix ".html" (toText fp) of
+        Just htmlFp ->
+          case nonEmpty (UE.encodeText . unicodeNormalize <$> T.splitOn "/" htmlFp) of
+            Nothing ->
+              ""
+            Just (removeLastIf "index" -> partsSansIndex) ->
+              T.intercalate "/" partsSansIndex
+        Nothing ->
+          UE.encodeText . unicodeNormalize . toText $ fp
+      where
+        removeLastIf :: Eq a => a -> NonEmpty a -> [a]
+        removeLastIf x xs =
+          if NE.last xs == x
+            then NE.init xs
+            else toList xs

src/Ema/Route/Slug.hs

@@ -31,7 +31,8 @@ instance IsString Slug where
     if "/" `T.isInfixOf` s
       then error ("Slug cannot contain a slash: " <> s)
       else Slug (unicodeNormalize s)
-    where
+
-      -- Normalize varying non-ascii strings (in filepaths / slugs) to one
+-- Normalize varying non-ascii strings (in filepaths / slugs) to one
-      -- representation, so that they can be reliably linked to.
+-- representation, so that they can be reliably linked to.
-      unicodeNormalize = UT.normalize UT.NFC . toText
+unicodeNormalize :: Text -> Text
+unicodeNormalize = UT.normalize UT.NFC . toText

src/Ema/Route/UrlStrategy.hs

@@ -1,49 +0,0 @@
-{-# LANGUAGE InstanceSigs #-}
-{-# LANGUAGE QuasiQuotes #-}
-
-module Ema.Route.UrlStrategy where
-
-import Data.Default (Default, def)
-import qualified Data.List.NonEmpty as NE
-import qualified Data.Text as T
-import Ema.Route.Slug (Slug (unSlug), decodeSlug, encodeSlug)
-import System.FilePath (joinPath)
-
-data UrlStrategy
-  = -- | URLs always end with a slash, and correspond to index.html in that folder
-    UrlStrategy_FolderOnly
-  | -- | Pretty URLs without ugly .html ext or slash-suffix
-    UrlStrategy_HtmlOnlySansExt
-  deriving (Eq, Show, Ord)
-
-instance Default UrlStrategy where
-  def = UrlStrategy_HtmlOnlySansExt
-
-slugRelUrlWithStrategy :: UrlStrategy -> ([Slug], String) -> Text
-slugRelUrlWithStrategy strat (slugs, ".html") =
-  case strat of
-    UrlStrategy_FolderOnly ->
-      T.intercalate "/" (encodeSlug <$> slugs)
-    UrlStrategy_HtmlOnlySansExt ->
-      case nonEmpty slugs of
-        Nothing ->
-          ""
-        Just (removeLastIf (decodeSlug "index") -> slugsWithoutIndex) ->
-          T.intercalate "/" (encodeSlug <$> slugsWithoutIndex)
-  where
-    removeLastIf :: Eq a => a -> NonEmpty a -> [a]
-    removeLastIf x xs =
-      if NE.last xs == x
-        then NE.init xs
-        else toList xs
-slugRelUrlWithStrategy _ (slugs, ext) =
-  T.intercalate "/" (encodeSlug <$> slugs) <> toText ext
-
-slugFileWithStrategy :: UrlStrategy -> ([Slug], String) -> FilePath
-slugFileWithStrategy strat (slugs, ext) =
-  case strat of
-    UrlStrategy_FolderOnly ->
-      joinPath $ fmap (toString . unSlug) slugs <> ["index" <> ext]
-    UrlStrategy_HtmlOnlySansExt ->
-      let (term :| (reverse -> parts)) = fromMaybe ("index" :| []) $ nonEmpty (reverse $ fmap (toString . unSlug) slugs)
-       in joinPath $ parts <> [term <> ext]

src/Ema/Server.hs

@@ -9,8 +9,7 @@ import Control.Monad.Logger
 import Data.LVar (LVar)
 import qualified Data.LVar as LVar
 import qualified Data.Text as T
-import Ema.Route (FileRoute (..))
+import Ema.Route (FileRoute (..), decodeUrlRoute)
-import qualified Ema.Route.Slug as Slug
 import GHC.IO.Unsafe (unsafePerformIO)
 import NeatInterpolation (text)
 import qualified Network.HTTP.Types as H
@@ -128,7 +127,7 @@ runServerWithWebSocketHotReload port model render = do
                 <> show @Text err
                 <> "</pre><p>Once you fix your code this page will automatically update.</body>"
     routeFromPathInfo =
-      decodeRoute @route . fmap Slug.decodeSlug
+      decodeUrlRoute @route . T.intercalate "/"
     -- TODO: It would be good have this also get us the stack trace.
     unsafeCatch :: Exception e => a -> (e -> a) -> a
     unsafeCatch x f = unsafePerformIO $ catch (seq x $ pure x) (pure . f)