1 files changed, 29 insertions, 0 deletions
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"]