Merge branch 'dev-metadata-route'

src/Hakyll/Core/Compiler.hs

@@ -39,6 +39,7 @@ import           System.FilePath               (takeExtension)
 --------------------------------------------------------------------------------
 import           Hakyll.Core.Compiler.Internal
 import qualified Hakyll.Core.Compiler.Require  as Internal
+import           Hakyll.Core.Dependencies
 import           Hakyll.Core.Identifier
 import           Hakyll.Core.Item
 import           Hakyll.Core.Logger            as Logger
@@ -71,8 +72,12 @@ makeItem x = do
 -- | Get the route for a specified item
 getRoute :: Identifier -> Compiler (Maybe FilePath)
 getRoute identifier = do
-    routes <- compilerRoutes <$> compilerAsk
-    return $ runRoutes routes identifier
+    provider <- compilerProvider <$> compilerAsk
+    routes   <- compilerRoutes <$> compilerAsk
+    -- Note that this makes us dependend on that identifier: when the metadata
+    -- of that item changes, the route may change, hence we have to recompile
+    compilerTellDependencies [IdentifierDependency identifier]
+    compilerUnsafeIO $ runRoutes routes provider identifier
 
 
 --------------------------------------------------------------------------------

src/Hakyll/Core/Routes.hs

@@ -35,36 +35,42 @@ module Hakyll.Core.Routes
     , customRoute
     , constRoute
     , gsubRoute
+    , metadataRoute
     , composeRoutes
     ) where
 
 
 --------------------------------------------------------------------------------
-import Data.Monoid (Monoid, mempty, mappend)
-import Control.Monad (mplus)
-import System.FilePath (replaceExtension)
+import           Data.Monoid                    (Monoid, mappend, mempty)
+import           System.FilePath                (replaceExtension)
 
 
 --------------------------------------------------------------------------------
-import Hakyll.Core.Identifier
-import Hakyll.Core.Identifier.Pattern
-import Hakyll.Core.Util.String
+import           Hakyll.Core.Identifier
+import           Hakyll.Core.Identifier.Pattern
+import           Hakyll.Core.Metadata
+import           Hakyll.Core.Provider
+import           Hakyll.Core.Util.String
 
 
 --------------------------------------------------------------------------------
 -- | Type used for a route
-newtype Routes = Routes {unRoutes :: Identifier -> Maybe FilePath}
+newtype Routes = Routes
+    { unRoutes :: Provider -> Identifier -> IO (Maybe FilePath)
+    }
 
 
 --------------------------------------------------------------------------------
 instance Monoid Routes where
