git.iko.soy/hakyll
on b287c82 help sign in
hakyll/src/Hakyll/Core/Provider/Internal.hs
203 lines 8.0 kB history raw
1--------------------------------------------------------------------------------
2{-# LANGUAGE CPP #-}
3{-# LANGUAGE DeriveDataTypeable #-}
4{-# LANGUAGE GeneralizedNewtypeDeriving #-}
5module Hakyll.Core.Provider.Internal
6 ( ResourceInfo (..)
7 , Provider (..)
8 , newProvider
10 , resourceList
11 , resourceExists
13 , resourceFilePath
14 , resourceString
15 , resourceLBS
17 , resourceModified
18 , resourceModificationTime
19 ) where
22--------------------------------------------------------------------------------
23import Control.Applicative ((<$>), (<*>))
24import Control.DeepSeq (NFData (..), deepseq)
25import Control.Monad (forM)
26import Data.Binary (Binary (..))
27import qualified Data.ByteString.Lazy as BL
28import Data.Map (Map)
29import qualified Data.Map as M
30import Data.Maybe (fromMaybe)
31import Data.Monoid (mempty)
32import Data.Set (Set)
33import qualified Data.Set as S
34import Data.Time (Day (..), UTCTime (..),
35 secondsToDiffTime)
36import Data.Typeable (Typeable)
37import System.Directory (getModificationTime)
38import System.FilePath (addExtension, (</>))
41--------------------------------------------------------------------------------
42#if !MIN_VERSION_directory(1,2,0)
43import Data.Time (readTime)
44import System.Locale (defaultTimeLocale)
45import System.Time (formatCalendarTime, toCalendarTime)
46#endif
49--------------------------------------------------------------------------------
50import Hakyll.Core.Identifier
51import Hakyll.Core.Store (Store)
52import qualified Hakyll.Core.Store as Store
53import Hakyll.Core.Util.File
56--------------------------------------------------------------------------------
57-- | Because UTCTime doesn't have a Binary instance...
58newtype BinaryTime = BinaryTime {unBinaryTime :: UTCTime}
59 deriving (Eq, NFData, Ord, Show, Typeable)
62--------------------------------------------------------------------------------
63instance Binary BinaryTime where
64 put (BinaryTime (UTCTime (ModifiedJulianDay d) dt)) =
65 put d >> put (floor dt :: Integer)
67 get = fmap BinaryTime $ UTCTime
68 <$> (ModifiedJulianDay <$> get)
69 <*> (secondsToDiffTime <$> get)
72--------------------------------------------------------------------------------
73data ResourceInfo = ResourceInfo
74 { resourceInfoModified :: BinaryTime
75 , resourceInfoMetadata :: Maybe Identifier
76 } deriving (Show, Typeable)
79--------------------------------------------------------------------------------
80instance Binary ResourceInfo where
81 put (ResourceInfo mtime meta) = put mtime >> put meta
82 get = ResourceInfo <$> get <*> get
85--------------------------------------------------------------------------------
86instance NFData ResourceInfo where
87 rnf (ResourceInfo mtime meta) = rnf mtime `seq` rnf meta `seq` ()
90--------------------------------------------------------------------------------
91-- | Responsible for retrieving and listing resources
92data Provider = Provider
93 { -- Top of the provided directory
94 providerDirectory :: FilePath
95 , -- | A list of all files found
96 providerFiles :: Map Identifier ResourceInfo
97 , -- | A list of the files from the previous run
98 providerOldFiles :: Map Identifier ResourceInfo
99 , -- | Underlying persistent store for caching
100 providerStore :: Store
101 }
104--------------------------------------------------------------------------------
105-- | Create a resource provider
106newProvider :: Store -- ^ Store to use
107 -> (FilePath -> Bool) -- ^ Should we ignore this file?
108 -> FilePath -- ^ Search directory
109 -> IO Provider -- ^ Resulting provider
110newProvider store ignore directory = do
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)
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
122 return $ Provider directory files oldFiles store
123 where
124 oldKey = ["Hakyll.Core.Provider.Internal.newProvider", "oldFiles"]
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}
132--------------------------------------------------------------------------------
133getResourceInfo :: FilePath -> Set Identifier -> Identifier -> IO ResourceInfo
134getResourceInfo 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
142--------------------------------------------------------------------------------
143resourceList :: Provider -> [Identifier]
144resourceList = M.keys . providerFiles
147--------------------------------------------------------------------------------
148-- | Check if a given resource exists
149resourceExists :: Provider -> Identifier -> Bool
150resourceExists provider =
151 (`M.member` providerFiles provider) . setVersion Nothing
154--------------------------------------------------------------------------------
155resourceFilePath :: Provider -> Identifier -> FilePath
156resourceFilePath p i = providerDirectory p </> toFilePath i
159--------------------------------------------------------------------------------
160-- | Get the raw body of a resource as string
161resourceString :: Provider -> Identifier -> IO String
162resourceString p i = readFile $ resourceFilePath p i
165--------------------------------------------------------------------------------
166-- | Get the raw body of a resource of a lazy bytestring
167resourceLBS :: Provider -> Identifier -> IO BL.ByteString
168resourceLBS p i = BL.readFile $ resourceFilePath p i
171--------------------------------------------------------------------------------
172-- | A resource is modified if it or its metadata has changed
173resourceModified :: Provider -> Identifier -> Bool
174resourceModified 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)
184--------------------------------------------------------------------------------
185resourceModificationTime :: Provider -> Identifier -> UTCTime
186resourceModificationTime 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"
194--------------------------------------------------------------------------------
195fileModificationTime :: FilePath -> IO UTCTime
196fileModificationTime 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