git.iko.soy/hakyll
on master help sign in
Add relativize URL's functionality
commit0969fe41c7c94c34e5663ed231ecbb9e2c4bc051 authorJasper Van der Jeugt <jaspervdj@gmail.com> dateTue 4 Jan 2011, 11:13 (16 years ago) parente395b0a
5 files changed+49−3
compare with master
unifiedsplit
src/Hakyll/Core/Compiler.hs+6−1 src/Hakyll/Core/Run.hs+2 src/Hakyll/Web.hs+12−1 src/Hakyll/Web/Page.hs−1 src/Hakyll/Web/RelativizeUrls.hs+29
src/Hakyll/Core/Compiler.hs+6−1
@@ -43,8 +43,11 @@ runCompiler :: Compiler () CompiledItem -- ^ Compiler to run
4343 -> Bool -- ^ Was the resource modified?
4444 -> IO CompiledItem -- ^ Resulting item
4545runCompiler compiler identifier provider lookup' route store modified = do
46+ -- Run the compiler job
4647 CompiledItem result <- runCompilerJob
4748 compiler identifier provider lookup' route store modified
49+
50+ -- Store a copy in the cache and return
4851 storeSet store "Hakyll.Core.Compiler.runCompiler" identifier result
4952 return $ CompiledItem result
5053
@@ -81,7 +84,9 @@ getDependencyOrResult identifier = CompilerM $ do
8184 Nothing -> fmap (fromMaybe error') $ liftIO $
8285 storeGet store "Hakyll.Core.Compiler.runCompiler" identifier
8386 where
84− error' = error "Hakyll.Core.Compiler.getDependency: Not found"
87+ error' = error $ "Hakyll.Core.Compiler.getDependency: "
88+ ++ show identifier
89+ ++ " not found in the cache, the cache might be corrupted"
8590
8691-- | Require another target. Using this function ensures automatic handling of
8792-- dependencies
src/Hakyll/Core/Run.hs+2
@@ -108,6 +108,8 @@ hakyllWith rules provider store = do
108108
109109 dependencyLookup map' id' = M.lookup id' map'
110110
111+-- | Return a set of modified identifiers
112+--
111113modified :: ResourceProvider -- ^ Resource provider
112114 -> Store -- ^ Store
113115 -> [Identifier] -- ^ Identifiers to check
src/Hakyll/Web.hs+12−1
@@ -3,19 +3,30 @@
33module Hakyll.Web
44 ( defaultPageRead
55 , defaultTemplateRead
6+ , defaultRelativizeUrls
67 ) where
78
8−import Control.Arrow (arr, (>>>), (>>^))
9+import Prelude hiding (id)
10+import Control.Category (id)
11+import Control.Arrow (arr, (>>>), (>>^), (&&&))
912
1013import Hakyll.Core.Compiler
1114import Hakyll.Web.Page
1215import Hakyll.Web.Pandoc
1316import Hakyll.Web.Template
17+import Hakyll.Web.RelativizeUrls
18+import Hakyll.Web.Util.String
1419
1520defaultPageRead :: Compiler () (Page String)
1621defaultPageRead = cached "Hakyll.Web.defaultPageRead" $
1722 pageRead >>> addDefaultFields >>> arr applySelf >>> pageRenderPandoc
1823
24+defaultRelativizeUrls :: Compiler (Page String) (Page String)
25+defaultRelativizeUrls = getRoute &&& id >>^ uncurry relativize
26+ where
27+ relativize Nothing = id
28+ relativize (Just r) = fmap (relativizeUrls $ toSiteRoot r)
29+
1930defaultTemplateRead :: Compiler () Template
2031defaultTemplateRead = cached "Hakyll.Web.defaultTemplateRead" $
2132 getResourceString >>^ readTemplate
src/Hakyll/Web/Page.hs−1
@@ -57,7 +57,6 @@ addDefaultFields = (getRoute &&& id >>^ uncurry addRoute)
5757 -- Add root and url, based on route
5858 addRoute Nothing = id
5959 addRoute (Just r) = addField "url" (toUrl r)
60− . addField "root" (toSiteRoot $ toUrl r)
6160
6261 -- Add title and category, based on identifier
6362 addIdentifier i = addField "title" (takeBaseName p)
src/Hakyll/Web/RelativizeUrls.hsnew file+29
@@ -0,0 +1,29 @@
1+module Hakyll.Web.RelativizeUrls
2+ ( relativizeUrls
3+ ) where
4+
5+import Data.List (isPrefixOf)
6+import qualified Data.Set as S
7+
8+import Text.HTML.TagSoup
9+
10+-- | Relativize URL's in HTML
11+--
12+relativizeUrls :: String -- ^ Path to the site root
13+ -> String -- ^ HTML to relativize
14+ -> String -- ^ Resulting HTML
15+relativizeUrls root = renderTags . map relativizeUrls' . parseTags
16+ where
17+ relativizeUrls' (TagOpen s a) = TagOpen s $ map (relativizeUrlsAttrs root) a
18+ relativizeUrls' x = x
19+
20+-- | Relativize URL's in attributes
21+--
22+relativizeUrlsAttrs :: String -- ^ Path to the site root
23+ -> Attribute String -- ^ Attribute to relativize
24+ -> Attribute String -- ^ Resulting attribute
25+relativizeUrlsAttrs root (key, value)
26+ | key `S.member` urls && "/" `isPrefixOf` value = (key, root ++ value)
27+ | otherwise = (key, value)
28+ where
29+ urls = S.fromList ["src", "href"]