@@ -1,111 +1,120 @@
1+--------------------------------------------------------------------------------
1−-- | A store for stroing and retreiving items
2+-- | A store for storing and retreiving items
3−{-# LANGUAGE ExistentialQuantification, ScopedTypeVariables #-}
3+{-# LANGUAGE ExistentialQuantification #-}
4+{-# LANGUAGE ScopedTypeVariables #-}
4module Hakyll.Core.Store
5module Hakyll.Core.Store
6− , StoreGet (..)
7+ , Result (..)
12−import Control.Applicative ((<$>))
13−import System.FilePath ((</>))
14−import System.Directory (doesFileExist)
15−import Data.Maybe (fromMaybe)
15+--------------------------------------------------------------------------------
16+import Control.Applicative ((<$>))
17+import Control.Exception (IOException, handle)
18+import qualified Crypto.Hash.MD5 as MD5
17−import Data.Binary (Binary, encodeFile, decodeFile)
19+import Data.Binary (Binary, decodeFile, encodeFile)
18−import Data.Typeable (Typeable, TypeRep, cast, typeOf)
20+import qualified Data.ByteString as B
21+import qualified Data.Cache.LRU.IO as Lru
22+import Data.List (intercalate)
23+import qualified Data.Text as T
24+import qualified Data.Text.Encoding as T
25+import Data.Typeable (TypeRep, Typeable, cast, typeOf)
26+import System.Directory (createDirectoryIfMissing)
27+import System.Directory (doesFileExist, removeFile)
28+import System.FilePath ((</>))
29+import Text.Printf (printf)
20−import Hakyll.Core.Identifier
21−import Hakyll.Core.Util.File
22−import qualified Data.Cache.LRU.IO as LRU
24−-- | Items we can store
32+--------------------------------------------------------------------------------
25−--
33+-- | Simple wrapper type
26−data Storable = forall a. (Binary a, Typeable a) => Storable a
34+data Box = forall a. Typeable a => Box a
28−-- | Result when an item from the store
30−data StoreGet a = Found a
32− | WrongType TypeRep TypeRep
35−-- | Data structure used for the store
37+--------------------------------------------------------------------------------
37data Store = Store
38data Store = Store
38 { -- | All items are stored on the filesystem
39 { -- | All items are stored on the filesystem
39 storeDirectory :: FilePath
40 storeDirectory :: FilePath
40− , -- | And some items are also kept in-memory
41+ , -- | Optionally, items are also kept in-memory
41− storeLRU :: Maybe (LRU.AtomicLRU FilePath Storable)
42+ storeMap :: Maybe (Lru.AtomicLRU FilePath Box)
44−-- | The size of the in-memory cache to use in items.
45−storeLRUSize :: Maybe Integer
46−storeLRUSize = Just 500
46+--------------------------------------------------------------------------------
47+-- | Result of a store query
49+ = Found a -- ^ Found, result
50+ | NotFound -- ^ Not found
51+ | WrongType TypeRep TypeRep -- ^ Expected, true type
55+--------------------------------------------------------------------------------
48-- | Initialize the store
56-- | Initialize the store
50−makeStore :: Bool -- ^ Use in-memory caching
57+new :: Bool -- ^ Use in-memory caching
51− -> FilePath -- ^ Directory to use for hard disk storage
58+ -> FilePath -- ^ Directory to use for hard disk storage
52− -> IO Store -- ^ Store
59+ -> IO Store -- ^ Store
53−makeStore inMemory directory = do
60+new inMemory directory = do
54− lru <- if inMemory
61+ createDirectoryIfMissing True directory
55− then Just <$> LRU.newAtomicLRU storeLRUSize
56− else return Nothing
62+ ref <- if inMemory then Just <$> Lru.newAtomicLRU csize else return Nothing
57 return Store
63 return Store
58 { storeDirectory = directory
64 { storeDirectory = directory
59− , storeLRU = lru
65+ , storeMap = ref
62−-- | Auxiliary: add an item to the map
64−cacheInsert :: (Binary a, Typeable a) => Store -> FilePath -> a -> IO ()
65−cacheInsert (Store _ Nothing) _ _ = return ()
66−cacheInsert (Store _ (Just lru)) path value =
67− LRU.insert path (Storable value) lru
69−-- | Auxiliary: get an item from the cache
71−cacheLookup :: forall a. (Binary a, Typeable a)
72− => Store -> FilePath -> IO (StoreGet a)
73−cacheLookup (Store _ Nothing) _ = return NotFound
74−cacheLookup (Store _ (Just lru)) path = do
75− res <- LRU.lookup path lru
77− Nothing -> return NotFound
78− Just (Storable s) -> return $ case cast s of
79− Nothing -> WrongType (typeOf s) $ typeOf (undefined :: a)
84−makePath :: Store -> String -> Identifier a -> FilePath
85−makePath store name identifier = storeDirectory store </> name
86− </> group </> toFilePath identifier </> "hakyllstore"
88− group = fromMaybe "" $ identifierGroup identifier
68+ csize = Just 500
71+--------------------------------------------------------------------------------
72+-- | Auxiliary: add an item to the in-memory cache
73+cacheInsert :: Typeable a => Store -> String -> a -> IO ()
74+cacheInsert (Store _ Nothing) _ _ = return ()
75+cacheInsert (Store _ (Just lru)) key x =
76+ Lru.insert key (Box x) lru
79+--------------------------------------------------------------------------------
80+-- | Auxiliary: get an item from the in-memory cache
81+cacheLookup :: forall a. Typeable a => Store -> String -> IO (Result a)
82+cacheLookup (Store _ Nothing) _ = return NotFound
83+cacheLookup (Store _ (Just lru)) key = do
84+ res <- Lru.lookup key lru
87+ Just (Box x) -> case cast x of
89+ Nothing -> WrongType (typeOf (undefined :: a)) (typeOf x)
92+--------------------------------------------------------------------------------
93+-- | Auxiliary: delete an item from the in-memory cache
94+cacheDelete :: Store -> String -> IO ()
95+cacheDelete (Store _ Nothing) _ = return ()
96+cacheDelete (Store _ (Just lru)) key = do
97+ _ <- Lru.delete key lru
101+--------------------------------------------------------------------------------
90-- | Store an item
102-- | Store an item
92−storeSet :: (Binary a, Typeable a)
103+set :: (Binary a, Typeable a) => Store -> [String] -> a -> IO ()
93− => Store -> String -> Identifier a -> a -> IO ()
94−storeSet store name identifier value = do
104+set store identifier value = do
96− encodeFile path value
105+ encodeFile (storeDirectory store </> key) value
97− cacheInsert store path value
106+ cacheInsert store key value
99− path = makePath store name identifier
108+ key = hash identifier
111+--------------------------------------------------------------------------------
101-- | Load an item
112-- | Load an item
103−storeGet :: (Binary a, Typeable a)
113+get :: (Binary a, Typeable a) => Store -> [String] -> IO (Result a)
104− => Store -> String -> Identifier a -> IO (StoreGet a)
105−storeGet store name identifier = do
114+get store identifier = do
106 -- First check the in-memory map
115 -- First check the in-memory map
107− mv <- cacheLookup store path
116+ ref <- cacheLookup store key
108− case mv of
117+ case ref of
109 -- Not found in the map, try the filesystem
118 -- Not found in the map, try the filesystem
110 NotFound -> do
119 NotFound -> do
111 exists <- doesFileExist path
120 exists <- doesFileExist path
@@ -113,10 +122,34 @@ storeGet store name identifier = do
113 -- Not found in the filesystem either
122 -- Not found in the filesystem either
114 then return NotFound
123 then return NotFound
115 -- Found in the filesystem
124 -- Found in the filesystem
116− else do v <- decodeFile path
126+ v <- decodeFile path
117− cacheInsert store path v
127+ cacheInsert store key v
118− return $ Found v
128+ return $ Found v
119− -- Found in the in-memory map, just return
129+ -- Found in the in-memory map (or wrong type), just return
120 s -> return s
130 s -> return s
132+ key = hash identifier
133+ path = storeDirectory store </> key
136+--------------------------------------------------------------------------------
138+delete :: Store -> [String] -> IO ()
139+delete store identifier = do
140+ cacheDelete store key
141+ deleteFile $ storeDirectory store </> key
122− path = makePath store name identifier
143+ key = hash identifier
146+--------------------------------------------------------------------------------
147+hash :: [String] -> String
148+hash = concatMap (printf "%02x") . B.unpack .
149+ MD5.hash . T.encodeUtf8 . T.pack . intercalate "/"
152+--------------------------------------------------------------------------------
153+-- | Delete a file unless it doesn't exist...
154+deleteFile :: FilePath -> IO ()
155+deleteFile = handle (\(_ :: IOException) -> return ()) . removeFile