-    mempty = Routes $ const Nothing
-    mappend (Routes f) (Routes g) = Routes $ \id' -> f id' `mplus` g id'
+    mempty = Routes $ \_ _ -> return Nothing
+    mappend (Routes f) (Routes g) = Routes $ \p id' -> do
+        mfp <- f p id'
+        maybe (g p id') (return . Just) mfp
 
 
 --------------------------------------------------------------------------------
 -- | Apply a route to an identifier
-runRoutes :: Routes -> Identifier -> Maybe FilePath
+runRoutes :: Routes -> Provider -> Identifier -> IO (Maybe FilePath)
 runRoutes = unRoutes
 
 
@@ -72,7 +78,7 @@ runRoutes = unRoutes
 -- | A route that uses the identifier as filepath. For example, the target with
 -- ID @foo\/bar@ will be written to the file @foo\/bar@.
 idRoute :: Routes
-idRoute = Routes $ Just . toFilePath
+idRoute = customRoute toFilePath
 
 
 --------------------------------------------------------------------------------
@@ -94,23 +100,23 @@ idRoute = Routes $ Just . toFilePath
 --
 -- > Just "posts/the-art-of-trolling.html"
 setExtension :: String -> Routes
-setExtension extension = Routes $
-    fmap (`replaceExtension` extension) . unRoutes idRoute
+setExtension extension = customRoute $
+    (`replaceExtension` extension) . toFilePath
 
 
 --------------------------------------------------------------------------------
 -- | Apply the route if the identifier matches the given pattern, fail
 -- otherwise
 matchRoute :: Pattern -> Routes -> Routes
-matchRoute pattern (Routes route) = Routes $ \id' ->
-    if matches pattern id' then route id' else Nothing
+matchRoute pattern (Routes route) = Routes $ \p id' ->
+    if matches pattern id' then route p id' else return Nothing
 
 
 --------------------------------------------------------------------------------
 -- | Create a custom route. This should almost always be used with
 -- 'matchRoute'
 customRoute :: (Identifier -> FilePath) -> Routes
-customRoute f = Routes $ Just . f
+customRoute f = Routes $ const $ return . Just . f
 
 
 --------------------------------------------------------------------------------
@@ -137,6 +143,14 @@ gsubRoute pattern replacement = customRoute $
     replaceAll pattern replacement . toFilePath
 
 
+--------------------------------------------------------------------------------
+-- | Get access to the metadata in order to determine the route
+metadataRoute :: (Metadata -> Routes) -> Routes
+metadataRoute f = Routes $ \p i -> do
+    metadata <- resourceMetadata p i
+    unRoutes (f metadata) p i
+
+
 --------------------------------------------------------------------------------
 -- | Compose routes so that @f \`composeRoutes\` g@ is more or less equivalent
 -- with @g . f@.
@@ -154,6 +168,6 @@ gsubRoute pattern replacement = customRoute $
 composeRoutes :: Routes  -- ^ First route to apply
               -> Routes  -- ^ Second route to apply
               -> Routes  -- ^ Resulting route
-composeRoutes (Routes f) (Routes g) = Routes $ \i -> do
-    p <- f i
-    g $ fromFilePath p
+composeRoutes (Routes f) (Routes g) = Routes $ \p i -> do
+    mfp <- f p i
+    maybe (return Nothing) (g p . fromFilePath) mfp

src/Hakyll/Core/Runtime.hs

@@ -219,10 +219,11 @@ chase trail id'
                     "(you probably want to call makeItem to solve this problem)"
 
                 -- Write if necessary
-                case runRoutes routes id' of
-                    Nothing  -> return ()
-                    Just url -> do
-                        let path = destinationDirectory config </> url
+                mroute <- liftIO $ runRoutes routes provider id'
+                case mroute of
+                    Nothing    -> return ()
+                    Just route -> do
+                        let path = destinationDirectory config </> route
                         liftIO $ makeDirectories path
                         liftIO $ write path item
                         Logger.debug logger $ "Routed to " ++ path

tests/Hakyll/Core/Routes/Tests.hs

@@ -7,7 +7,7 @@ module Hakyll.Core.Routes.Tests
 
 --------------------------------------------------------------------------------
 import           Test.Framework         (Test, testGroup)
-import           Test.HUnit             ((@=?))
+import           Test.HUnit             (Assertion, (@=?))
 
 
 --------------------------------------------------------------------------------
@@ -19,19 +19,25 @@ import           TestSuite.Util
 --------------------------------------------------------------------------------
 tests :: Test
 tests = testGroup "Hakyll.Core.Routes.Tests" $ fromAssertions "runRoutes"
-    [ Just "foo.html" @=? runRoutes (setExtension "html") "foo"
-    , Just "foo.html" @=? runRoutes (setExtension ".html") "foo"
-    , Just "foo.html" @=? runRoutes (setExtension "html") "foo.markdown"
-    , Just "foo.html" @=? runRoutes (setExtension ".html") "foo.markdown"
+    [ testRoutes "foo.html" (setExtension "html") "foo"
+    , testRoutes "foo.html" (setExtension ".html") "foo"
+    , testRoutes "foo.html" (setExtension "html") "foo.markdown"
+    , testRoutes "foo.html" (setExtension ".html") "foo.markdown"
 
-    , Just "neve ro ddo reven" @=?
-        runRoutes (customRoute (reverse . toFilePath  )) "never odd or even"
+    , testRoutes "neve ro ddo reven"
+        (customRoute (reverse . toFilePath  )) "never odd or even"
 
-    , Just "foo" @=? runRoutes (constRoute "foo") "bar"
+    , testRoutes "foo" (constRoute "foo") "bar"
 
-    , Just "tags/bar.xml" @=?
-        runRoutes (gsubRoute "rss/" (const "")) "tags/rss/bar.xml"
-    , Just "tags/bar.xml" @=?
-        runRoutes (gsubRoute "rss/" (const "") `composeRoutes`
-            setExtension "xml") "tags/rss/bar"
+    , testRoutes "tags/bar.xml" (gsubRoute "rss/" (const "")) "tags/rss/bar.xml"
+    , testRoutes "tags/bar.xml"
+        (gsubRoute "rss/" (const "") `composeRoutes` setExtension "xml")
+        "tags/rss/bar"
     ]
+
+
+--------------------------------------------------------------------------------
+testRoutes :: FilePath -> Routes -> Identifier -> Assertion
+testRoutes expected r id' = do
+    route <- runRoutes r (error "Hakyll.Core.Routes.Tests: no provider") id'
+    Just expected @=? route

tests/Hakyll/Core/Rules/Tests.hs

@@ -38,16 +38,18 @@ case01 = do
     store    <- newTestStore
     provider <- newTestProvider store
     ruleSet  <- runRules (rules01 ioref) provider
-    let identifiers = S.fromList $ map fst $ rulesCompilers ruleSet
-        routes      = rulesRoutes ruleSet
+    let identifiers     = S.fromList $ map fst $ rulesCompilers ruleSet
+        routes          = rulesRoutes ruleSet
+        checkRoute ex i =
+            runRoutes routes provider i >>= \r -> Just ex @=? r
 
     -- Test that we have some identifiers and that the routes work out
     assert $ all (`S.member` identifiers) expected
-    Just "example.html" @=? runRoutes routes "example.md"
-    Just "example.md"   @=? runRoutes routes (sv "raw" "example.md")
-    Just "example.md"   @=? runRoutes routes (sv "nav" "example.md")
-    Just "example.mv1"  @=? runRoutes routes (sv "mv1" "example.md")
-    Just "example.mv2"  @=? runRoutes routes (sv "mv2" "example.md")
+    checkRoute "example.html" "example.md"
+    checkRoute "example.md"   (sv "raw" "example.md")
+    checkRoute "example.md"   (sv "nav" "example.md")
+    checkRoute "example.mv1"  (sv "mv1" "example.md")
+    checkRoute "example.mv2"  (sv "mv2" "example.md")
     readIORef ioref >>= assert
     cleanTestEnv
   where