From 75f157ca8c319d770f02c38d65226bb3de495a0e Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Tue, 6 Sep 2011 22:26:07 +0200 Subject: 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/RelativizeUrls.hs | 62 ------------------------------- src/Hakyll/Web/Tags.hs | 2 +- src/Hakyll/Web/Urls.hs | 56 ++++++++++++++++++++++++++++ src/Hakyll/Web/Urls/Relativize.hs | 47 +++++++++++++++++++++++ src/Hakyll/Web/Util/Url.hs | 35 ----------------- tests/Hakyll/Web/RelativizeUrls/Tests.hs | 20 ---------- tests/Hakyll/Web/Urls/Relativize/Tests.hs | 20 ++++++++++ tests/Hakyll/Web/Urls/Tests.hs | 38 +++++++++++++++++++ tests/Hakyll/Web/Util/Url/Tests.hs | 25 ------------- tests/TestSuite.hs | 12 +++--- 14 files changed, 176 insertions(+), 157 deletions(-) delete mode 100644 src/Hakyll/Web/RelativizeUrls.hs create mode 100644 src/Hakyll/Web/Urls.hs create mode 100644 src/Hakyll/Web/Urls/Relativize.hs delete mode 100644 src/Hakyll/Web/Util/Url.hs delete mode 100644 tests/Hakyll/Web/RelativizeUrls/Tests.hs create mode 100644 tests/Hakyll/Web/Urls/Relativize/Tests.hs 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/RelativizeUrls.hs b/src/Hakyll/Web/RelativizeUrls.hs deleted file mode 100644 index 06b4ae2..0000000 --- a/src/Hakyll/Web/RelativizeUrls.hs +++ /dev/null @@ -1,62 +0,0 @@ --- | This module exposes a function which can relativize URL's on a webpage. --- --- This means that one can deploy the resulting site on --- @http:\/\/example.com\/@, but also on @http:\/\/example.com\/some-folder\/@ --- without having to change anything (simply copy over the files). --- --- To use it, you should use absolute URL's from the site root everywhere. For --- example, use --- --- > Funny zomgroflcopter --- --- in a blogpost. When running this through the relativize URL's module, this --- will result in (suppose your blogpost is located at @\/posts\/foo.html@: --- --- > Funny zomgroflcopter --- -module Hakyll.Web.RelativizeUrls - ( relativizeUrlsCompiler - , relativizeUrls - ) where - -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 - --- | Compiler form of 'relativizeUrls' which automatically picks the right root --- path --- -relativizeUrlsCompiler :: Compiler (Page String) (Page String) -relativizeUrlsCompiler = getRoute &&& id >>^ uncurry relativize - where - relativize Nothing = id - relativize (Just r) = fmap (relativizeUrls $ toSiteRoot r) - --- | 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"] 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/Urls/Relativize.hs b/src/Hakyll/Web/Urls/Relativize.hs new file mode 100644 index 0000000..f4b7a6c --- /dev/null +++ b/src/Hakyll/Web/Urls/Relativize.hs @@ -0,0 +1,47 @@ +-- | This module exposes a function which can relativize URL's on a webpage. +-- +-- This means that one can deploy the resulting site on +-- @http:\/\/example.com\/@, but also on @http:\/\/example.com\/some-folder\/@ +-- without having to change anything (simply copy over the files). +-- +-- To use it, you should use absolute URL's from the site root everywhere. For +-- example, use +-- +-- > Funny zomgroflcopter +-- +-- in a blogpost. When running this through the relativize URL's module, this +-- will result in (suppose your blogpost is located at @\/posts\/foo.html@: +-- +-- > Funny zomgroflcopter +-- +module Hakyll.Web.Urls.Relativize + ( relativizeUrlsCompiler + , relativizeUrls + ) where + +import Prelude hiding (id) +import Control.Category (id) +import Control.Arrow ((&&&), (>>^)) +import Data.List (isPrefixOf) + +import Hakyll.Core.Compiler +import Hakyll.Web.Page +import Hakyll.Web.Urls + +-- | Compiler form of 'relativizeUrls' which automatically picks the right root +-- path +-- +relativizeUrlsCompiler :: Compiler (Page String) (Page String) +relativizeUrlsCompiler = getRoute &&& id >>^ uncurry relativize + where + relativize Nothing = id + relativize (Just r) = fmap (relativizeUrls $ toSiteRoot r) + +-- | Relativize URL's in HTML +-- +relativizeUrls :: String -- ^ Path to the site root + -> String -- ^ HTML to relativize + -> String -- ^ Resulting HTML +relativizeUrls root = withUrls rel + where + 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/RelativizeUrls/Tests.hs deleted file mode 100644 index 05971ad..0000000 --- a/tests/Hakyll/Web/RelativizeUrls/Tests.hs +++ /dev/null @@ -1,20 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -module Hakyll.Web.RelativizeUrls.Tests - ( tests - ) where - -import Test.Framework -import Test.HUnit hiding (Test) - -import Hakyll.Web.RelativizeUrls -import TestSuite.Util - -tests :: [Test] -tests = fromAssertions "relativizeUrls" - [ "bar" @=? - relativizeUrls ".." "bar" - , "" @=? - relativizeUrls "../.." "" - , "Haskell" @=? - relativizeUrls "../.." "Haskell" - ] diff --git a/tests/Hakyll/Web/Urls/Relativize/Tests.hs b/tests/Hakyll/Web/Urls/Relativize/Tests.hs new file mode 100644 index 0000000..00f5a0f --- /dev/null +++ b/tests/Hakyll/Web/Urls/Relativize/Tests.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE OverloadedStrings #-} +module Hakyll.Web.Urls.Relativize.Tests + ( tests + ) where + +import Test.Framework +import Test.HUnit hiding (Test) + +import Hakyll.Web.Urls.Relativize +import TestSuite.Util + +tests :: [Test] +tests = fromAssertions "relativizeUrls" + [ "bar" @=? + relativizeUrls ".." "bar" + , "" @=? + relativizeUrls "../.." "" + , "Haskell" @=? + relativizeUrls "../.." "Haskell" + ] 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 ] -- cgit v1.2.3