diff --git a/hakyll.cabal b/hakyll.cabal --- a/hakyll.cabal +++ b/hakyll.cabal @@ -1,5 +1,5 @@ Name: hakyll -Version: 4.3.0.0 +Version: 4.3.1.0 Synopsis: A static website compiler library Description: @@ -143,6 +143,7 @@ blaze-markup >= 0.5.1 && < 0.6, bytestring >= 0.9 && < 0.11, citeproc-hs >= 0.3.2 && < 0.4, + cmdargs >= 0.10 && < 0.11, containers >= 0.3 && < 0.6, cryptohash >= 0.7 && < 0.10, data-default >= 0.4 && < 0.6, @@ -151,9 +152,9 @@ filepath >= 1.0 && < 1.4, lrucache >= 1.1.1 && < 1.2, mtl >= 1 && < 2.2, + network >= 2.4 && < 2.5, old-locale >= 1.0 && < 1.1, old-time >= 1.0 && < 1.2, - cmdargs >= 0.10 && < 0.11, pandoc >= 1.10 && < 1.12, parsec >= 3.0 && < 3.2, process >= 1.0 && < 1.2, @@ -219,6 +220,7 @@ blaze-markup >= 0.5.1 && < 0.6, bytestring >= 0.9 && < 0.11, citeproc-hs >= 0.3.2 && < 0.4, + cmdargs >= 0.10 && < 0.11, containers >= 0.3 && < 0.6, cryptohash >= 0.7 && < 0.10, data-default >= 0.4 && < 0.6, @@ -227,9 +229,9 @@ filepath >= 1.0 && < 1.4, lrucache >= 1.1.1 && < 1.2, mtl >= 1 && < 2.2, + network >= 2.4 && < 2.5, old-locale >= 1.0 && < 1.1, old-time >= 1.0 && < 1.2, - cmdargs >= 0.10 && < 0.11, pandoc >= 1.10 && < 1.12, parsec >= 3.0 && < 3.2, process >= 1.0 && < 1.2, diff --git a/src/Hakyll/Core/Util/String.hs b/src/Hakyll/Core/Util/String.hs --- a/src/Hakyll/Core/Util/String.hs +++ b/src/Hakyll/Core/Util/String.hs @@ -1,5 +1,5 @@ +-------------------------------------------------------------------------------- -- | Miscellaneous string manipulation functions. --- module Hakyll.Core.Util.String ( trim , replaceAll @@ -7,21 +7,24 @@ , needlePrefix ) where + +-------------------------------------------------------------------------------- import Data.Char (isSpace) import Data.List (isPrefixOf) import Data.Maybe (listToMaybe) - import Text.Regex.TDFA ((=~~)) + +-------------------------------------------------------------------------------- -- | Trim a string (drop spaces, tabs and newlines at both sides). --- trim :: String -> String trim = reverse . trim' . reverse . trim' where trim' = dropWhile isSpace + +-------------------------------------------------------------------------------- -- | A simple (but inefficient) regex replace funcion --- replaceAll :: String -- ^ Pattern -> (String -> String) -- ^ Replacement (called on capture) -> String -- ^ Source string @@ -35,9 +38,10 @@ (capture, after) = splitAt l tmp in before ++ f capture ++ replaceAll' after + +-------------------------------------------------------------------------------- -- | A simple regex split function. The resulting list will contain no empty -- strings. --- splitAll :: String -- ^ Pattern -> String -- ^ String to split -> [String] -- ^ Result @@ -50,19 +54,24 @@ in before : splitAll' (drop l tmp) --- | Find the first instance of needle (must be non-empty) in --- haystack. We return the prefix of haystack before needle is --- matched. + +-------------------------------------------------------------------------------- +-- | Find the first instance of needle (must be non-empty) in haystack. We +-- return the prefix of haystack before needle is matched. -- -- Examples: --- needlePrefix "cd" "abcde" = "ab" --- needlePrefix "ab" "abc" = "" --- needlePrefix "ab" "xxab" = "xx" --- needlePrefix "a" "xx" = "xx" -- -needlePrefix :: String -> String -> String -needlePrefix needle haystack = go haystack +-- > needlePrefix "cd" "abcde" = "ab" +-- +-- > needlePrefix "ab" "abc" = "" +-- +-- > needlePrefix "ab" "xxab" = "xx" +-- +-- > needlePrefix "a" "xx" = "xx" +needlePrefix :: String -> String -> Maybe String +needlePrefix needle haystack = go [] haystack where - go [] = [] - go xss@(x:xs) | needle `isPrefixOf` xss = [] - | otherwise = x : go xs + go _ [] = Nothing + go acc xss@(x:xs) + | needle `isPrefixOf` xss = Just $ reverse acc + | otherwise = go (x : acc) xs diff --git a/src/Hakyll/Web/Html.hs b/src/Hakyll/Web/Html.hs --- a/src/Hakyll/Web/Html.hs +++ b/src/Hakyll/Web/Html.hs @@ -30,6 +30,7 @@ import Text.Blaze.Html (toHtml) import Text.Blaze.Html.Renderer.String (renderHtml) import qualified Text.HTML.TagSoup as TS +import Network.URI (isUnreserved, escapeURIString) -------------------------------------------------------------------------------- @@ -98,9 +99,18 @@ -- Result: -- -- > "/foo/bar.html" +-- +-- This also sanitizes the URL, e.g. converting spaces into '%20' toUrl :: FilePath -> String -toUrl ('/' : xs) = '/' : xs -toUrl url = '/' : url +toUrl url = case url of + ('/' : xs) -> '/' : sanitize xs + xs -> '/' : sanitize xs + where + -- Everything but unreserved characters should be escaped as we are + -- sanitising the path therefore reserved characters which have a + -- meaning in URI does not appear. Special casing for `/`, because it has + -- a special meaning in FilePath as well as in URI. + sanitize = escapeURIString (\c -> c == '/' || isUnreserved c) -------------------------------------------------------------------------------- diff --git a/src/Hakyll/Web/Template/Context.hs b/src/Hakyll/Web/Template/Context.hs --- a/src/Hakyll/Web/Template/Context.hs +++ b/src/Hakyll/Web/Template/Context.hs @@ -242,9 +242,13 @@ teaserField :: String -- ^ Key to use -> Snapshot -- ^ Snapshot to load -> Context String -- ^ Resulting context -teaserField key snapshot = field key $ \item -> - (needlePrefix teaserSeparator . itemBody) <$> - loadSnapshot (itemIdentifier item) snapshot +teaserField key snapshot = field key $ \item -> do + body <- itemBody <$> loadSnapshot (itemIdentifier item) snapshot + case needlePrefix teaserSeparator body of + Nothing -> fail $ + "Hakyll.Web.Template.Context: no teaser defined for " ++ + show (itemIdentifier item) + Just t -> return t -------------------------------------------------------------------------------- diff --git a/tests/Hakyll/Core/Util/String/Tests.hs b/tests/Hakyll/Core/Util/String/Tests.hs --- a/tests/Hakyll/Core/Util/String/Tests.hs +++ b/tests/Hakyll/Core/Util/String/Tests.hs @@ -30,13 +30,13 @@ ] , fromAssertions "needlePrefix" - [ "ab" @=? needlePrefix "cd" "abcde" - , "xx" @=? needlePrefix "ab" "xxab" - , "xx" @=? needlePrefix "a" "xx" - , "x" @=? needlePrefix "ab" "xabxab" - , "" @=? needlePrefix "ab" "abc" - , "" @=? needlePrefix "ab" "abab" - , "" @=? needlePrefix "" "" + [ Just "ab" @=? needlePrefix "cd" "abcde" + , Just "xx" @=? needlePrefix "ab" "xxab" + , Nothing @=? needlePrefix "a" "xx" + , Just "x" @=? needlePrefix "ab" "xabxab" + , Just "" @=? needlePrefix "ab" "abc" + , Just "" @=? needlePrefix "ab" "abab" + , Nothing @=? needlePrefix "" "" ] ] diff --git a/tests/Hakyll/Web/Html/Tests.hs b/tests/Hakyll/Web/Html/Tests.hs --- a/tests/Hakyll/Web/Html/Tests.hs +++ b/tests/Hakyll/Web/Html/Tests.hs @@ -43,9 +43,15 @@ ] , fromAssertions "toUrl" - [ "/foo/bar.html" @=? toUrl "foo/bar.html" - , "/" @=? toUrl "/" - , "/funny-pics.html" @=? toUrl "/funny-pics.html" + [ "/foo/bar.html" @=? toUrl "foo/bar.html" + , "/" @=? toUrl "/" + , "/funny-pics.html" @=? toUrl "/funny-pics.html" + , "/funny%20pics.html" @=? toUrl "funny pics.html" + -- Test various reserved characters (RFC 3986, section 2.2) + , "/%21%2A%27%28%29%3B%3A%40%26.html" @=? toUrl "/!*'();:@&.html" + , "/%3D%2B%24%2C/%3F%23%5B%5D.html" @=? toUrl "=+$,/?#[].html" + -- Test various characters that are nor reserved, nor unreserved. + , "/%E3%81%82%F0%9D%90%87%E2%88%80" @=? toUrl "\12354\119815\8704" ] , fromAssertions "toSiteRoot"