git.iko.soy/hakyll
on 877cb21 help sign in
hakyll/src/Hakyll/Core/Store.hs
155 lines 5.5 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 , new
9 , set
10 , get
11 , delete
12 ) where
15--------------------------------------------------------------------------------
16import Control.Applicative ((<$>))
17import Control.Exception (IOException, handle)
18import qualified Crypto.Hash.MD5 as MD5
19import Data.Binary (Binary, decodeFile, encodeFile)
20import qualified Data.ByteString as B
21import qualified Data.Cache.LRU.IO as Lru
22import Data.List (intercalate)
23import qualified Data.Text as T
24import qualified Data.Text.Encoding as T
25import Data.Typeable (TypeRep, Typeable, cast, typeOf)
26import System.Directory (createDirectoryIfMissing)
27import System.Directory (doesFileExist, removeFile)
28import System.FilePath ((</>))
29import Text.Printf (printf)
32--------------------------------------------------------------------------------
33-- | Simple wrapper type
34data Box = forall a. Typeable a => Box a
37--------------------------------------------------------------------------------
38data Store = Store
39 { -- | All items are stored on the filesystem
40 storeDirectory :: FilePath
41 , -- | Optionally, items are also kept in-memory
42 storeMap :: Maybe (Lru.AtomicLRU FilePath Box)
43 }
46--------------------------------------------------------------------------------
47-- | Result of a store query
48data Result a
49 = Found a -- ^ Found, result
50 | NotFound -- ^ Not found
51 | WrongType TypeRep TypeRep -- ^ Expected, true type
52 deriving (Show, Eq)
55--------------------------------------------------------------------------------
56-- | Initialize the store
57new :: Bool -- ^ Use in-memory caching
58 -> FilePath -- ^ Directory to use for hard disk storage
59 -> IO Store -- ^ Store
60new inMemory directory = do
61 createDirectoryIfMissing True directory
62 ref <- if inMemory then Just <$> Lru.newAtomicLRU csize else return Nothing
63 return Store
64 { storeDirectory = directory
65 , storeMap = ref
66 }
67 where
68 csize = Just 500
71--------------------------------------------------------------------------------
72-- | Auxiliary: add an item to the in-memory cache
73cacheInsert :: Typeable a => Store -> String -> a -> IO ()
74cacheInsert (Store _ Nothing) _ _ = return ()
75cacheInsert (Store _ (Just lru)) key x =
76 Lru.insert key (Box x) lru
79--------------------------------------------------------------------------------
80-- | Auxiliary: get an item from the in-memory cache
81cacheLookup :: forall a. Typeable a => Store -> String -> IO (Result a)
82cacheLookup (Store _ Nothing) _ = return NotFound
83cacheLookup (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)
92--------------------------------------------------------------------------------
93-- | Auxiliary: delete an item from the in-memory cache
94cacheDelete :: Store -> String -> IO ()
95cacheDelete (Store _ Nothing) _ = return ()
96cacheDelete (Store _ (Just lru)) key = do
97 _ <- Lru.delete key lru
98 return ()
101--------------------------------------------------------------------------------
102-- | Store an item
103set :: (Binary a, Typeable a) => Store -> [String] -> a -> IO ()
104set store identifier value = do
105 encodeFile (storeDirectory store </> key) value
106 cacheInsert store key value
107 where
108 key = hash identifier
111--------------------------------------------------------------------------------
112-- | Load an item
113get :: (Binary a, Typeable a) => Store -> [String] -> IO (Result a)
114get store identifier = do
115 -- First check the in-memory map
116 ref <- cacheLookup store key
117 case ref of
118 -- Not found in the map, try the filesystem
119 NotFound -> do
120 exists <- doesFileExist path
121 if not exists
122 -- Not found in the filesystem either
123 then return NotFound
124 -- Found in the filesystem
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
130 s -> return s
131 where
132 key = hash identifier
133 path = storeDirectory store </> key
136--------------------------------------------------------------------------------
137-- | Delete an item
138delete :: Store -> [String] -> IO ()
139delete store identifier = do
140 cacheDelete store key
141 deleteFile $ storeDirectory store </> key
142 where
143 key = hash identifier
146--------------------------------------------------------------------------------
147hash :: [String] -> String
148hash = concatMap (printf "%02x") . B.unpack .
149 MD5.hash . T.encodeUtf8 . T.pack . intercalate "/"
152--------------------------------------------------------------------------------
153-- | Delete a file unless it doesn't exist...
154deleteFile :: FilePath -> IO ()
155deleteFile = handle (\(_ :: IOException) -> return ()) . removeFile