@@ -1,111 +1,120 @@
1−-- | A store for stroing and retreiving items
2−--
3−{-# LANGUAGE ExistentialQuantification, ScopedTypeVariables #-}
1+--------------------------------------------------------------------------------
2+-- | A store for storing and retreiving items
3+{-# LANGUAGE ExistentialQuantification #-}
4+{-# LANGUAGE ScopedTypeVariables #-}
45module Hakyll.Core.Store
56 ( Store
6− , StoreGet (..)
7− , makeStore
8− , storeSet
9− , storeGet
7+ , Result (..)
8+ , new
9+ , set
10+ , get
11+ , delete
1012 ) where
1113
12−import Control.Applicative ((<$>))
13−import System.FilePath ((</>))
14−import System.Directory (doesFileExist)
15−import Data.Maybe (fromMaybe)
1614
17−import Data.Binary (Binary, encodeFile, decodeFile)
18−import Data.Typeable (Typeable, TypeRep, cast, typeOf)
15+--------------------------------------------------------------------------------
16+import Control.Applicative ((<$>))
17+import Control.Exception (IOException, handle)
18+import qualified Crypto.Hash.MD5 as MD5
19+import Data.Binary (Binary, decodeFile, encodeFile)
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)
1930
20−import Hakyll.Core.Identifier
21−import Hakyll.Core.Util.File
22−import qualified Data.Cache.LRU.IO as LRU
2331
24−-- | Items we can store
25−--
26−data Storable = forall a. (Binary a, Typeable a) => Storable a
32+--------------------------------------------------------------------------------
33+-- | Simple wrapper type
34+data Box = forall a. Typeable a => Box a
2735
28−-- | Result when an item from the store
29−--
30−data StoreGet a = Found a
31− | NotFound
32− | WrongType TypeRep TypeRep
33− deriving (Show, Eq)
3436
35−-- | Data structure used for the store
36−--
37+--------------------------------------------------------------------------------
3738data Store = Store
3839 { -- | All items are stored on the filesystem
3940 storeDirectory :: FilePath
40− , -- | And some items are also kept in-memory
41− storeLRU :: Maybe (LRU.AtomicLRU FilePath Storable)
41+ , -- | Optionally, items are also kept in-memory
42+ storeMap :: Maybe (Lru.AtomicLRU FilePath Box)
4243 }
4344
44−-- | The size of the in-memory cache to use in items.
45−storeLRUSize :: Maybe Integer
46−storeLRUSize = Just 500
4745
46+--------------------------------------------------------------------------------
47+-- | Result of a store query
48+data Result a
49+ = Found a -- ^ Found, result
50+ | NotFound -- ^ Not found
51+ | WrongType TypeRep TypeRep -- ^ Expected, true type
52+ deriving (Show, Eq)
53+
54+
55+--------------------------------------------------------------------------------
4856-- | Initialize the store
49−--
50−makeStore :: Bool -- ^ Use in-memory caching
51− -> FilePath -- ^ Directory to use for hard disk storage
52− -> IO Store -- ^ Store
53−makeStore inMemory directory = do
54− lru <- if inMemory
55− then Just <$> LRU.newAtomicLRU storeLRUSize
56− else return Nothing
57+new :: Bool -- ^ Use in-memory caching
58+ -> FilePath -- ^ Directory to use for hard disk storage
59+ -> IO Store -- ^ Store
60+new inMemory directory = do
61+ createDirectoryIfMissing True directory
62+ ref <- if inMemory then Just <$> Lru.newAtomicLRU csize else return Nothing
5763 return Store
5864 { storeDirectory = directory
59− , storeLRU = lru
65+ , storeMap = ref
6066 }
61−
62−-- | Auxiliary: add an item to the map
63−--
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
68−
69−-- | Auxiliary: get an item from the cache
70−--
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
76− case res of
77− Nothing -> return NotFound
78− Just (Storable s) -> return $ case cast s of
79− Nothing -> WrongType (typeOf s) $ typeOf (undefined :: a)
80− Just s' -> Found s'
81−
82−-- | Create a path
83−--
84−makePath :: Store -> String -> Identifier a -> FilePath
85−makePath store name identifier = storeDirectory store </> name
86− </> group </> toFilePath identifier </> "hakyllstore"
8767 where
88− group = fromMaybe "" $ identifierGroup identifier
68+ csize = Just 500
69+
70+
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
77+
78+
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
85+ return $ case res of
86+ Nothing -> NotFound
87+ Just (Box x) -> case cast x of
88+ Just x' -> Found x'
89+ Nothing -> WrongType (typeOf (undefined :: a)) (typeOf x)
90+
91+
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
98+ return ()
8999
100+
101+--------------------------------------------------------------------------------
90102-- | Store an item
91−--
92−storeSet :: (Binary a, Typeable a)
93− => Store -> String -> Identifier a -> a -> IO ()
94−storeSet store name identifier value = do
95− makeDirectories path
96− encodeFile path value
97− cacheInsert store path value
103+set :: (Binary a, Typeable a) => Store -> [String] -> a -> IO ()
104+set store identifier value = do
105+ encodeFile (storeDirectory store </> key) value
106+ cacheInsert store key value
98107 where
99− path = makePath store name identifier
108+ key = hash identifier
109+
100110
111+--------------------------------------------------------------------------------
101112-- | Load an item
102−--
103−storeGet :: (Binary a, Typeable a)
104− => Store -> String -> Identifier a -> IO (StoreGet a)
105−storeGet store name identifier = do
113+get :: (Binary a, Typeable a) => Store -> [String] -> IO (Result a)
114+get store identifier = do
106115 -- First check the in-memory map
107− mv <- cacheLookup store path
108− case mv of
116+ ref <- cacheLookup store key
117+ case ref of
109118 -- Not found in the map, try the filesystem
110119 NotFound -> do
111120 exists <- doesFileExist path
@@ -113,10 +122,34 @@ storeGet store name identifier = do
113122 -- Not found in the filesystem either
114123 then return NotFound
115124 -- Found in the filesystem
116− else do v <- decodeFile path
117− cacheInsert store path v
118− return $ Found v
119− -- Found in the in-memory map, just return
125+ else do
126+ v <- decodeFile path
127+ cacheInsert store key v
128+ return $ Found v
129+ -- Found in the in-memory map (or wrong type), just return
120130 s -> return s
121131 where
122− path = makePath store name identifier
132+ key = hash identifier
133+ path = storeDirectory store </> key
134+
135+
136+--------------------------------------------------------------------------------
137+-- | Delete an item
138+delete :: Store -> [String] -> IO ()
139+delete store identifier = do
140+ cacheDelete store key
141+ deleteFile $ storeDirectory store </> key
142+ where
143+ key = hash identifier
144+
145+
146+--------------------------------------------------------------------------------
147+hash :: [String] -> String
148+hash = concatMap (printf "%02x") . B.unpack .
149+ MD5.hash . T.encodeUtf8 . T.pack . intercalate "/"
150+
151+
152+--------------------------------------------------------------------------------
153+-- | Delete a file unless it doesn't exist...
154+deleteFile :: FilePath -> IO ()
155+deleteFile = handle (\(_ :: IOException) -> return ()) . removeFile