Add some URL utilities

6 files changed, 63 insertions, 57 deletions

diff --git a/src/Hakyll/Web/Feed.hs b/src/Hakyll/Web/Feed.hs
index 27246a2..cd71029 100644
--- a/src/Hakyll/Web/Feed.hs
+++ b/src/Hakyll/Web/Feed.hs
@@ -33,7 +33,7 @@ import Hakyll.Web.Page
 import Hakyll.Web.Page.Metadata
 import Hakyll.Web.Template
 import Hakyll.Web.Template.Read.Hakyll (readTemplate)
-import Hakyll.Web.Util.Url
+import Hakyll.Web.Urls
 
 import Paths_hakyll
 
diff --git a/src/Hakyll/Web/Page.hs b/src/Hakyll/Web/Page.hs
index 6c219b4..e92bb14 100644
--- a/src/Hakyll/Web/Page.hs
+++ b/src/Hakyll/Web/Page.hs
@@ -78,7 +78,7 @@ import Hakyll.Web.Page.Read
 import Hakyll.Web.Page.Metadata
 import Hakyll.Web.Pandoc
 import Hakyll.Web.Template
-import Hakyll.Web.Util.Url
+import Hakyll.Web.Urls
 
 -- | Create a page from a body, without metadata
 --
diff --git a/src/Hakyll/Web/Tags.hs b/src/Hakyll/Web/Tags.hs
index 6ae47fa..c8e45c9 100644
--- a/src/Hakyll/Web/Tags.hs
+++ b/src/Hakyll/Web/Tags.hs
@@ -55,7 +55,7 @@ import qualified Text.Blaze.Html5.Attributes as A
 
 import Hakyll.Web.Page
 import Hakyll.Web.Page.Metadata
-import Hakyll.Web.Util.Url
+import Hakyll.Web.Urls
 import Hakyll.Core.Writable
 import Hakyll.Core.Identifier
 import Hakyll.Core.Compiler
diff --git a/src/Hakyll/Web/Urls.hs b/src/Hakyll/Web/Urls.hs
new file mode 100644
index 0000000..52e9413
--- /dev/null
+++ b/src/Hakyll/Web/Urls.hs
@@ -0,0 +1,56 @@
+-- | Provides utilities to manipulate URL's
+--
+module Hakyll.Web.Urls
+    ( withUrls
+    , toUrl
+    , toSiteRoot
+    , isExternal
+    ) where
+
+import Data.List (isPrefixOf)
+import System.FilePath (splitPath, takeDirectory, joinPath)
+import qualified Data.Set as S
+
+import Text.HTML.TagSoup (Tag (..), renderTags, parseTags)
+
+-- | Apply a function to each URL on a webpage
+--
+withUrls :: (String -> String) -> String -> String
+withUrls f = renderTags . map tag . parseTags
+  where
+    tag (TagOpen s a) = TagOpen s $ map attr a
+    tag x = x
+    attr (k, v) = (k, if k `S.member` refs then f v else v)
+    refs = S.fromList ["src", "href"]
+
+-- | Convert a filepath to an URL starting from the site root
+--
+-- Example:
+--
+-- > toUrl "foo/bar.html"
+--
+-- Result:
+--
+-- > "/foo/bar.html"
+--
+toUrl :: FilePath -> String
+toUrl ('/' : xs) = '/' : xs
+toUrl url        = '/' : url
+
+-- | Get the relative url to the site root, for a given (absolute) url
+--
+toSiteRoot :: String -> String
+toSiteRoot = emptyException . joinPath . map parent
+           . filter relevant . splitPath . takeDirectory
+  where
+    parent = const ".."
+    emptyException [] = "."
+    emptyException x  = x
+    relevant "." = False
+    relevant "/" = False
+    relevant _   = True
+
+-- | Check if an URL links to an external HTTP(S) source
+--
+isExternal :: String -> Bool
+isExternal url = any (flip isPrefixOf url) ["http://", "https://"]
diff --git a/src/Hakyll/Web/RelativizeUrls.hs b/src/Hakyll/Web/Urls/Relativize.hs
index 06b4ae2..f4b7a6c 100644
--- a/src/Hakyll/Web/RelativizeUrls.hs
+++ b/src/Hakyll/Web/Urls/Relativize.hs
@@ -14,7 +14,7 @@
 --
 -- > <img src="../images/lolcat.png" alt="Funny zomgroflcopter" />
 --
-module Hakyll.Web.RelativizeUrls
+module Hakyll.Web.Urls.Relativize
     ( relativizeUrlsCompiler
     , relativizeUrls
     ) where
@@ -23,13 +23,10 @@ import Prelude hiding (id)
 import Control.Category (id)
 import Control.Arrow ((&&&), (>>^))
 import Data.List (isPrefixOf)
-import qualified Data.Set as S
-
-import Text.HTML.TagSoup
 
 import Hakyll.Core.Compiler
 import Hakyll.Web.Page
-import Hakyll.Web.Util.Url
+import Hakyll.Web.Urls
 
 -- | Compiler form of 'relativizeUrls' which automatically picks the right root
 -- path
@@ -45,18 +42,6 @@ relativizeUrlsCompiler = getRoute &&& id >>^ uncurry relativize
 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)
+relativizeUrls root = withUrls rel
   where
-    urls = S.fromList ["src", "href"]
+    rel x = if "/" `isPrefixOf` x then root ++ x else x
diff --git a/src/Hakyll/Web/Util/Url.hs b/src/Hakyll/Web/Util/Url.hs
deleted file mode 100644
index 7ab6717..0000000
--- a/src/Hakyll/Web/Util/Url.hs
+++ /dev/null
@@ -1,35 +0,0 @@
--- | Miscellaneous URL manipulation functions.
---
-module Hakyll.Web.Util.Url
-    ( toUrl
-    , toSiteRoot
-    ) where
-
-import System.FilePath (splitPath, takeDirectory, joinPath)
-
--- | Convert a filepath to an URL starting from the site root
---
--- Example:
---
--- > toUrl "foo/bar.html"
---
--- Result:
---
--- > "/foo/bar.html"
---
-toUrl :: FilePath -> String
-toUrl ('/' : xs) = '/' : xs
-toUrl url        = '/' : url
-
--- | Get the relative url to the site root, for a given (absolute) url
---
-toSiteRoot :: String -> String
-toSiteRoot = emptyException . joinPath . map parent
-           . filter relevant . splitPath . takeDirectory
-  where
-    parent = const ".."
-    emptyException [] = "."
-    emptyException x  = x
-    relevant "." = False
-    relevant "/" = False
-    relevant _   = True