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 --- 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 ---------------------- 7 files changed, 106 insertions(+), 100 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 (limited to 'src/Hakyll/Web') 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 -- cgit v1.2.3