yogsototh/hakyll
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Start provider rewrite

Browse source
This commit is contained in:
Jasper Van der Jeugt 2013-02-09 15:11:40 +01:00
parent ea953d3415
commit 86d0b68aed
13 changed files with 173 additions and 174 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

1
hakyll.cabal
View file

@ -151,7 +151,6 @@ Library
Hakyll.Core.Provider.Internal
Hakyll.Core.Provider.Metadata
Hakyll.Core.Provider.MetadataCache
Hakyll.Core.Provider.Modified
Hakyll.Core.Rules.Internal
Hakyll.Core.Runtime
Hakyll.Core.Store

2
src/Hakyll/Core/Compiler.hs
View file

@ -131,7 +131,7 @@ cached name compiler = do
id' <- compilerUnderlying <$> compilerAsk
store <- compilerStore <$> compilerAsk
provider <- compilerProvider <$> compilerAsk
modified <- compilerUnsafeIO $ resourceModified provider id'
let modified = resourceModified provider id'
if modified
then do
x <- compiler

51
src/Hakyll/Core/Provider.hs
View file

@ -3,44 +3,43 @@
-- caching.
module Hakyll.Core.Provider
( -- * Constructing resource providers
Provider
Internal.Provider
, newProvider
-- * Querying resource properties
, resourceList
, resourceExists
, resourceModified
, resourceModificationTime
, Internal.resourceList
, Internal.resourceExists
, Internal.resourceModified
, Internal.resourceModificationTime
-- * Access to raw resource content
, resourceString
, resourceLBS
, Internal.resourceString
, Internal.resourceLBS
-- * Access to metadata and body content
, resourceMetadata
, resourceBody
, Internal.resourceMetadata
, Internal.resourceBody
) where
--------------------------------------------------------------------------------
import Hakyll.Core.Identifier
import Hakyll.Core.Metadata
import Hakyll.Core.Provider.Internal
import Control.Monad (forM_)
import qualified Hakyll.Core.Provider.Internal as Internal
import qualified Hakyll.Core.Provider.MetadataCache as Internal
import Hakyll.Core.Provider.Modified
import Hakyll.Core.Store (Store)
--------------------------------------------------------------------------------
-- | Wrapper to ensure metadata cache is invalidated if necessary
resourceMetadata :: Provider -> Identifier -> IO Metadata
resourceMetadata rp r = do
_ <- resourceModified rp r
Internal.resourceMetadata rp r
--------------------------------------------------------------------------------
-- | Wrapper to ensure metadata cache is invalidated if necessary
resourceBody :: Provider -> Identifier -> IO String
resourceBody rp r = do
_ <- resourceModified rp r
Internal.resourceBody rp r
-- | Create a resource provider
newProvider :: Store -- ^ Store to use
-> (FilePath -> Bool) -- ^ Should we ignore this file?
-> FilePath -- ^ Search directory
-> IO Internal.Provider -- ^ Resulting provider
newProvider store ignore directory = do
-- Delete metadata cache where necessary
provider <- Internal.newProvider store ignore directory
forM_ (Internal.resourceList provider) $ \identifier ->
if Internal.resourceModified provider identifier
then Internal.resourceInvalidateMetadataCache provider identifier
else return ()
return provider

149
src/Hakyll/Core/Provider/Internal.hs
View file

