Add some URL utilities

hakyll.cabal

@@ -115,12 +115,12 @@ Library
     Hakyll.Web.Page.Read
     Hakyll.Web.Pandoc
     Hakyll.Web.Pandoc.FileType
-    Hakyll.Web.RelativizeUrls
     Hakyll.Web.Tags
     Hakyll.Web.Template
     Hakyll.Web.Template.Read
+    Hakyll.Web.Urls
+    Hakyll.Web.Urls.Relativize
     Hakyll.Web.Util.Html
-    Hakyll.Web.Util.Url
 
   Other-Modules:
     Hakyll.Core.Compiler.Internal

src/Hakyll.hs

@@ -26,11 +26,11 @@ module Hakyll
     , module Hakyll.Web.Page.Read
     , module Hakyll.Web.Pandoc
     , module Hakyll.Web.Pandoc.FileType
-    , module Hakyll.Web.RelativizeUrls
+    , module Hakyll.Web.Urls
+    , module Hakyll.Web.Urls.Relativize
     , module Hakyll.Web.Tags
     , module Hakyll.Web.Template
     , module Hakyll.Web.Util.Html
-    , module Hakyll.Web.Util.Url
     ) where
 
 import Hakyll.Core.Compiler
@@ -58,8 +58,8 @@ import Hakyll.Web.Page.Metadata
 import Hakyll.Web.Page.Read
 import Hakyll.Web.Pandoc
 import Hakyll.Web.Pandoc.FileType
-import Hakyll.Web.RelativizeUrls
+import Hakyll.Web.Urls
+import Hakyll.Web.Urls.Relativize
 import Hakyll.Web.Tags
 import Hakyll.Web.Template
 import Hakyll.Web.Util.Html
-import Hakyll.Web.Util.Url

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
 

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
 --

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

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://"]

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
+relativizeUrls root = withUrls rel
   where
-    relativizeUrls' (TagOpen s a) = TagOpen s $ map (relativizeUrlsAttrs root) a
+    rel x = if "/" `isPrefixOf` x then root ++ x else x
-    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"]

src/Hakyll/Web/Util/Url.hs

@@ -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

tests/Hakyll/Web/Urls/Relativize/Tests.hs

@@ -1,12 +1,12 @@
 {-# LANGUAGE OverloadedStrings #-}
-module Hakyll.Web.RelativizeUrls.Tests
+module Hakyll.Web.Urls.Relativize.Tests
     ( tests
     ) where
 
 import Test.Framework
 import Test.HUnit hiding (Test)
 
-import Hakyll.Web.RelativizeUrls
+import Hakyll.Web.Urls.Relativize
 import TestSuite.Util
 
 tests :: [Test]

tests/Hakyll/Web/Urls/Tests.hs

@@ -0,0 +1,38 @@
+module Hakyll.Web.Urls.Tests
+    ( tests
+    ) where
+
+import Data.Char (toUpper)
+
+import Test.Framework
+import Test.HUnit hiding (Test)
+
+import Hakyll.Web.Urls
+import TestSuite.Util
+
+tests :: [Test]
+tests = concat
+    [ fromAssertions "withUrls"
+        [ "<a href=\"FOO\">bar</a>" @=?
+            withUrls (map toUpper) "<a href=\"foo\">bar</a>"
+        , "<img src=\"OH BAR\">" @=?
+            withUrls (map toUpper) "<img src=\"oh bar\">"
+        ]
+    , fromAssertions "toUrl"
+        [ "/foo/bar.html"    @=? toUrl "foo/bar.html"
+        , "/"                @=? toUrl "/"
+        , "/funny-pics.html" @=? toUrl "/funny-pics.html"
+        ]
+    , fromAssertions "toSiteRoot"
+        [ ".."    @=? toSiteRoot "/foo/bar.html"
+        , "."     @=? toSiteRoot "index.html"
+        , "."     @=? toSiteRoot "/index.html"
+        , "../.." @=? toSiteRoot "foo/bar/qux"
+        ]
+    , fromAssertions "isExternal"
+        [ assert (isExternal "http://reddit.com")
+        , assert (isExternal "https://mail.google.com")
+        , assert (not (isExternal "../header.png"))
+        , assert (not (isExternal "/foo/index.html"))
+        ]
+    ]

tests/Hakyll/Web/Util/Url/Tests.hs

@@ -1,25 +0,0 @@
-module Hakyll.Web.Util.Url.Tests
-    ( tests
-    ) where
-
-import Test.Framework
-import Test.HUnit hiding (Test)
-
-import Hakyll.Web.Util.Url
-import TestSuite.Util
-
-tests :: [Test]
-tests = concat
-    [ fromAssertions "toUrl"
-        [ "/foo/bar.html"    @=? toUrl "foo/bar.html"
-        , "/"                @=? toUrl "/"
-        , "/funny-pics.html" @=? toUrl "/funny-pics.html"
-        ]
-
-    , fromAssertions "toSiteRoot"
-        [ ".."    @=? toSiteRoot "/foo/bar.html"
-        , "."     @=? toSiteRoot "index.html"
-        , "."     @=? toSiteRoot "/index.html"
-        , "../.." @=? toSiteRoot "foo/bar/qux"
-        ]
-    ]

tests/TestSuite.hs

@@ -10,10 +10,10 @@ import qualified Hakyll.Core.Store.Tests
 import qualified Hakyll.Core.UnixFilter.Tests
 import qualified Hakyll.Web.Page.Tests
 import qualified Hakyll.Web.Page.Metadata.Tests
-import qualified Hakyll.Web.RelativizeUrls.Tests
 import qualified Hakyll.Web.Template.Tests
+import qualified Hakyll.Web.Urls.Tests
+import qualified Hakyll.Web.Urls.Relativize.Tests
 import qualified Hakyll.Web.Util.Html.Tests
-import qualified Hakyll.Web.Util.Url.Tests
 
 main :: IO ()
 main = defaultMain
@@ -33,12 +33,12 @@ main = defaultMain
         Hakyll.Web.Page.Tests.tests
     , testGroup "Hakyll.Web.Page.Metadata.Tests"
         Hakyll.Web.Page.Metadata.Tests.tests
-    , testGroup "Hakyll.Web.RelativizeUrls.Tests"
-        Hakyll.Web.RelativizeUrls.Tests.tests
     , testGroup "Hakyll.Web.Template.Tests"
         Hakyll.Web.Template.Tests.tests
+    , testGroup "Hakyll.Web.Urls.Tests"
+        Hakyll.Web.Urls.Tests.tests
+    , testGroup "Hakyll.Web.Urls.Relativize.Tests"
+        Hakyll.Web.Urls.Relativize.Tests.tests
     , testGroup "Hakyll.Web.Util.Html.Tests"
         Hakyll.Web.Util.Html.Tests.tests
-    , testGroup "Hakyll.Web.Util.Url.Tests"
-        Hakyll.Web.Util.Url.Tests.tests
     ]