Add some URL utilities
This commit is contained in:
parent
bf4115eb0f
commit
75f157ca8c
12 changed files with 115 additions and 96 deletions
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
||||
|
|
|
@ -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
|
||||
--
|
||||
|
|
|
@ -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
|
||||
|
|
56
src/Hakyll/Web/Urls.hs
Normal file
56
src/Hakyll/Web/Urls.hs
Normal file
|
@ -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://"]
|
|
@ -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
|
||||
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
|
|
@ -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
|
|
@ -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]
|
38
tests/Hakyll/Web/Urls/Tests.hs
Normal file
38
tests/Hakyll/Web/Urls/Tests.hs
Normal file
|
@ -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"))
|
||||
]
|
||||
]
|
|
@ -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"
|
||||
]
|
||||
]
|
|
@ -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
|
||||
]
|
||||
|
|
Loading…
Reference in a new issue