git.iko.soy/hakyll
on bc360a3 help sign in
hakyll/src/Hakyll/Core/Store.hs
198 lines 6.9 kB history raw
1--------------------------------------------------------------------------------
2-- | A store for storing and retreiving items
3{-# LANGUAGE ExistentialQuantification #-}
4{-# LANGUAGE ScopedTypeVariables #-}
5module Hakyll.Core.Store
6 ( Store
7 , Result (..)
8 , toMaybe
9 , new
10 , set
11 , get
12 , isMember
13 , delete
14 , hash
15 ) where
18--------------------------------------------------------------------------------
19import Control.Applicative ((<$>))
20import Control.Exception (IOException, handle)
21import qualified Crypto.Hash.MD5 as MD5
22import Data.Binary (Binary, decode, encodeFile)
23import qualified Data.ByteString as B
24import qualified Data.ByteString.Lazy as BL
25import qualified Data.Cache.LRU.IO as Lru
26import Data.List (intercalate)
27import Data.Maybe (isJust)
28import qualified Data.Text as T
29import qualified Data.Text.Encoding as T
30import Data.Typeable (TypeRep, Typeable, cast, typeOf)
31import System.Directory (createDirectoryIfMissing)
32import System.Directory (doesFileExist, removeFile)
33import System.FilePath ((</>))
34import System.IO (IOMode (..), hClose, openFile)
35import Text.Printf (printf)
38--------------------------------------------------------------------------------
39-- | Simple wrapper type
40data Box = forall a. Typeable a => Box a
43--------------------------------------------------------------------------------
44data Store = Store
45 { -- | All items are stored on the filesystem
46 storeDirectory :: FilePath
47 , -- | Optionally, items are also kept in-memory
48 storeMap :: Maybe (Lru.AtomicLRU FilePath Box)
49 }
52--------------------------------------------------------------------------------
53instance Show Store where
54 show _ = "<Store>"
57--------------------------------------------------------------------------------
58-- | Result of a store query
59data Result a
60 = Found a -- ^ Found, result
61 | NotFound -- ^ Not found
62 | WrongType TypeRep TypeRep -- ^ Expected, true type
63 deriving (Show, Eq)
66--------------------------------------------------------------------------------
67-- | Convert result to 'Maybe'
68toMaybe :: Result a -> Maybe a
69toMaybe (Found x) = Just x
70toMaybe _ = Nothing
73--------------------------------------------------------------------------------
74-- | Initialize the store
75new :: Bool -- ^ Use in-memory caching
76 -> FilePath -- ^ Directory to use for hard disk storage
77 -> IO Store -- ^ Store
78new inMemory directory = do
79 createDirectoryIfMissing True directory
80 ref <- if inMemory then Just <$> Lru.newAtomicLRU csize else return Nothing
81 return Store
82 { storeDirectory = directory
83 , storeMap = ref
84 }
85 where
86 csize = Just 500
89--------------------------------------------------------------------------------
90-- | Auxiliary: add an item to the in-memory cache
91cacheInsert :: Typeable a => Store -> String -> a -> IO ()
92cacheInsert (Store _ Nothing) _ _ = return ()
93cacheInsert (Store _ (Just lru)) key x =
94 Lru.insert key (Box x) lru
97--------------------------------------------------------------------------------
98-- | Auxiliary: get an item from the in-memory cache
99cacheLookup :: forall a. Typeable a => Store -> String -> IO (Result a)
100cacheLookup (Store _ Nothing) _ = return NotFound
101cacheLookup (Store _ (Just lru)) key = do
102 res <- Lru.lookup key lru
103 return $ case res of
104 Nothing -> NotFound
105 Just (Box x) -> case cast x of
106 Just x' -> Found x'
107 Nothing -> WrongType (typeOf (undefined :: a)) (typeOf x)
110--------------------------------------------------------------------------------
111cacheIsMember :: Store -> String -> IO Bool
112cacheIsMember (Store _ Nothing) _ = return False
113cacheIsMember (Store _ (Just lru)) key = isJust <$> Lru.lookup key lru
116--------------------------------------------------------------------------------
117-- | Auxiliary: delete an item from the in-memory cache
118cacheDelete :: Store -> String -> IO ()
119cacheDelete (Store _ Nothing) _ = return ()
120cacheDelete (Store _ (Just lru)) key = do
121 _ <- Lru.delete key lru
122 return ()
125--------------------------------------------------------------------------------
126-- | Store an item
127set :: (Binary a, Typeable a) => Store -> [String] -> a -> IO ()
128set store identifier value = do
129 encodeFile (storeDirectory store </> key) value
130 cacheInsert store key value
131 where
132 key = hash identifier
135--------------------------------------------------------------------------------
136-- | Load an item
137get :: (Binary a, Typeable a) => Store -> [String] -> IO (Result a)
138get store identifier = do
139 -- First check the in-memory map
140 ref <- cacheLookup store key
141 case ref of
142 -- Not found in the map, try the filesystem
143 NotFound -> do
144 exists <- doesFileExist path
145 if not exists
146 -- Not found in the filesystem either
147 then return NotFound
148 -- Found in the filesystem
149 else do
150 v <- decodeClose
151 cacheInsert store key v
152 return $ Found v
153 -- Found in the in-memory map (or wrong type), just return
154 s -> return s
155 where
156 key = hash identifier
157 path = storeDirectory store </> key
159 -- 'decodeFile' from Data.Binary which closes the file ASAP
160 decodeClose = do
161 h <- openFile path ReadMode
162 lbs <- BL.hGetContents h
163 BL.length lbs `seq` hClose h
164 return $ decode lbs
167--------------------------------------------------------------------------------
168-- | Strict function
169isMember :: Store -> [String] -> IO Bool
170isMember store identifier = do
171 inCache <- cacheIsMember store key
172 if inCache then return True else doesFileExist path
173 where
174 key = hash identifier
175 path = storeDirectory store </> key
178--------------------------------------------------------------------------------
179-- | Delete an item
180delete :: Store -> [String] -> IO ()
181delete store identifier = do
182 cacheDelete store key
183 deleteFile $ storeDirectory store </> key
184 where
185 key = hash identifier
188--------------------------------------------------------------------------------
189-- | Delete a file unless it doesn't exist...
190deleteFile :: FilePath -> IO ()
191deleteFile = handle (\(_ :: IOException) -> return ()) . removeFile
194--------------------------------------------------------------------------------
195-- | Mostly meant for internal usage
196hash :: [String] -> String
197hash = concatMap (printf "%02x") . B.unpack .
198 MD5.hash . T.encodeUtf8 . T.pack . intercalate "/"