on master help sign in
Start provider rewrite
86d0b68Jasper Van der Jeugt
hakyll.cabal−1
@@ -151,7 +151,6 @@ Library
151 Hakyll.Core.Provider.Internal
151 Hakyll.Core.Provider.Internal
152 Hakyll.Core.Provider.Metadata
152 Hakyll.Core.Provider.Metadata
153 Hakyll.Core.Provider.MetadataCache
153 Hakyll.Core.Provider.MetadataCache
154− Hakyll.Core.Provider.Modified
155 Hakyll.Core.Rules.Internal
154 Hakyll.Core.Rules.Internal
156 Hakyll.Core.Runtime
155 Hakyll.Core.Runtime
157 Hakyll.Core.Store
156 Hakyll.Core.Store
src/Hakyll/Core/Compiler.hs+1−1
@@ -131,7 +131,7 @@ cached name compiler = do
131 id' <- compilerUnderlying <$> compilerAsk
131 id' <- compilerUnderlying <$> compilerAsk
132 store <- compilerStore <$> compilerAsk
132 store <- compilerStore <$> compilerAsk
133 provider <- compilerProvider <$> compilerAsk
133 provider <- compilerProvider <$> compilerAsk
134− modified <- compilerUnsafeIO $ resourceModified provider id'
134+ let modified = resourceModified provider id'
135 if modified
135 if modified
136 then do
136 then do
137 x <- compiler
137 x <- compiler
src/Hakyll/Core/Provider.hs+25−26
@@ -3,44 +3,43 @@
3-- caching.
3-- caching.
4module Hakyll.Core.Provider
4module Hakyll.Core.Provider
5 ( -- * Constructing resource providers
5 ( -- * Constructing resource providers
6− Provider
6+ Internal.Provider
7 , newProvider
7 , newProvider
8
8
9 -- * Querying resource properties
9 -- * Querying resource properties
10− , resourceList
10+ , Internal.resourceList
11− , resourceExists
11+ , Internal.resourceExists
12− , resourceModified
12+ , Internal.resourceModified
13− , resourceModificationTime
13+ , Internal.resourceModificationTime
14
14
15 -- * Access to raw resource content
15 -- * Access to raw resource content
16− , resourceString
16+ , Internal.resourceString
17− , resourceLBS
17+ , Internal.resourceLBS
18
18
19 -- * Access to metadata and body content
19 -- * Access to metadata and body content
20− , resourceMetadata
20+ , Internal.resourceMetadata
21− , resourceBody
21+ , Internal.resourceBody
22 ) where
22 ) where
23
23
24
24
25--------------------------------------------------------------------------------
25--------------------------------------------------------------------------------
26−import Hakyll.Core.Identifier
26+import Control.Monad (forM_)
27−import Hakyll.Core.Metadata
28−import Hakyll.Core.Provider.Internal
27+import qualified Hakyll.Core.Provider.Internal as Internal
29import qualified Hakyll.Core.Provider.MetadataCache as Internal
28import qualified Hakyll.Core.Provider.MetadataCache as Internal
30−import Hakyll.Core.Provider.Modified
29+import Hakyll.Core.Store (Store)
31
30
32
31
33--------------------------------------------------------------------------------
32--------------------------------------------------------------------------------
34−-- | Wrapper to ensure metadata cache is invalidated if necessary
33+-- | Create a resource provider
35−resourceMetadata :: Provider -> Identifier -> IO Metadata
34+newProvider :: Store -- ^ Store to use
36−resourceMetadata rp r = do
35+ -> (FilePath -> Bool) -- ^ Should we ignore this file?
37− _ <- resourceModified rp r
36+ -> FilePath -- ^ Search directory
38− Internal.resourceMetadata rp r
37+ -> IO Internal.Provider -- ^ Resulting provider
39−
38+newProvider store ignore directory = do
40−
39+ -- Delete metadata cache where necessary
41−--------------------------------------------------------------------------------
40+ provider <- Internal.newProvider store ignore directory
42−-- | Wrapper to ensure metadata cache is invalidated if necessary
41+ forM_ (Internal.resourceList provider) $ \identifier ->
43−resourceBody :: Provider -> Identifier -> IO String
44−resourceBody rp r = do
45− _ <- resourceModified rp r
42+ if Internal.resourceModified provider identifier
46− Internal.resourceBody rp r
43+ then Internal.resourceInvalidateMetadataCache provider identifier
44+ else return ()
45+ return provider
src/Hakyll/Core/Provider/Internal.hs+132−23
@@ -1,46 +1,103 @@
1--------------------------------------------------------------------------------
1--------------------------------------------------------------------------------
2+{-# LANGUAGE CPP #-}
3+{-# LANGUAGE DeriveDataTypeable #-}
4+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
2module Hakyll.Core.Provider.Internal
5module Hakyll.Core.Provider.Internal
6+ ( ResourceInfo (..)
3− ( Provider (..)
7+ , Provider (..)
4 , newProvider
8 , newProvider
5
9
6 , resourceList
10 , resourceList
7 , resourceExists
11 , resourceExists
8− , resourceMetadataResource
9
12
10 , resourceFilePath
13 , resourceFilePath
11 , resourceString
14 , resourceString
12 , resourceLBS
15 , resourceLBS
16+
17+ , resourceModified
18+ , resourceModificationTime
13 ) where
19 ) where
14
20
15
21
16--------------------------------------------------------------------------------
22--------------------------------------------------------------------------------
17−import Control.Applicative ((<$>))
23+import Control.Applicative ((<$>), (<*>))
24+import Control.DeepSeq (NFData (..), deepseq)
25+import Control.Monad (forM)
26+import Data.Binary (Binary (..))
18import qualified Data.ByteString.Lazy as BL
27import qualified Data.ByteString.Lazy as BL
19−import Data.IORef
20import Data.Map (Map)
28import Data.Map (Map)
21import qualified Data.Map as M
29import qualified Data.Map as M
30+import Data.Maybe (fromMaybe)
31+import Data.Monoid (mempty)
22import Data.Set (Set)
32import Data.Set (Set)
23import qualified Data.Set as S
33import qualified Data.Set as S
34+import Data.Time (Day (..), UTCTime (..),
35+ secondsToDiffTime)
36+import Data.Typeable (Typeable)
37+import System.Directory (getModificationTime)
24import System.FilePath (addExtension, (</>))
38import System.FilePath (addExtension, (</>))
25
39
26
40
41+--------------------------------------------------------------------------------
42+#if !MIN_VERSION_directory(1,2,0)
43+import Data.Time (readTime)
44+import System.Locale (defaultTimeLocale)
45+import System.Time (formatCalendarTime, toCalendarTime)
46+#endif
47+
48+
27--------------------------------------------------------------------------------
49--------------------------------------------------------------------------------
28import Hakyll.Core.Identifier
50import Hakyll.Core.Identifier
29−import Hakyll.Core.Store
51+import Hakyll.Core.Store (Store)
52+import qualified Hakyll.Core.Store as Store
30import Hakyll.Core.Util.File
53import Hakyll.Core.Util.File
31
54
32
55
56+--------------------------------------------------------------------------------
57+-- | Because UTCTime doesn't have a Binary instance...
58+newtype BinaryTime = BinaryTime {unBinaryTime :: UTCTime}
59+ deriving (Eq, NFData, Ord, Show, Typeable)
60+
61+
62+--------------------------------------------------------------------------------
63+instance Binary BinaryTime where
64+ put (BinaryTime (UTCTime (ModifiedJulianDay d) dt)) =
65+ put d >> put (floor dt :: Integer)
66+
67+ get = fmap BinaryTime $ UTCTime
68+ <$> (ModifiedJulianDay <$> get)
69+ <*> (secondsToDiffTime <$> get)
70+
71+
72+--------------------------------------------------------------------------------
73+data ResourceInfo = ResourceInfo
74+ { resourceInfoModified :: BinaryTime
75+ , resourceInfoMetadata :: Maybe Identifier
76+ } deriving (Show, Typeable)
77+
78+
79+--------------------------------------------------------------------------------
80+instance Binary ResourceInfo where
81+ put (ResourceInfo mtime meta) = put mtime >> put meta
82+ get = ResourceInfo <$> get <*> get
83+
84+
85+--------------------------------------------------------------------------------
86+instance NFData ResourceInfo where
87+ rnf (ResourceInfo mtime meta) = rnf mtime `seq` rnf meta `seq` ()
88+
89+
33--------------------------------------------------------------------------------
90--------------------------------------------------------------------------------
34-- | Responsible for retrieving and listing resources
91-- | Responsible for retrieving and listing resources
35data Provider = Provider
92data Provider = Provider
36 { -- Top of the provided directory
93 { -- Top of the provided directory
37− providerDirectory :: FilePath
94+ providerDirectory :: FilePath
38 , -- | A list of all files found
95 , -- | A list of all files found
39− providerSet :: Set Identifier
96+ providerFiles :: Map Identifier ResourceInfo
40− , -- | Cache keeping track of modified files
97+ , -- | A list of the files from the previous run
41− providerModifiedCache :: IORef (Map Identifier Bool)
98+ providerOldFiles :: Map Identifier ResourceInfo
42 , -- | Underlying persistent store for caching
99 , -- | Underlying persistent store for caching
43− providerStore :: Store
100+ providerStore :: Store
44 }
101 }
45
102
46
103
@@ -51,29 +108,47 @@ newProvider :: Store -- ^ Store to use
51 -> FilePath -- ^ Search directory
108 -> FilePath -- ^ Search directory
52 -> IO Provider -- ^ Resulting provider
109 -> IO Provider -- ^ Resulting provider
53newProvider store ignore directory = do
110newProvider store ignore directory = do
54− list <- map fromFilePath <$> getRecursiveContents ignore directory
111+ list <- map fromFilePath <$> getRecursiveContents ignore directory
55− cache <- newIORef M.empty
112+ let universe = S.fromList list
113+ files <- fmap (maxmtime . M.fromList) $ forM list $ \identifier -> do
114+ rInfo <- getResourceInfo directory universe identifier
115+ return (identifier, rInfo)
116+
117+ -- Get the old files from the store, and then immediately replace them by
118+ -- the new files.
119+ oldFiles <- fromMaybe mempty . Store.toMaybe <$> Store.get store oldKey
120+ oldFiles `deepseq` Store.set store oldKey files
121+
56− return $ Provider directory (S.fromList list) cache store
122+ return $ Provider directory files oldFiles store
123+ where
124+ oldKey = ["Hakyll.Core.Provider.Internal.newProvider", "oldFiles"]
125+
126+ -- Update modified if metadata is modified
127+ maxmtime files = flip M.map files $ \rInfo@(ResourceInfo mtime meta) ->
128+ let metaMod = fmap resourceInfoModified $ meta >>= flip M.lookup files
129+ in rInfo {resourceInfoModified = maybe mtime (max mtime) metaMod}
130+
131+
132+--------------------------------------------------------------------------------
133+getResourceInfo :: FilePath -> Set Identifier -> Identifier -> IO ResourceInfo
134+getResourceInfo directory universe identifier = do
135+ mtime <- fileModificationTime $ directory </> toFilePath identifier
136+ return $ ResourceInfo (BinaryTime mtime) $
137+ if mdRsc `S.member` universe then Just mdRsc else Nothing
138+ where
139+ mdRsc = fromFilePath $ flip addExtension "metadata" $ toFilePath identifier
57
140
58
141
59--------------------------------------------------------------------------------
142--------------------------------------------------------------------------------
60resourceList :: Provider -> [Identifier]
143resourceList :: Provider -> [Identifier]
61−resourceList = S.toList . providerSet
144+resourceList = M.keys . providerFiles
62
145
63
146
64--------------------------------------------------------------------------------
147--------------------------------------------------------------------------------
65-- | Check if a given resource exists
148-- | Check if a given resource exists
66resourceExists :: Provider -> Identifier -> Bool
149resourceExists :: Provider -> Identifier -> Bool
67resourceExists provider =
150resourceExists provider =
68− (`S.member` providerSet provider) . setVersion Nothing
151+ (`M.member` providerFiles provider) . setVersion Nothing
69−
70−
71−--------------------------------------------------------------------------------
72−-- | Each resource may have an associated metadata resource (with a @.metadata@
73−-- filename)
74−resourceMetadataResource :: Identifier -> Identifier
75−resourceMetadataResource =
76− fromFilePath . flip addExtension "metadata" . toFilePath
77
152
78
153
79--------------------------------------------------------------------------------
154--------------------------------------------------------------------------------
@@ -91,3 +166,37 @@ resourceString p i = readFile $ resourceFilePath p i
91-- | Get the raw body of a resource of a lazy bytestring
166-- | Get the raw body of a resource of a lazy bytestring
92resourceLBS :: Provider -> Identifier -> IO BL.ByteString
167resourceLBS :: Provider -> Identifier -> IO BL.ByteString
93resourceLBS p i = BL.readFile $ resourceFilePath p i
168resourceLBS p i = BL.readFile $ resourceFilePath p i
169+
170+
171+--------------------------------------------------------------------------------
172+-- | A resource is modified if it or its metadata has changed
173+resourceModified :: Provider -> Identifier -> Bool
174+resourceModified p r = case (ri, oldRi) of
175+ (Nothing, _) -> True
176+ (Just _, Nothing) -> True
177+ (Just n, Just o) -> resourceInfoModified n > resourceInfoModified o
178+ where
179+ ri = M.lookup (setVersion Nothing r) (providerFiles p)
180+ oldRi = ri >>= resourceInfoMetadata >>= flip M.lookup (providerFiles p)
181+
182+
183+--------------------------------------------------------------------------------
184+resourceModificationTime :: Provider -> Identifier -> UTCTime
185+resourceModificationTime p i =
186+ case M.lookup (setVersion Nothing i) (providerFiles p) of
187+ Just ri -> unBinaryTime $ resourceInfoModified ri
188+ Nothing -> error $
189+ "Hakyll.Core.Provider.Internal.resourceModificationTime: " ++
190+ "resource " ++ show i ++ " does not exist"
191+
192+
193+--------------------------------------------------------------------------------
194+fileModificationTime :: FilePath -> IO UTCTime
195+fileModificationTime fp = do
196+#if MIN_VERSION_directory(1,2,0)
197+ getModificationTime fp
198+#else
199+ ct <- toCalendarTime =<< getModificationTime fp
200+ let str = formatCalendarTime defaultTimeLocale "%s" ct
201+ return $ readTime defaultTimeLocale "%s" str
202+#endif
src/Hakyll/Core/Provider/Metadata.hs+4−3
@@ -31,13 +31,14 @@ loadMetadata p identifier = do
31 then second Just <$> loadMetadataHeader fp
31 then second Just <$> loadMetadataHeader fp
32 else return (M.empty, Nothing)
32 else return (M.empty, Nothing)
33
33
34− emd <- if resourceExists p mi then loadMetadataFile mfp else return M.empty
34+ emd <- case mi of
35+ Nothing -> return M.empty
36+ Just mi' -> loadMetadataFile $ resourceFilePath p mi'
35
37
36 return (M.union md emd, body)
38 return (M.union md emd, body)
37 where
39 where
38 fp = resourceFilePath p identifier
40 fp = resourceFilePath p identifier
39− mi = resourceMetadataResource identifier
41+ mi = M.lookup identifier (providerFiles p) >>= resourceInfoMetadata
40− mfp = resourceFilePath p mi
41
42
42
43
43--------------------------------------------------------------------------------
44--------------------------------------------------------------------------------
src/Hakyll/Core/Provider/MetadataCache.hs+1
@@ -23,6 +23,7 @@ resourceMetadata :: Provider -> Identifier -> IO Metadata
23resourceMetadata p r
23resourceMetadata p r
24 | not (resourceExists p r) = return M.empty
24 | not (resourceExists p r) = return M.empty
25 | otherwise = do
25 | otherwise = do
26+ -- TODO keep time in md cache
26 load p r
27 load p r
27 Store.Found md <- Store.get (providerStore p)
28 Store.Found md <- Store.get (providerStore p)
28 [name, toFilePath r, "metadata"]
29 [name, toFilePath r, "metadata"]
src/Hakyll/Core/Provider/Modified.hsdeleted−115
@@ -1,115 +0,0 @@
1−--------------------------------------------------------------------------------
2−{-# LANGUAGE CPP #-}
3−{-# LANGUAGE DeriveDataTypeable #-}
4−module Hakyll.Core.Provider.Modified
5− ( resourceModified
6− , resourceModificationTime
7− ) where
8−
9−
10−--------------------------------------------------------------------------------
11−import Control.Applicative ((<$>), (<*>))
12−import Control.Monad (when)
13−import Data.Binary (Binary (..))
14−import Data.IORef
15−import qualified Data.Map as M
16−import Data.Time (Day (..), UTCTime (..),
17− secondsToDiffTime)
18−import Data.Typeable (Typeable)
19−import System.Directory (getModificationTime)
20−
21−
22−--------------------------------------------------------------------------------
23−#if !MIN_VERSION_directory(1,2,0)
24−import Data.Time (readTime)
25−import System.Locale (defaultTimeLocale)
26−import System.Time (formatCalendarTime,
27− toCalendarTime)
28−#endif
29−
30−
31−--------------------------------------------------------------------------------
32−import Hakyll.Core.Identifier
33−import Hakyll.Core.Provider.Internal
34−import Hakyll.Core.Provider.MetadataCache
35−import Hakyll.Core.Store (Store)
36−import qualified Hakyll.Core.Store as Store
37−
38−
39−--------------------------------------------------------------------------------
40−-- | A resource is modified if it or its metadata has changed
41−resourceModified :: Provider -> Identifier -> IO Bool
42−resourceModified p r
43− | not exists = return False
44− | otherwise = do
45− cache <- readIORef cacheRef
46− case M.lookup normalized cache of
47− Just m -> return m
48− Nothing -> do
49− -- Check if the actual file was modified, and do a recursive
50− -- call to check if the metadata file was modified
51− m <- (||)
52− <$> fileModified store filePath
53− <*> resourceModified p (resourceMetadataResource r)
54− modifyIORef cacheRef (M.insert normalized m)
55−
56− -- Important! (But ugly)
57− when m $ resourceInvalidateMetadataCache p r
58−
59− return m
60− where
61− normalized = setVersion Nothing r
62− exists = resourceExists p r
63− store = providerStore p
64− cacheRef = providerModifiedCache p
65− filePath = resourceFilePath p r
66−
67−
68−--------------------------------------------------------------------------------
69−-- | Utility: Check if a file was modified recently
70−fileModified :: Store -> FilePath -> IO Bool
71−fileModified store fp = do
72− lastModified <- Store.get store key
73− newModified <- BinaryTime <$> fileModificationTime fp
74− if maybe False (>= newModified) (Store.toMaybe lastModified)
75− -- All is fine, not modified
76− then return False
77− -- Resource modified; store new digest
78− else do
79− Store.set store key newModified
80− return True
81− where
82− key = ["Hakyll.Core.Resource.Provider.fileModified", fp]
83−
84−
85−--------------------------------------------------------------------------------
86−resourceModificationTime :: Provider -> Identifier -> IO UTCTime
87−resourceModificationTime p i = fileModificationTime $ resourceFilePath p i
88−
89−
90−--------------------------------------------------------------------------------
91−fileModificationTime :: FilePath -> IO UTCTime
92−fileModificationTime fp = do
93−#if MIN_VERSION_directory(1,2,0)
94− getModificationTime fp
95−#else
96− ct <- toCalendarTime =<< getModificationTime fp
97− let str = formatCalendarTime defaultTimeLocale "%s" ct
98− return $ readTime defaultTimeLocale "%s" str
99−#endif
100−
101−
102−--------------------------------------------------------------------------------
103−-- | Because UTCTime doesn't have a Binary instance...
104−newtype BinaryTime = BinaryTime UTCTime
105− deriving (Eq, Ord, Typeable)
106−
107−
108−--------------------------------------------------------------------------------
109−instance Binary BinaryTime where
110− put (BinaryTime (UTCTime (ModifiedJulianDay d) dt)) =
111− put d >> put (floor dt :: Integer)
112−
113− get = fmap BinaryTime $ UTCTime
114− <$> (ModifiedJulianDay <$> get)
115− <*> (secondsToDiffTime <$> get)
src/Hakyll/Core/Runtime.hs+4−3
@@ -6,7 +6,7 @@ module Hakyll.Core.Runtime
6
6
7--------------------------------------------------------------------------------
7--------------------------------------------------------------------------------
8import Control.Applicative ((<$>))
8import Control.Applicative ((<$>))
9−import Control.Monad (filterM, unless)
9+import Control.Monad (unless)
10import Control.Monad.Error (ErrorT, runErrorT, throwError)
10import Control.Monad.Error (ErrorT, runErrorT, throwError)
11import Control.Monad.Reader (ask)
11import Control.Monad.Reader (ask)
12import Control.Monad.RWS (RWST, runRWST)
12import Control.Monad.RWS (RWST, runRWST)
@@ -140,8 +140,9 @@ scheduleOutOfDate = do
140 todo <- runtimeTodo <$> get
140 todo <- runtimeTodo <$> get
141
141
142 let identifiers = M.keys universe
142 let identifiers = M.keys universe
143− modified <- fmap S.fromList $ flip filterM identifiers $
143+ modified = S.fromList $ flip filter identifiers $
144− liftIO . resourceModified provider
144+ resourceModified provider
145+
145 let (ood, facts', msgs) = outOfDate identifiers modified facts
146 let (ood, facts', msgs) = outOfDate identifiers modified facts
146 todo' = M.filterWithKey
147 todo' = M.filterWithKey
147 (\id' _ -> id' `S.member` ood) universe
148 (\id' _ -> id' `S.member` ood) universe
src/Hakyll/Web/Template/Context.hs+1−2
@@ -207,8 +207,7 @@ modificationTimeFieldWith :: TimeLocale -- ^ Time output locale
207 -> Context a -- ^ Resulting context
207 -> Context a -- ^ Resulting context
208modificationTimeFieldWith locale key fmt = field key $ \i -> do
208modificationTimeFieldWith locale key fmt = field key $ \i -> do
209 provider <- compilerProvider <$> compilerAsk
209 provider <- compilerProvider <$> compilerAsk
210− mtime <- compilerUnsafeIO $
211− resourceModificationTime provider $ itemIdentifier i
210+ let mtime = resourceModificationTime provider $ itemIdentifier i
212 return $ formatTime locale fmt mtime
211 return $ formatTime locale fmt mtime
213
212
214
213
tests/Hakyll/Core/Provider/Tests.hs+1
@@ -37,3 +37,4 @@ case01 = do
37
37
38 doesntExist <- resourceMetadata provider "doesntexist.md"
38 doesntExist <- resourceMetadata provider "doesntexist.md"
39 M.empty @=? doesntExist
39 M.empty @=? doesntExist
40+ cleanTestEnv
tests/Hakyll/Core/Rules/Tests.hs+1
@@ -51,6 +51,7 @@ rulesTest = do
51 Just "example.mv1" @=? runRoutes routes (sv "mv1" "example.md")
51 Just "example.mv1" @=? runRoutes routes (sv "mv1" "example.md")
52 Just "example.mv2" @=? runRoutes routes (sv "mv2" "example.md")
52 Just "example.mv2" @=? runRoutes routes (sv "mv2" "example.md")
53 readIORef ioref >>= assert
53 readIORef ioref >>= assert
54+ cleanTestEnv
54 where
55 where
55 sv g = setVersion (Just g)
56 sv g = setVersion (Just g)
56 expected =
57 expected =
tests/Hakyll/Core/Store/Tests.hs+1
@@ -67,3 +67,4 @@ wrongType = do
67 e == typeOf (undefined :: Int) &&
67 e == typeOf (undefined :: Int) &&
68 t == typeOf (undefined :: String)
68 t == typeOf (undefined :: String)
69 _ -> False
69 _ -> False
70+ cleanTestEnv
tests/Hakyll/Web/Template/Tests.hs+2
@@ -44,6 +44,7 @@ case01 = do
44 pandocCompiler >>= applyTemplate (itemBody tpl) testContext
44 pandocCompiler >>= applyTemplate (itemBody tpl) testContext
45
45
46 out @=? itemBody item
46 out @=? itemBody item
47+ cleanTestEnv
47
48
48
49
49--------------------------------------------------------------------------------
50--------------------------------------------------------------------------------
@@ -63,6 +64,7 @@ testApplyJoinTemplateList = do
63 applyJoinTemplateList ", " tpl defaultContext [i1, i2]
64 applyJoinTemplateList ", " tpl defaultContext [i1, i2]
64
65
65 str @?= "<b>Hello</b>, <b>World</b>"
66 str @?= "<b>Hello</b>, <b>World</b>"
67+ cleanTestEnv
66 where
68 where
67 i1 = Item "item1" "Hello"
69 i1 = Item "item1" "Hello"
68 i2 = Item "item2" "World"
70 i2 = Item "item2" "World"