git.iko.soy/hakyll
on 2ef7fee help sign in
hakyll/src/Hakyll/Core/Store.hs
193 lines 6.7 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--------------------------------------------------------------------------------
53-- | Result of a store query
54data Result a
55 = Found a -- ^ Found, result
56 | NotFound -- ^ Not found
57 | WrongType TypeRep TypeRep -- ^ Expected, true type
58 deriving (Show, Eq)
61--------------------------------------------------------------------------------
62-- | Convert result to 'Maybe'
63toMaybe :: Result a -> Maybe a
64toMaybe (Found x) = Just x
65toMaybe _ = Nothing
68--------------------------------------------------------------------------------
69-- | Initialize the store
70new :: Bool -- ^ Use in-memory caching
71 -> FilePath -- ^ Directory to use for hard disk storage
72 -> IO Store -- ^ Store
73new inMemory directory = do
74 createDirectoryIfMissing True directory
75 ref <- if inMemory then Just <$> Lru.newAtomicLRU csize else return Nothing
76 return Store
77 { storeDirectory = directory
78 , storeMap = ref
79 }
80 where
81 csize = Just 500
84--------------------------------------------------------------------------------
85-- | Auxiliary: add an item to the in-memory cache
86cacheInsert :: Typeable a => Store -> String -> a -> IO ()
87cacheInsert (Store _ Nothing) _ _ = return ()
88cacheInsert (Store _ (Just lru)) key x =
89 Lru.insert key (Box x) lru
92--------------------------------------------------------------------------------
93-- | Auxiliary: get an item from the in-memory cache
94cacheLookup :: forall a. Typeable a => Store -> String -> IO (Result a)
95cacheLookup (Store _ Nothing) _ = return NotFound
96cacheLookup (Store _ (Just lru)) key = do
97 res <- Lru.lookup key lru
98 return $ case res of
99 Nothing -> NotFound
100 Just (Box x) -> case cast x of
101 Just x' -> Found x'
102 Nothing -> WrongType (typeOf (undefined :: a)) (typeOf x)
105--------------------------------------------------------------------------------
106cacheIsMember :: Store -> String -> IO Bool
107cacheIsMember (Store _ Nothing) _ = return False
108cacheIsMember (Store _ (Just lru)) key = isJust <$> Lru.lookup key lru
111--------------------------------------------------------------------------------
112-- | Auxiliary: delete an item from the in-memory cache
113cacheDelete :: Store -> String -> IO ()
114cacheDelete (Store _ Nothing) _ = return ()
115cacheDelete (Store _ (Just lru)) key = do
116 _ <- Lru.delete key lru
117 return ()
120--------------------------------------------------------------------------------
121-- | Store an item
122set :: (Binary a, Typeable a) => Store -> [String] -> a -> IO ()
123set store identifier value = do
124 encodeFile (storeDirectory store </> key) value
125 cacheInsert store key value
126 where
127 key = hash identifier
130--------------------------------------------------------------------------------
131-- | Load an item
132get :: (Binary a, Typeable a) => Store -> [String] -> IO (Result a)
133get store identifier = do
134 -- First check the in-memory map
135 ref <- cacheLookup store key
136 case ref of
137 -- Not found in the map, try the filesystem
138 NotFound -> do
139 exists <- doesFileExist path
140 if not exists
141 -- Not found in the filesystem either
142 then return NotFound
143 -- Found in the filesystem
144 else do
145 v <- decodeClose
146 cacheInsert store key v
147 return $ Found v
148 -- Found in the in-memory map (or wrong type), just return
149 s -> return s
150 where
151 key = hash identifier
152 path = storeDirectory store </> key
154 -- 'decodeFile' from Data.Binary which closes the file ASAP
155 decodeClose = do
156 h <- openFile path ReadMode
157 lbs <- BL.hGetContents h
158 BL.length lbs `seq` hClose h
159 return $ decode lbs
162--------------------------------------------------------------------------------
163-- | Strict function
164isMember :: Store -> [String] -> IO Bool
165isMember store identifier = do
166 inCache <- cacheIsMember store key
167 if inCache then return True else doesFileExist path
168 where
169 key = hash identifier
170 path = storeDirectory store </> key
173--------------------------------------------------------------------------------
174-- | Delete an item
175delete :: Store -> [String] -> IO ()
176delete store identifier = do
177 cacheDelete store key
178 deleteFile $ storeDirectory store </> key
179 where
180 key = hash identifier
183--------------------------------------------------------------------------------
184-- | Delete a file unless it doesn't exist...
185deleteFile :: FilePath -> IO ()
186deleteFile = handle (\(_ :: IOException) -> return ()) . removeFile
189--------------------------------------------------------------------------------
190-- | Mostly meant for internal usage
191hash :: [String] -> String
192hash = concatMap (printf "%02x") . B.unpack .
193 MD5.hash . T.encodeUtf8 . T.pack . intercalate "/"