1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
|
--------------------------------------------------------------------------------
-- | A store for storing and retreiving items
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Hakyll.Core.Store
( Store
, Result (..)
, new
, set
, get
, delete
) where
--------------------------------------------------------------------------------
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)
--------------------------------------------------------------------------------
-- | Simple wrapper type
data Box = forall a. Typeable a => Box a
--------------------------------------------------------------------------------
data Store = Store
{ -- | All items are stored on the filesystem
storeDirectory :: FilePath
, -- | Optionally, items are also kept in-memory
storeMap :: Maybe (Lru.AtomicLRU FilePath Box)
}
--------------------------------------------------------------------------------
-- | 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
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
, storeMap = ref
}
where
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
set :: (Binary a, Typeable a) => Store -> [String] -> a -> IO ()
set store identifier value = do
encodeFile (storeDirectory store </> key) value
cacheInsert store key value
where
key = hash identifier
--------------------------------------------------------------------------------
-- | Load an item
get :: (Binary a, Typeable a) => Store -> [String] -> IO (Result a)
get store identifier = do
-- First check the in-memory map
ref <- cacheLookup store key
case ref of
-- Not found in the map, try the filesystem
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
cacheInsert store key v
return $ Found v
-- Found in the in-memory map (or wrong type), just return
s -> return s
where
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
|
