From 75f157ca8c319d770f02c38d65226bb3de495a0e Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Tue, 6 Sep 2011 22:26:07 +0200 Subject: [PATCH] Add some URL utilities --- hakyll.cabal | 4 +- src/Hakyll.hs | 8 +-- src/Hakyll/Web/Feed.hs | 2 +- src/Hakyll/Web/Page.hs | 2 +- src/Hakyll/Web/Tags.hs | 2 +- src/Hakyll/Web/Urls.hs | 56 +++++++++++++++++++ .../{RelativizeUrls.hs => Urls/Relativize.hs} | 23 ++------ src/Hakyll/Web/Util/Url.hs | 35 ------------ .../Relativize}/Tests.hs | 4 +- tests/Hakyll/Web/Urls/Tests.hs | 38 +++++++++++++ tests/Hakyll/Web/Util/Url/Tests.hs | 25 --------- tests/TestSuite.hs | 12 ++-- 12 files changed, 115 insertions(+), 96 deletions(-) create mode 100644 src/Hakyll/Web/Urls.hs rename src/Hakyll/Web/{RelativizeUrls.hs => Urls/Relativize.hs} (66%) delete mode 100644 src/Hakyll/Web/Util/Url.hs rename tests/Hakyll/Web/{RelativizeUrls => Urls/Relativize}/Tests.hs (88%) create mode 100644 tests/Hakyll/Web/Urls/Tests.hs delete mode 100644 tests/Hakyll/Web/Util/Url/Tests.hs diff --git a/hakyll.cabal b/hakyll.cabal index 52ef48f..96b656e 100644 --- a/hakyll.cabal +++ b/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 diff --git a/src/Hakyll.hs b/src/Hakyll.hs index 268c9ae..a0e48f5 100644 --- a/src/Hakyll.hs +++ b/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 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 similarity index 66% rename from src/Hakyll/Web/RelativizeUrls.hs rename to 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 @@ -- -- > 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 - 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"] + 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 diff --git a/tests/Hakyll/Web/RelativizeUrls/Tests.hs b/tests/Hakyll/Web/Urls/Relativize/Tests.hs similarity index 88% rename from tests/Hakyll/Web/RelativizeUrls/Tests.hs rename to tests/Hakyll/Web/Urls/Relativize/Tests.hs index 05971ad..00f5a0f 100644 --- a/tests/Hakyll/Web/RelativizeUrls/Tests.hs +++ b/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] diff --git a/tests/Hakyll/Web/Urls/Tests.hs b/tests/Hakyll/Web/Urls/Tests.hs new file mode 100644 index 0000000..db7a10b --- /dev/null +++ b/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" + [ "bar" @=? + withUrls (map toUpper) "bar" + , "" @=? + withUrls (map toUpper) "" + ] + , 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")) + ] + ] diff --git a/tests/Hakyll/Web/Util/Url/Tests.hs b/tests/Hakyll/Web/Util/Url/Tests.hs deleted file mode 100644 index aab4172..0000000 --- a/tests/Hakyll/Web/Util/Url/Tests.hs +++ /dev/null @@ -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" - ] - ] diff --git a/tests/TestSuite.hs b/tests/TestSuite.hs index 0f13106..fdd5e56 100644 --- a/tests/TestSuite.hs +++ b/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 ]