diff options
| -rw-r--r-- | src/Hakyll/Core/Compiler.hs | 27 | ||||
| -rw-r--r-- | src/Hakyll/Core/Resource/Provider.hs | 39 | ||||
| -rw-r--r-- | src/Hakyll/Core/Run.hs | 13 | ||||
| -rw-r--r-- | src/Hakyll/Core/Store.hs | 207 | ||||
| -rw-r--r-- | tests/Hakyll/Core/Store/Tests.hs | 81 | ||||
| -rw-r--r-- | tests/TestSuite/Util.hs | 5 |
6 files changed, 212 insertions, 160 deletions
diff --git a/src/Hakyll/Core/Compiler.hs b/src/Hakyll/Core/Compiler.hs index 55eaff8..3c62a3a 100644 --- a/src/Hakyll/Core/Compiler.hs +++ b/src/Hakyll/Core/Compiler.hs @@ -60,7 +60,7 @@ -- Let's look at it in detail: -- -- > (Binary a, Typeable a, Writable a) --- +-- -- These are constraints for the @a@ type. @a@ (the template) needs to have -- certain properties for it to be required. -- @@ -138,10 +138,11 @@ import Hakyll.Core.Writable import Hakyll.Core.Resource import Hakyll.Core.Resource.Provider import Hakyll.Core.Compiler.Internal -import Hakyll.Core.Store +import Hakyll.Core.Store (Store) import Hakyll.Core.Rules.Internal import Hakyll.Core.Routes import Hakyll.Core.Logger +import qualified Hakyll.Core.Store as Store -- | Run a compiler, yielding the resulting target and it's dependencies. This -- version of 'runCompilerJob' also stores the result @@ -167,8 +168,7 @@ runCompiler compiler id' provider universe routes store modified logger = do -- before we return control. This makes sure the compiled item can later -- be accessed by e.g. require. Right (CompileRule (CompiledItem x)) -> - storeSet store "Hakyll.Core.Compiler.runCompiler" - (castIdentifier id') x + Store.set store ["Hakyll.Core.Compiler.runCompiler", show id'] x -- Otherwise, we do nothing here _ -> return () @@ -227,12 +227,13 @@ getResourceWith reader = fromJob $ \r -> CompilerM $ do getDependency :: (Binary a, Writable a, Typeable a) => Identifier a -> CompilerM a getDependency id' = CompilerM $ do - store <- compilerStore <$> ask - result <- liftIO $ storeGet store "Hakyll.Core.Compiler.runCompiler" id' + store <- compilerStore <$> ask + result <- liftIO $ + Store.get store ["Hakyll.Core.Compiler.runCompiler", show id'] case result of - NotFound -> throwError notFound - WrongType e r -> throwError $ wrongType e r - Found x -> return x + Store.NotFound -> throwError notFound + Store.WrongType e r -> throwError $ wrongType e r + Store.Found x -> return x where notFound = "Hakyll.Core.Compiler.getDependency: " ++ show id' ++ " was " ++ @@ -310,11 +311,11 @@ cached name (Compiler d j) = Compiler d $ const $ CompilerM $ do report logger $ "Checking cache: " ++ if modified then "modified" else "OK" if modified then do v <- unCompilerM $ j $ fromIdentifier identifier - liftIO $ storeSet store name identifier v + liftIO $ Store.set store [name, show identifier] v return v - else do v <- liftIO $ storeGet store name identifier - case v of Found v' -> return v' - _ -> throwError (error' progName) + else do v <- liftIO $ Store.get store [name, show identifier] + case v of Store.Found v' -> return v' + _ -> throwError (error' progName) where error' progName = "Hakyll.Core.Compiler.cached: Cache corrupt! " ++ diff --git a/src/Hakyll/Core/Resource/Provider.hs b/src/Hakyll/Core/Resource/Provider.hs index ebd5984..2ed7797 100644 --- a/src/Hakyll/Core/Resource/Provider.hs +++ b/src/Hakyll/Core/Resource/Provider.hs @@ -1,3 +1,4 @@ +-------------------------------------------------------------------------------- -- | This module provides an API for resource providers. Resource providers -- allow Hakyll to get content from resources; the type of resource depends on -- the concrete instance. @@ -19,22 +20,30 @@ module Hakyll.Core.Resource.Provider , resourceModified ) where + +-------------------------------------------------------------------------------- import Control.Applicative ((<$>)) import Control.Concurrent (MVar, readMVar, modifyMVar_, newMVar) import Data.Map (Map) import qualified Data.Map as M import qualified Data.Set as S + +-------------------------------------------------------------------------------- import Data.Time (UTCTime) import qualified Crypto.Hash.MD5 as MD5 import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as LB -import Hakyll.Core.Store + +-------------------------------------------------------------------------------- +import Hakyll.Core.Store (Store) import Hakyll.Core.Resource +import qualified Hakyll.Core.Store as Store + +-------------------------------------------------------------------------------- -- | A value responsible for retrieving and listing resources --- data ResourceProvider = ResourceProvider { -- | A set of all resources this provider is able to provide resourceSet :: S.Set Resource @@ -48,8 +57,9 @@ data ResourceProvider = ResourceProvider resourceModifiedCache :: MVar (Map Resource Bool) } + +-------------------------------------------------------------------------------- -- | Create a resource provider --- makeResourceProvider :: [Resource] -- ^ Resource list -> (Resource -> IO String) -- ^ String reader -> (Resource -> IO LB.ByteString) -- ^ ByteString reader @@ -58,22 +68,27 @@ makeResourceProvider :: [Resource] -- ^ Resource list makeResourceProvider l s b t = ResourceProvider (S.fromList l) s b t <$> newMVar M.empty + +-------------------------------------------------------------------------------- -- | Get the list of all resources resourceList :: ResourceProvider -> [Resource] resourceList = S.toList . resourceSet + +-------------------------------------------------------------------------------- -- | Check if a given identifier has a resource --- resourceExists :: ResourceProvider -> Resource -> Bool resourceExists provider = flip S.member $ resourceSet provider + +-------------------------------------------------------------------------------- -- | Retrieve a digest for a given resource --- resourceDigest :: ResourceProvider -> Resource -> IO B.ByteString resourceDigest provider = fmap MD5.hashlazy . resourceLBS provider + +-------------------------------------------------------------------------------- -- | Check if a resource was modified --- resourceModified :: ResourceProvider -> Store -> Resource -> IO Bool resourceModified provider store r = do cache <- readMVar mvar @@ -90,21 +105,21 @@ resourceModified provider store r = do where mvar = resourceModifiedCache provider + +-------------------------------------------------------------------------------- -- | Check if a resource digest was modified --- digestModified :: ResourceProvider -> Store -> Resource -> IO Bool digestModified provider store r = do -- Get the latest seen digest from the store - lastDigest <- storeGet store itemName identifier + lastDigest <- Store.get store key -- Calculate the digest for the resource newDigest <- resourceDigest provider r -- Check digests - if Found newDigest == lastDigest + if Store.Found newDigest == lastDigest -- All is fine, not modified then return False -- Resource modified; store new digest - else do storeSet store itemName identifier newDigest + else do Store.set store key newDigest return True where - identifier = toIdentifier r - itemName = "Hakyll.Core.ResourceProvider.digestModified" + key = ["Hakyll.Core.ResourceProvider.digestModified", unResource r] diff --git a/src/Hakyll/Core/Run.hs b/src/Hakyll/Core/Run.hs index c662886..0bc3625 100644 --- a/src/Hakyll/Core/Run.hs +++ b/src/Hakyll/Core/Run.hs @@ -30,9 +30,10 @@ import Hakyll.Core.Resource.Provider import Hakyll.Core.Resource.Provider.File import Hakyll.Core.Routes import Hakyll.Core.Rules.Internal -import Hakyll.Core.Store +import Hakyll.Core.Store (Store) import Hakyll.Core.Util.File import Hakyll.Core.Writable +import qualified Hakyll.Core.Store as Store -- | Run all rules needed, return the rule set used -- @@ -42,15 +43,15 @@ run configuration rules = do section logger "Initialising" store <- timed logger "Creating store" $ - makeStore (inMemoryCache configuration) $ storeDirectory configuration + Store.new (inMemoryCache configuration) $ storeDirectory configuration provider <- timed logger "Creating provider" $ fileResourceProvider configuration -- Fetch the old graph from the store. If we don't find it, we consider this -- to be the first run - graph <- storeGet store "Hakyll.Core.Run.run" "dependencies" - let (firstRun, oldGraph) = case graph of Found g -> (False, g) - _ -> (True, mempty) + graph <- Store.get store ["Hakyll.Core.Run.run", "dependencies"] + let (firstRun, oldGraph) = case graph of Store.Found g -> (False, g) + _ -> (True, mempty) let ruleSet = runRules rules provider compilers = rulesCompilers ruleSet @@ -77,7 +78,7 @@ run configuration rules = do thrown logger e Right ((), state') -> -- We want to save the final dependency graph for the next run - storeSet store "Hakyll.Core.Run.run" "dependencies" $ + Store.set store ["Hakyll.Core.Run.run", "dependencies"] $ analyzerGraph $ hakyllAnalyzer state' -- Flush and return diff --git a/src/Hakyll/Core/Store.hs b/src/Hakyll/Core/Store.hs index 318730a..231da2a 100644 --- a/src/Hakyll/Core/Store.hs +++ b/src/Hakyll/Core/Store.hs @@ -1,111 +1,120 @@ --- | A store for stroing and retreiving items --- -{-# LANGUAGE ExistentialQuantification, ScopedTypeVariables #-} +-------------------------------------------------------------------------------- +-- | A store for storing and retreiving items +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE ScopedTypeVariables #-} module Hakyll.Core.Store ( Store - , StoreGet (..) - , makeStore - , storeSet - , storeGet + , Result (..) + , new + , set + , get + , delete ) where -import Control.Applicative ((<$>)) -import System.FilePath ((</>)) -import System.Directory (doesFileExist) -import Data.Maybe (fromMaybe) -import Data.Binary (Binary, encodeFile, decodeFile) -import Data.Typeable (Typeable, TypeRep, cast, typeOf) +-------------------------------------------------------------------------------- +import Control.Applicative ((<$>)) +import Control.Exception (IOException, handle) +import qualified Crypto.Hash.MD5 as MD5 +import Data.Binary (Binary, decodeFile, encodeFile) +import qualified Data.ByteString as B +import qualified Data.Cache.LRU.IO as Lru +import Data.List (intercalate) +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import Data.Typeable (TypeRep, Typeable, cast, typeOf) +import System.Directory (createDirectoryIfMissing) +import System.Directory (doesFileExist, removeFile) +import System.FilePath ((</>)) +import Text.Printf (printf) -import Hakyll.Core.Identifier -import Hakyll.Core.Util.File -import qualified Data.Cache.LRU.IO as LRU --- | Items we can store --- -data Storable = forall a. (Binary a, Typeable a) => Storable a +-------------------------------------------------------------------------------- +-- | Simple wrapper type +data Box = forall a. Typeable a => Box a --- | Result when an item from the store --- -data StoreGet a = Found a - | NotFound - | WrongType TypeRep TypeRep - deriving (Show, Eq) --- | Data structure used for the store --- +-------------------------------------------------------------------------------- data Store = Store { -- | All items are stored on the filesystem storeDirectory :: FilePath - , -- | And some items are also kept in-memory - storeLRU :: Maybe (LRU.AtomicLRU FilePath Storable) + , -- | Optionally, items are also kept in-memory + storeMap :: Maybe (Lru.AtomicLRU FilePath Box) } --- | The size of the in-memory cache to use in items. -storeLRUSize :: Maybe Integer -storeLRUSize = Just 500 +-------------------------------------------------------------------------------- +-- | Result of a store query +data Result a + = Found a -- ^ Found, result + | NotFound -- ^ Not found + | WrongType TypeRep TypeRep -- ^ Expected, true type + deriving (Show, Eq) + + +-------------------------------------------------------------------------------- -- | Initialize the store --- -makeStore :: Bool -- ^ Use in-memory caching - -> FilePath -- ^ Directory to use for hard disk storage - -> IO Store -- ^ Store -makeStore inMemory directory = do - lru <- if inMemory - then Just <$> LRU.newAtomicLRU storeLRUSize - else return Nothing +new :: Bool -- ^ Use in-memory caching + -> FilePath -- ^ Directory to use for hard disk storage + -> IO Store -- ^ Store +new inMemory directory = do + createDirectoryIfMissing True directory + ref <- if inMemory then Just <$> Lru.newAtomicLRU csize else return Nothing return Store { storeDirectory = directory - , storeLRU = lru + , storeMap = ref } - --- | Auxiliary: add an item to the map --- -cacheInsert :: (Binary a, Typeable a) => Store -> FilePath -> a -> IO () -cacheInsert (Store _ Nothing) _ _ = return () -cacheInsert (Store _ (Just lru)) path value = - LRU.insert path (Storable value) lru - --- | Auxiliary: get an item from the cache --- -cacheLookup :: forall a. (Binary a, Typeable a) - => Store -> FilePath -> IO (StoreGet a) -cacheLookup (Store _ Nothing) _ = return NotFound -cacheLookup (Store _ (Just lru)) path = do - res <- LRU.lookup path lru - case res of - Nothing -> return NotFound - Just (Storable s) -> return $ case cast s of - Nothing -> WrongType (typeOf s) $ typeOf (undefined :: a) - Just s' -> Found s' - --- | Create a path --- -makePath :: Store -> String -> Identifier a -> FilePath -makePath store name identifier = storeDirectory store </> name - </> group </> toFilePath identifier </> "hakyllstore" where - group = fromMaybe "" $ identifierGroup identifier + csize = Just 500 + + +-------------------------------------------------------------------------------- +-- | Auxiliary: add an item to the in-memory cache +cacheInsert :: Typeable a => Store -> String -> a -> IO () +cacheInsert (Store _ Nothing) _ _ = return () +cacheInsert (Store _ (Just lru)) key x = + Lru.insert key (Box x) lru + + +-------------------------------------------------------------------------------- +-- | Auxiliary: get an item from the in-memory cache +cacheLookup :: forall a. Typeable a => Store -> String -> IO (Result a) +cacheLookup (Store _ Nothing) _ = return NotFound +cacheLookup (Store _ (Just lru)) key = do + res <- Lru.lookup key lru + return $ case res of + Nothing -> NotFound + Just (Box x) -> case cast x of + Just x' -> Found x' + Nothing -> WrongType (typeOf (undefined :: a)) (typeOf x) + + +-------------------------------------------------------------------------------- +-- | Auxiliary: delete an item from the in-memory cache +cacheDelete :: Store -> String -> IO () +cacheDelete (Store _ Nothing) _ = return () +cacheDelete (Store _ (Just lru)) key = do + _ <- Lru.delete key lru + return () + +-------------------------------------------------------------------------------- -- | Store an item --- -storeSet :: (Binary a, Typeable a) - => Store -> String -> Identifier a -> a -> IO () -storeSet store name identifier value = do - makeDirectories path - encodeFile path value - cacheInsert store path value +set :: (Binary a, Typeable a) => Store -> [String] -> a -> IO () +set store identifier value = do + encodeFile (storeDirectory store </> key) value + cacheInsert store key value where - path = makePath store name identifier + key = hash identifier + +-------------------------------------------------------------------------------- -- | Load an item --- -storeGet :: (Binary a, Typeable a) - => Store -> String -> Identifier a -> IO (StoreGet a) -storeGet store name identifier = do +get :: (Binary a, Typeable a) => Store -> [String] -> IO (Result a) +get store identifier = do -- First check the in-memory map - mv <- cacheLookup store path - case mv of + ref <- cacheLookup store key + case ref of -- Not found in the map, try the filesystem NotFound -> do exists <- doesFileExist path @@ -113,10 +122,34 @@ storeGet store name identifier = do -- Not found in the filesystem either then return NotFound -- Found in the filesystem - else do v <- decodeFile path - cacheInsert store path v - return $ Found v - -- Found in the in-memory map, just return + else do + v <- decodeFile path + cacheInsert store key v + return $ Found v + -- Found in the in-memory map (or wrong type), just return s -> return s where - path = makePath store name identifier + key = hash identifier + path = storeDirectory store </> key + + +-------------------------------------------------------------------------------- +-- | Delete an item +delete :: Store -> [String] -> IO () +delete store identifier = do + cacheDelete store key + deleteFile $ storeDirectory store </> key + where + key = hash identifier + + +-------------------------------------------------------------------------------- +hash :: [String] -> String +hash = concatMap (printf "%02x") . B.unpack . + MD5.hash . T.encodeUtf8 . T.pack . intercalate "/" + + +-------------------------------------------------------------------------------- +-- | Delete a file unless it doesn't exist... +deleteFile :: FilePath -> IO () +deleteFile = handle (\(_ :: IOException) -> return ()) . removeFile diff --git a/tests/Hakyll/Core/Store/Tests.hs b/tests/Hakyll/Core/Store/Tests.hs index 53ad74e..3188c30 100644 --- a/tests/Hakyll/Core/Store/Tests.hs +++ b/tests/Hakyll/Core/Store/Tests.hs @@ -1,67 +1,68 @@ +-------------------------------------------------------------------------------- {-# LANGUAGE OverloadedStrings #-} module Hakyll.Core.Store.Tests ( tests ) where -import Control.Applicative ((<$>)) -import Control.Monad (replicateM) -import Test.Framework -import Test.Framework.Providers.QuickCheck2 -import Test.Framework.Providers.HUnit -import Test.QuickCheck -import Test.QuickCheck.Monadic -import qualified Test.HUnit as H +-------------------------------------------------------------------------------- +import Data.Typeable (typeOf) +import Test.Framework +import Test.Framework.Providers.HUnit +import Test.Framework.Providers.QuickCheck2 +import qualified Test.HUnit as H +import Test.QuickCheck +import Test.QuickCheck.Monadic -import Hakyll.Core.Identifier -import Hakyll.Core.Store -import TestSuite.Util +-------------------------------------------------------------------------------- +import qualified Hakyll.Core.Store as Store +import TestSuite.Util + + +-------------------------------------------------------------------------------- tests :: [Test] tests = - [ testProperty "simple storeGet . storeSet" simpleSetGet - , testProperty "persistent storeGet . storeSet" persistentSetGet - , testCase "WrongType storeGet . storeSet" wrongType + [ testProperty "simple get . set" simpleSetGet + , testProperty "persistent get . set" persistentSetGet + , testCase "WrongType get . set" wrongType ] + +-------------------------------------------------------------------------------- simpleSetGet :: Property simpleSetGet = monadicIO $ do - identifier <- parseIdentifier . unFileName <$> pick arbitrary - FileName name <- pick arbitrary + key <- pick arbitrary value <- pick arbitrary store <- run $ makeStoreTest - run $ storeSet store name identifier (value :: String) - value' <- run $ storeGet store name identifier - assert $ Found value == value' + run $ Store.set store key (value :: String) + value' <- run $ Store.get store key + assert $ Store.Found value == value' + +-------------------------------------------------------------------------------- persistentSetGet :: Property persistentSetGet = monadicIO $ do - identifier <- parseIdentifier . unFileName <$> pick arbitrary - FileName name <- pick arbitrary - value <- pick arbitrary + key <- pick arbitrary + value <- pick arbitrary store1 <- run $ makeStoreTest - run $ storeSet store1 name identifier (value :: String) + run $ Store.set store1 key (value :: String) -- Now Create another store from the same dir to test persistence store2 <- run $ makeStoreTest - value' <- run $ storeGet store2 name identifier - assert $ Found value == value' + value' <- run $ Store.get store2 key + assert $ Store.Found value == value' + +-------------------------------------------------------------------------------- wrongType :: H.Assertion wrongType = do store <- makeStoreTest -- Store a string and try to fetch an int - storeSet store "foo" "bar" ("qux" :: String) - value <- storeGet store "foo" "bar" :: IO (StoreGet Int) - H.assert $ case value of WrongType _ _ -> True - _ -> False - -newtype FileName = FileName {unFileName :: String} - deriving (Show) - -instance Arbitrary FileName where - arbitrary = do - length' <- choose (5, 100) - str <- replicateM length' $ elements cs - return $ FileName str - where - cs = ['a' .. 'z'] ++ ['A' .. 'Z'] ++ ['0' .. '9'] ++ ".- " + Store.set store ["foo", "bar"] ("qux" :: String) + value <- Store.get store ["foo", "bar"] :: IO (Store.Result Int) + print value + H.assert $ case value of + Store.WrongType e t -> + e == typeOf (undefined :: Int) && + t == typeOf (undefined :: String) + _ -> False diff --git a/tests/TestSuite/Util.hs b/tests/TestSuite/Util.hs index aa34ab6..4fd87bf 100644 --- a/tests/TestSuite/Util.hs +++ b/tests/TestSuite/Util.hs @@ -16,7 +16,8 @@ import Hakyll.Core.Compiler.Internal import Hakyll.Core.Identifier import Hakyll.Core.Logger import Hakyll.Core.Resource.Provider -import Hakyll.Core.Store +import Hakyll.Core.Store (Store) +import qualified Hakyll.Core.Store as Store fromAssertions :: String -- ^ Name -> [Assertion] -- ^ Cases @@ -28,7 +29,7 @@ fromAssertions name = zipWith testCase names -- | Create a store for testing -- makeStoreTest :: IO Store -makeStoreTest = makeStore True "_store" +makeStoreTest = Store.new True "_store" -- | Testing for 'runCompilerJob' -- |