Add relativize URL's functionality

5 files changed, 49 insertions, 3 deletions

diff --git a/src/Hakyll/Core/Compiler.hs b/src/Hakyll/Core/Compiler.hs
index 57a6d07..0c13c78 100644
--- a/src/Hakyll/Core/Compiler.hs
+++ b/src/Hakyll/Core/Compiler.hs
@@ -43,8 +43,11 @@ runCompiler :: Compiler () CompiledItem  -- ^ Compiler to run
             -> Bool                      -- ^ Was the resource modified?
             -> IO CompiledItem           -- ^ Resulting item
 runCompiler compiler identifier provider lookup' route store modified = do
+    -- Run the compiler job
     CompiledItem result <- runCompilerJob
         compiler identifier provider lookup' route store modified
+
+    -- Store a copy in the cache and return
     storeSet store "Hakyll.Core.Compiler.runCompiler" identifier result
     return $ CompiledItem result
 
@@ -81,7 +84,9 @@ getDependencyOrResult identifier = CompilerM $ do
         Nothing -> fmap (fromMaybe error') $ liftIO $
             storeGet store "Hakyll.Core.Compiler.runCompiler" identifier
   where
-    error' = error "Hakyll.Core.Compiler.getDependency: Not found"
+    error' = error $  "Hakyll.Core.Compiler.getDependency: "
+                   ++ show identifier
+                   ++ " not found in the cache, the cache might be corrupted"
 
 -- | Require another target. Using this function ensures automatic handling of
 -- dependencies
diff --git a/src/Hakyll/Core/Run.hs b/src/Hakyll/Core/Run.hs
index c5e6489..9e6a6ee 100644
--- a/src/Hakyll/Core/Run.hs
+++ b/src/Hakyll/Core/Run.hs
@@ -108,6 +108,8 @@ hakyllWith rules provider store = do
 
     dependencyLookup map' id' = M.lookup id' map'
 
+-- | Return a set of modified identifiers
+--
 modified :: ResourceProvider     -- ^ Resource provider
          -> Store                -- ^ Store
          -> [Identifier]         -- ^ Identifiers to check
diff --git a/src/Hakyll/Web.hs b/src/Hakyll/Web.hs
index bc7710f..536abda 100644
--- a/src/Hakyll/Web.hs
+++ b/src/Hakyll/Web.hs
@@ -3,19 +3,30 @@
 module Hakyll.Web
     ( defaultPageRead
     , defaultTemplateRead
+    , defaultRelativizeUrls
     ) where
 
-import Control.Arrow (arr, (>>>), (>>^))
+import Prelude hiding (id)
+import Control.Category (id)
+import Control.Arrow (arr, (>>>), (>>^), (&&&))
 
 import Hakyll.Core.Compiler
 import Hakyll.Web.Page
 import Hakyll.Web.Pandoc
 import Hakyll.Web.Template
+import Hakyll.Web.RelativizeUrls
+import Hakyll.Web.Util.String
 
 defaultPageRead :: Compiler () (Page String)
 defaultPageRead = cached "Hakyll.Web.defaultPageRead" $
     pageRead >>> addDefaultFields >>> arr applySelf >>> pageRenderPandoc
 
+defaultRelativizeUrls :: Compiler (Page String) (Page String)
+defaultRelativizeUrls = getRoute &&& id >>^ uncurry relativize
+  where
+    relativize Nothing = id
+    relativize (Just r) = fmap (relativizeUrls $ toSiteRoot r)
+
 defaultTemplateRead :: Compiler () Template
 defaultTemplateRead = cached "Hakyll.Web.defaultTemplateRead" $
     getResourceString >>^ readTemplate
diff --git a/src/Hakyll/Web/Page.hs b/src/Hakyll/Web/Page.hs
index 531c951..883da74 100644
--- a/src/Hakyll/Web/Page.hs
+++ b/src/Hakyll/Web/Page.hs
@@ -57,7 +57,6 @@ addDefaultFields =   (getRoute &&& id >>^ uncurry addRoute)
     -- Add root and url, based on route
     addRoute Nothing  = id
     addRoute (Just r) = addField "url" (toUrl r)
-                      . addField "root" (toSiteRoot $ toUrl r)
 
     -- Add title and category, based on identifier
     addIdentifier i = addField "title" (takeBaseName p)
diff --git a/src/Hakyll/Web/RelativizeUrls.hs b/src/Hakyll/Web/RelativizeUrls.hs
new file mode 100644
index 0000000..2a3b98f
--- /dev/null
+++ b/src/Hakyll/Web/RelativizeUrls.hs
@@ -0,0 +1,29 @@
+module Hakyll.Web.RelativizeUrls
+    ( relativizeUrls
+    ) where
+
+import Data.List (isPrefixOf)
+import qualified Data.Set as S
+
+import Text.HTML.TagSoup
+
+-- | Relativize URL's in HTML
+--
+relativizeUrls :: String  -- ^ Path to the site root
+               -> String  -- ^ HTML to relativize
+               -> String  -- ^ Resulting HTML
+relativizeUrls root = renderTags . map relativizeUrls' . parseTags
+  where
+    relativizeUrls' (TagOpen s a) = TagOpen s $ map (relativizeUrlsAttrs root) a
+    relativizeUrls' x = x
+
+-- | Relativize URL's in attributes
+--
+relativizeUrlsAttrs :: String            -- ^ Path to the site root
+                    -> Attribute String  -- ^ Attribute to relativize
+                    -> Attribute String  -- ^ Resulting attribute
+relativizeUrlsAttrs root (key, value)
+    | key `S.member` urls && "/" `isPrefixOf` value = (key, root ++ value)
+    | otherwise = (key, value)
+  where
+    urls = S.fromList ["src", "href"]