summaryrefslogtreecommitdiff
path: root/src/Hakyll/Core
diff options
context:
space:
mode:
Diffstat (limited to 'src/Hakyll/Core')
-rw-r--r--src/Hakyll/Core/Compiler.hs27
-rw-r--r--src/Hakyll/Core/Resource/Provider.hs39
-rw-r--r--src/Hakyll/Core/Run.hs13
-rw-r--r--src/Hakyll/Core/Store.hs207
4 files changed, 168 insertions, 118 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
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-30 15:23:57 +0000