@@ -1,46 +1,103 @@
11--------------------------------------------------------------------------------
2+{-# LANGUAGE CPP #-}
3+{-# LANGUAGE DeriveDataTypeable #-}
4+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
25module Hakyll.Core.Provider.Internal
3− ( Provider (..)
6+ ( ResourceInfo (..)
7+ , Provider (..)
48 , newProvider
59
610 , resourceList
711 , resourceExists
8− , resourceMetadataResource
912
1013 , resourceFilePath
1114 , resourceString
1215 , resourceLBS
16+
17+ , resourceModified
18+ , resourceModificationTime
1319 ) where
1420
1521
1622--------------------------------------------------------------------------------
17−import Control.Applicative ((<$>))
23+import Control.Applicative ((<$>), (<*>))
24+import Control.DeepSeq (NFData (..), deepseq)
25+import Control.Monad (forM)
26+import Data.Binary (Binary (..))
1827import qualified Data.ByteString.Lazy as BL
19−import Data.IORef
2028import Data.Map (Map)
2129import qualified Data.Map as M
30+import Data.Maybe (fromMaybe)
31+import Data.Monoid (mempty)
2232import Data.Set (Set)
2333import qualified Data.Set as S
34+import Data.Time (Day (..), UTCTime (..),
35+ secondsToDiffTime)
36+import Data.Typeable (Typeable)
37+import System.Directory (getModificationTime)
2438import System.FilePath (addExtension, (</>))
2539
2640
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+
2749--------------------------------------------------------------------------------
2850import Hakyll.Core.Identifier
29−import Hakyll.Core.Store
51+import Hakyll.Core.Store (Store)
52+import qualified Hakyll.Core.Store as Store
3053import Hakyll.Core.Util.File
3154
3255
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+
3390--------------------------------------------------------------------------------
3491-- | Responsible for retrieving and listing resources
3592data Provider = Provider
3693 { -- Top of the provided directory
37− providerDirectory :: FilePath
94+ providerDirectory :: FilePath
3895 , -- | A list of all files found
39− providerSet :: Set Identifier
40− , -- | Cache keeping track of modified files
41− providerModifiedCache :: IORef (Map Identifier Bool)
96+ providerFiles :: Map Identifier ResourceInfo
97+ , -- | A list of the files from the previous run
98+ providerOldFiles :: Map Identifier ResourceInfo
4299 , -- | Underlying persistent store for caching
43− providerStore :: Store
100+ providerStore :: Store
44101 }
45102
46103
@@ -51,30 +108,47 @@ newProvider :: Store -- ^ Store to use
51108 -> FilePath -- ^ Search directory
52109 -> IO Provider -- ^ Resulting provider
53110newProvider store ignore directory = do
54− list <- map fromFilePath . filter (not . ignore) <$>
55− getRecursiveContents directory
56− cache <- newIORef M.empty
57− return $ Provider directory (S.fromList list) cache store
111+ list <- map fromFilePath <$> getRecursiveContents ignore directory
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+
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
58140
59141
60142--------------------------------------------------------------------------------
61143resourceList :: Provider -> [Identifier]
62−resourceList = S.toList . providerSet
144+resourceList = M.keys . providerFiles
63145
64146
65147--------------------------------------------------------------------------------
66148-- | Check if a given resource exists
67149resourceExists :: Provider -> Identifier -> Bool
68150resourceExists provider =
69− (`S.member` providerSet provider) . setVersion Nothing
70−
71−
72−--------------------------------------------------------------------------------
73−-- | Each resource may have an associated metadata resource (with a @.metadata@
74−-- filename)
75−resourceMetadataResource :: Identifier -> Identifier
76−resourceMetadataResource =
77− fromFilePath . flip addExtension "metadata" . toFilePath
151+ (`M.member` providerFiles provider) . setVersion Nothing
78152
79153
80154--------------------------------------------------------------------------------
@@ -92,3 +166,38 @@ resourceString p i = readFile $ resourceFilePath p i
92166-- | Get the raw body of a resource of a lazy bytestring
93167resourceLBS :: Provider -> Identifier -> IO BL.ByteString
94168resourceLBS 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, _) -> False
176+ (Just _, Nothing) -> True
177+ (Just n, Just o) -> resourceInfoModified n > resourceInfoModified o
178+ where
179+ normal = setVersion Nothing r
180+ ri = M.lookup normal (providerFiles p)
181+ oldRi = M.lookup normal (providerOldFiles p)
182+
183+
184+--------------------------------------------------------------------------------
185+resourceModificationTime :: Provider -> Identifier -> UTCTime
186+resourceModificationTime p i =
187+ case M.lookup (setVersion Nothing i) (providerFiles p) of
188+ Just ri -> unBinaryTime $ resourceInfoModified ri
189+ Nothing -> error $
190+ "Hakyll.Core.Provider.Internal.resourceModificationTime: " ++
191+ "resource " ++ show i ++ " does not exist"
192+
193+
194+--------------------------------------------------------------------------------
195+fileModificationTime :: FilePath -> IO UTCTime
196+fileModificationTime fp = do
197+#if MIN_VERSION_directory(1,2,0)
198+ getModificationTime fp
199+#else
200+ ct <- toCalendarTime =<< getModificationTime fp
201+ let str = formatCalendarTime defaultTimeLocale "%s" ct
202+ return $ readTime defaultTimeLocale "%s" str
203+#endif