diff options
author | Jasper Van der Jeugt <m@jaspervdj.be> | 2012-05-12 13:17:20 +0200 |
---|---|---|
committer | Jasper Van der Jeugt <m@jaspervdj.be> | 2012-05-12 13:17:20 +0200 |
commit | 759f1e61eadc29708e60fd51bfb92b9fa5c90ec2 (patch) | |
tree | b985035dee70db88506745d49b4552bc2645c951 /src/Hakyll/Core | |
parent | c64479b71594ae2ab72929cc77f3308da8fb3b13 (diff) | |
download | hakyll-759f1e61eadc29708e60fd51bfb92b9fa5c90ec2.tar.gz |
Memory optimizations
Diffstat (limited to 'src/Hakyll/Core')
-rw-r--r-- | src/Hakyll/Core/Configuration.hs | 4 | ||||
-rw-r--r-- | src/Hakyll/Core/Run.hs | 2 | ||||
-rw-r--r-- | src/Hakyll/Core/Store.hs | 49 |
3 files changed, 37 insertions, 18 deletions
diff --git a/src/Hakyll/Core/Configuration.hs b/src/Hakyll/Core/Configuration.hs index e71d52d..82e72b0 100644 --- a/src/Hakyll/Core/Configuration.hs +++ b/src/Hakyll/Core/Configuration.hs @@ -40,6 +40,9 @@ data HakyllConfiguration = HakyllConfiguration -- > ./hakyll deploy -- deployCommand :: String + , -- | Use an in-memory cache for items. This is faster but uses more + -- memory. + inMemoryCache :: Bool } -- | Default configuration for a hakyll application @@ -50,6 +53,7 @@ defaultHakyllConfiguration = HakyllConfiguration , storeDirectory = "_cache" , ignoreFile = ignoreFile' , deployCommand = "echo 'No deploy command specified'" + , inMemoryCache = False } where ignoreFile' path diff --git a/src/Hakyll/Core/Run.hs b/src/Hakyll/Core/Run.hs index 4384f40..c662886 100644 --- a/src/Hakyll/Core/Run.hs +++ b/src/Hakyll/Core/Run.hs @@ -42,7 +42,7 @@ run configuration rules = do section logger "Initialising" store <- timed logger "Creating store" $ - makeStore $ storeDirectory configuration + makeStore (inMemoryCache configuration) $ storeDirectory configuration provider <- timed logger "Creating provider" $ fileResourceProvider configuration diff --git a/src/Hakyll/Core/Store.hs b/src/Hakyll/Core/Store.hs index 3000910..9c1b9ba 100644 --- a/src/Hakyll/Core/Store.hs +++ b/src/Hakyll/Core/Store.hs @@ -9,6 +9,7 @@ module Hakyll.Core.Store , storeGet ) where +import Control.Applicative ((<$>)) import Control.Concurrent.MVar (MVar, newMVar, readMVar, modifyMVar_) import System.FilePath ((</>)) import System.Directory (doesFileExist) @@ -39,14 +40,16 @@ data Store = Store { -- | All items are stored on the filesystem storeDirectory :: FilePath , -- | And some items are also kept in-memory - storeMap :: MVar (Map FilePath Storable) + storeMap :: Maybe (MVar (Map FilePath Storable)) } -- | Initialize the store -- -makeStore :: FilePath -> IO Store -makeStore directory = do - mvar <- newMVar M.empty +makeStore :: Bool -- ^ Use in-memory caching + -> FilePath -- ^ Directory to use for hard disk storage + -> IO Store -- ^ Store +makeStore inMemory directory = do + mvar <- if inMemory then Just <$> newMVar M.empty else return Nothing return Store { storeDirectory = directory , storeMap = mvar @@ -54,9 +57,23 @@ makeStore directory = do -- | Auxiliary: add an item to the map -- -addToMap :: (Binary a, Typeable a) => Store -> FilePath -> a -> IO () -addToMap store path value = - modifyMVar_ (storeMap store) $ return . M.insert path (Storable value) +cacheInsert :: (Binary a, Typeable a) => Store -> FilePath -> a -> IO () +cacheInsert (Store _ Nothing) _ _ = return () +cacheInsert (Store _ (Just mv)) path value = + modifyMVar_ mv $ return . M.insert path (Storable value) + +-- | 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 mv)) path = do + map' <- readMVar mv + case M.lookup path map' 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 -- @@ -73,31 +90,29 @@ storeSet :: (Binary a, Typeable a) storeSet store name identifier value = do makeDirectories path encodeFile path value - addToMap store path value + cacheInsert store path value where path = makePath store name identifier -- | Load an item -- -storeGet :: forall a. (Binary a, Typeable a) +storeGet :: (Binary a, Typeable a) => Store -> String -> Identifier a -> IO (StoreGet a) storeGet store name identifier = do -- First check the in-memory map - map' <- readMVar $ storeMap store - case M.lookup path map' of - -- Found in the in-memory map - Just (Storable s) -> return $ case cast s of - Nothing -> WrongType (typeOf s) $ typeOf (undefined :: a) - Just s' -> Found s' + mv <- cacheLookup store path + case mv of -- Not found in the map, try the filesystem - Nothing -> do + NotFound -> do exists <- doesFileExist path if not exists -- Not found in the filesystem either then return NotFound -- Found in the filesystem else do v <- decodeFile path - addToMap store path v + cacheInsert store path v return $ Found v + -- Found in the in-memory map, just return + s -> return s where path = makePath store name identifier |