@ -1,44 +1,101 @@
--------------------------------------------------------------------------------
{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Hakyll.Core.Provider.Internal
( Provider (..)
( ResourceInfo (..)
, Provider (..)
, newProvider
, resourceList
, resourceExists
, resourceMetadataResource
, resourceFilePath
, resourceString
, resourceLBS
, resourceModified
, resourceModificationTime
) where
--------------------------------------------------------------------------------
import Control.Applicative ((<$>))
import Control.Applicative ((<$>), (<*>))
import Control.DeepSeq (NFData (..), deepseq)
import Control.Monad (forM)
import Data.Binary (Binary (..))
import qualified Data.ByteString.Lazy as BL
import Data.IORef
import Data.Map (Map)
import qualified Data.Map as M
import Data.Maybe (fromMaybe)
import Data.Monoid (mempty)
import Data.Set (Set)
import qualified Data.Set as S
import Data.Time (Day (..), UTCTime (..),
secondsToDiffTime)
import Data.Typeable (Typeable)
import System.Directory (getModificationTime)
import System.FilePath (addExtension, (</>))
--------------------------------------------------------------------------------
#if !MIN_VERSION_directory(1,2,0)
import Data.Time (readTime)
import System.Locale (defaultTimeLocale)
import System.Time (formatCalendarTime, toCalendarTime)
#endif
--------------------------------------------------------------------------------
import Hakyll.Core.Identifier
import Hakyll.Core.Store
import Hakyll.Core.Store (Store)
import qualified Hakyll.Core.Store as Store
import Hakyll.Core.Util.File
--------------------------------------------------------------------------------
-- | Because UTCTime doesn't have a Binary instance...
newtype BinaryTime = BinaryTime {unBinaryTime :: UTCTime}
deriving (Eq, NFData, Ord, Show, Typeable)
--------------------------------------------------------------------------------
instance Binary BinaryTime where
put (BinaryTime (UTCTime (ModifiedJulianDay d) dt)) =
put d >> put (floor dt :: Integer)
get = fmap BinaryTime $ UTCTime
<$> (ModifiedJulianDay <$> get)
<*> (secondsToDiffTime <$> get)
--------------------------------------------------------------------------------
data ResourceInfo = ResourceInfo
{ resourceInfoModified :: BinaryTime
, resourceInfoMetadata :: Maybe Identifier
} deriving (Show, Typeable)
--------------------------------------------------------------------------------
instance Binary ResourceInfo where
put (ResourceInfo mtime meta) = put mtime >> put meta
get = ResourceInfo <$> get <*> get
--------------------------------------------------------------------------------
instance NFData ResourceInfo where
rnf (ResourceInfo mtime meta) = rnf mtime `seq` rnf meta `seq` ()
--------------------------------------------------------------------------------
-- | Responsible for retrieving and listing resources
data Provider = Provider
{ -- Top of the provided directory
providerDirectory :: FilePath
, -- | A list of all files found
providerSet :: Set Identifier
, -- | Cache keeping track of modified files
providerModifiedCache :: IORef (Map Identifier Bool)
providerFiles :: Map Identifier ResourceInfo
, -- | A list of the files from the previous run
providerOldFiles :: Map Identifier ResourceInfo
, -- | Underlying persistent store for caching
providerStore :: Store
}
@ -52,28 +109,46 @@ newProvider :: Store -- ^ Store to use
-> IO Provider -- ^ Resulting provider
newProvider store ignore directory = do
list <- map fromFilePath <$> getRecursiveContents ignore directory
cache <- newIORef M.empty
return $ Provider directory (S.fromList list) cache store
let universe = S.fromList list
files <- fmap (maxmtime . M.fromList) $ forM list $ \identifier -> do
rInfo <- getResourceInfo directory universe identifier
return (identifier, rInfo)
-- Get the old files from the store, and then immediately replace them by
-- the new files.
oldFiles <- fromMaybe mempty . Store.toMaybe <$> Store.get store oldKey
oldFiles `deepseq` Store.set store oldKey files
return $ Provider directory files oldFiles store
where
oldKey = ["Hakyll.Core.Provider.Internal.newProvider", "oldFiles"]
-- Update modified if metadata is modified
maxmtime files = flip M.map files $ \rInfo@(ResourceInfo mtime meta) ->
let metaMod = fmap resourceInfoModified $ meta >>= flip M.lookup files
in rInfo {resourceInfoModified = maybe mtime (max mtime) metaMod}
--------------------------------------------------------------------------------
getResourceInfo :: FilePath -> Set Identifier -> Identifier -> IO ResourceInfo
getResourceInfo directory universe identifier = do
mtime <- fileModificationTime $ directory </> toFilePath identifier
return $ ResourceInfo (BinaryTime mtime) $
if mdRsc `S.member` universe then Just mdRsc else Nothing
where
mdRsc = fromFilePath $ flip addExtension "metadata" $ toFilePath identifier
--------------------------------------------------------------------------------
resourceList :: Provider -> [Identifier]
resourceList = S.toList . providerSet
resourceList = M.keys . providerFiles
--------------------------------------------------------------------------------
-- | Check if a given resource exists
resourceExists :: Provider -> Identifier -> Bool
resourceExists provider =
(`S.member` providerSet provider) . setVersion Nothing
--------------------------------------------------------------------------------
-- | Each resource may have an associated metadata resource (with a @.metadata@
-- filename)
resourceMetadataResource :: Identifier -> Identifier
resourceMetadataResource =
fromFilePath . flip addExtension "metadata" . toFilePath
(`M.member` providerFiles provider) . setVersion Nothing
--------------------------------------------------------------------------------
@ -91,3 +166,37 @@ resourceString p i = readFile $ resourceFilePath p i
-- | Get the raw body of a resource of a lazy bytestring
resourceLBS :: Provider -> Identifier -> IO BL.ByteString
resourceLBS p i = BL.readFile $ resourceFilePath p i
--------------------------------------------------------------------------------
-- | A resource is modified if it or its metadata has changed
resourceModified :: Provider -> Identifier -> Bool
resourceModified p r = case (ri, oldRi) of
(Nothing, _) -> True
(Just _, Nothing) -> True
(Just n, Just o) -> resourceInfoModified n > resourceInfoModified o
where
ri = M.lookup (setVersion Nothing r) (providerFiles p)
oldRi = ri >>= resourceInfoMetadata >>= flip M.lookup (providerFiles p)
--------------------------------------------------------------------------------
resourceModificationTime :: Provider -> Identifier -> UTCTime
resourceModificationTime p i =
case M.lookup (setVersion Nothing i) (providerFiles p) of
Just ri -> unBinaryTime $ resourceInfoModified ri
Nothing -> error $
"Hakyll.Core.Provider.Internal.resourceModificationTime: " ++
"resource " ++ show i ++ " does not exist"
--------------------------------------------------------------------------------
fileModificationTime :: FilePath -> IO UTCTime
fileModificationTime fp = do
#if MIN_VERSION_directory(1,2,0)
getModificationTime fp
#else
ct <- toCalendarTime =<< getModificationTime fp
let str = formatCalendarTime defaultTimeLocale "%s" ct
return $ readTime defaultTimeLocale "%s" str
#endif

7
src/Hakyll/Core/Provider/Metadata.hs
View file

@ -31,13 +31,14 @@ loadMetadata p identifier = do
then second Just <$> loadMetadataHeader fp
else return (M.empty, Nothing)
emd <- if resourceExists p mi then loadMetadataFile mfp else return M.empty
emd <- case mi of
Nothing -> return M.empty
Just mi' -> loadMetadataFile $ resourceFilePath p mi'
return (M.union md emd, body)
where
fp = resourceFilePath p identifier
mi = resourceMetadataResource identifier
mfp = resourceFilePath p mi
mi = M.lookup identifier (providerFiles p) >>= resourceInfoMetadata
--------------------------------------------------------------------------------

1
src/Hakyll/Core/Provider/MetadataCache.hs
View file

@ -23,6 +23,7 @@ resourceMetadata :: Provider -> Identifier -> IO Metadata
resourceMetadata p r
| not (resourceExists p r) = return M.empty
| otherwise = do
-- TODO keep time in md cache
load p r
Store.Found md <- Store.get (providerStore p)
[name, toFilePath r, "metadata"]

115
src/Hakyll/Core/Provider/Modified.hs
View file

@ -1,115 +0,0 @@
--------------------------------------------------------------------------------
{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
module Hakyll.Core.Provider.Modified
( resourceModified
, resourceModificationTime
) where
--------------------------------------------------------------------------------
import Control.Applicative ((<$>), (<*>))
import Control.Monad (when)
import Data.Binary (Binary (..))
import Data.IORef
import qualified Data.Map as M
import Data.Time (Day (..), UTCTime (..),
secondsToDiffTime)
import Data.Typeable (Typeable)
import System.Directory (getModificationTime)
--------------------------------------------------------------------------------
#if !MIN_VERSION_directory(1,2,0)
import Data.Time (readTime)
import System.Locale (defaultTimeLocale)
import System.Time (formatCalendarTime,
toCalendarTime)
#endif
--------------------------------------------------------------------------------
import Hakyll.Core.Identifier
import Hakyll.Core.Provider.Internal
import Hakyll.Core.Provider.MetadataCache
import Hakyll.Core.Store (Store)
import qualified Hakyll.Core.Store as Store
--------------------------------------------------------------------------------
-- | A resource is modified if it or its metadata has changed
resourceModified :: Provider -> Identifier -> IO Bool
resourceModified p r
| not exists = return False
| otherwise = do
cache <- readIORef cacheRef
case M.lookup normalized cache of
Just m -> return m
Nothing -> do
-- Check if the actual file was modified, and do a recursive
-- call to check if the metadata file was modified
m <- (||)
<$> fileModified store filePath
<*> resourceModified p (resourceMetadataResource r)
modifyIORef cacheRef (M.insert normalized m)
-- Important! (But ugly)
when m $ resourceInvalidateMetadataCache p r
return m
where
normalized = setVersion Nothing r
exists = resourceExists p r
store = providerStore p
cacheRef = providerModifiedCache p
filePath = resourceFilePath p r
--------------------------------------------------------------------------------
-- | Utility: Check if a file was modified recently
fileModified :: Store -> FilePath -> IO Bool
fileModified store fp = do
lastModified <- Store.get store key
newModified <- BinaryTime <$> fileModificationTime fp
if maybe False (>= newModified) (Store.toMaybe lastModified)
-- All is fine, not modified
then return False
-- Resource modified; store new digest
else do
Store.set store key newModified
return True
where
key = ["Hakyll.Core.Resource.Provider.fileModified", fp]
--------------------------------------------------------------------------------
resourceModificationTime :: Provider -> Identifier -> IO UTCTime
resourceModificationTime p i = fileModificationTime $ resourceFilePath p i
--------------------------------------------------------------------------------
fileModificationTime :: FilePath -> IO UTCTime
fileModificationTime fp = do
#if MIN_VERSION_directory(1,2,0)
getModificationTime fp
#else
ct <- toCalendarTime =<< getModificationTime fp
let str = formatCalendarTime defaultTimeLocale "%s" ct
return $ readTime defaultTimeLocale "%s" str
#endif
--------------------------------------------------------------------------------
-- | Because UTCTime doesn't have a Binary instance...
newtype BinaryTime = BinaryTime UTCTime
deriving (Eq, Ord, Typeable)
--------------------------------------------------------------------------------
instance Binary BinaryTime where
put (BinaryTime (UTCTime (ModifiedJulianDay d) dt)) =
put d >> put (floor dt :: Integer)
get = fmap BinaryTime $ UTCTime
<$> (ModifiedJulianDay <$> get)
<*> (secondsToDiffTime <$> get)

7
src/Hakyll/Core/Runtime.hs
View file

@ -6,7 +6,7 @@ module Hakyll.Core.Runtime
--------------------------------------------------------------------------------
import Control.Applicative ((<$>))
import Control.Monad (filterM, unless)
import Control.Monad (unless)
import Control.Monad.Error (ErrorT, runErrorT, throwError)
import Control.Monad.Reader (ask)
import Control.Monad.RWS (RWST, runRWST)
@ -140,8 +140,9 @@ scheduleOutOfDate = do
todo <- runtimeTodo <$> get
let identifiers = M.keys universe
modified <- fmap S.fromList $ flip filterM identifiers $
liftIO . resourceModified provider
modified = S.fromList $ flip filter identifiers $
resourceModified provider
let (ood, facts', msgs) = outOfDate identifiers modified facts
todo' = M.filterWithKey
(\id' _ -> id' `S.member` ood) universe

3
src/Hakyll/Web/Template/Context.hs
View file

@ -207,8 +207,7 @@ modificationTimeFieldWith :: TimeLocale -- ^ Time output locale
-> Context a -- ^ Resulting context
modificationTimeFieldWith locale key fmt = field key $ \i -> do
provider <- compilerProvider <$> compilerAsk
mtime <- compilerUnsafeIO $
resourceModificationTime provider $ itemIdentifier i
let mtime = resourceModificationTime provider $ itemIdentifier i
return $ formatTime locale fmt mtime

1
tests/Hakyll/Core/Provider/Tests.hs
View file

@ -37,3 +37,4 @@ case01 = do
doesntExist <- resourceMetadata provider "doesntexist.md"
M.empty @=? doesntExist
cleanTestEnv

1
tests/Hakyll/Core/Rules/Tests.hs
View file

@ -51,6 +51,7 @@ rulesTest = do
Just "example.mv1" @=? runRoutes routes (sv "mv1" "example.md")
Just "example.mv2" @=? runRoutes routes (sv "mv2" "example.md")
readIORef ioref >>= assert
cleanTestEnv
where
sv g = setVersion (Just g)
expected =

1
tests/Hakyll/Core/Store/Tests.hs
View file

@ -67,3 +67,4 @@ wrongType = do
e == typeOf (undefined :: Int) &&
t == typeOf (undefined :: String)
_ -> False
cleanTestEnv

2
tests/Hakyll/Web/Template/Tests.hs
View file

@ -44,6 +44,7 @@ case01 = do
pandocCompiler >>= applyTemplate (itemBody tpl) testContext
out @=? itemBody item
cleanTestEnv
--------------------------------------------------------------------------------
@ -63,6 +64,7 @@ testApplyJoinTemplateList = do
applyJoinTemplateList ", " tpl defaultContext [i1, i2]
str @?= "<b>Hello</b>, <b>World</b>"
cleanTestEnv
where
i1 = Item "item1" "Hello"
i2 = Item "item2" "World"