Pick Store from the develop branch

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'
 --