git.iko.soy/hakyll
on b287c82 help sign in
hakyll/src/Hakyll/Core/Store.hs
165 lines 5.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 , delete
13 , hash
14 ) where
17--------------------------------------------------------------------------------
18import Control.Applicative ((<$>))
19import Control.Exception (IOException, handle)
20import qualified Crypto.Hash.MD5 as MD5
21import Data.Binary (Binary, decodeFile, encodeFile)
22import qualified Data.ByteString as B
23import qualified Data.Cache.LRU.IO as Lru
24import Data.List (intercalate)
25import qualified Data.Text as T
26import qualified Data.Text.Encoding as T
27import Data.Typeable (TypeRep, Typeable, cast, typeOf)
28import System.Directory (createDirectoryIfMissing)
29import System.Directory (doesFileExist, removeFile)
30import System.FilePath ((</>))
31import Text.Printf (printf)
34--------------------------------------------------------------------------------
35-- | Simple wrapper type
36data Box = forall a. Typeable a => Box a
39--------------------------------------------------------------------------------
40data Store = Store
41 { -- | All items are stored on the filesystem
42 storeDirectory :: FilePath
43 , -- | Optionally, items are also kept in-memory
44 storeMap :: Maybe (Lru.AtomicLRU FilePath Box)
45 }
48--------------------------------------------------------------------------------
49-- | Result of a store query
50data Result a
51 = Found a -- ^ Found, result
52 | NotFound -- ^ Not found
53 | WrongType TypeRep TypeRep -- ^ Expected, true type
54 deriving (Show, Eq)
57--------------------------------------------------------------------------------
58-- | Convert result to 'Maybe'
59toMaybe :: Result a -> Maybe a
60toMaybe (Found x) = Just x
61toMaybe _ = Nothing
64--------------------------------------------------------------------------------
65-- | Initialize the store
66new :: Bool -- ^ Use in-memory caching
67 -> FilePath -- ^ Directory to use for hard disk storage
68 -> IO Store -- ^ Store
69new inMemory directory = do
70 createDirectoryIfMissing True directory
71 ref <- if inMemory then Just <$> Lru.newAtomicLRU csize else return Nothing
72 return Store
73 { storeDirectory = directory
74 , storeMap = ref
75 }
76 where
77 csize = Just 500
80--------------------------------------------------------------------------------
81-- | Auxiliary: add an item to the in-memory cache
82cacheInsert :: Typeable a => Store -> String -> a -> IO ()
83cacheInsert (Store _ Nothing) _ _ = return ()
84cacheInsert (Store _ (Just lru)) key x =
85 Lru.insert key (Box x) lru
88--------------------------------------------------------------------------------
89-- | Auxiliary: get an item from the in-memory cache
90cacheLookup :: forall a. Typeable a => Store -> String -> IO (Result a)
91cacheLookup (Store _ Nothing) _ = return NotFound
92cacheLookup (Store _ (Just lru)) key = do
93 res <- Lru.lookup key lru
94 return $ case res of
95 Nothing -> NotFound
96 Just (Box x) -> case cast x of
97 Just x' -> Found x'
98 Nothing -> WrongType (typeOf (undefined :: a)) (typeOf x)
101--------------------------------------------------------------------------------
102-- | Auxiliary: delete an item from the in-memory cache
103cacheDelete :: Store -> String -> IO ()
104cacheDelete (Store _ Nothing) _ = return ()
105cacheDelete (Store _ (Just lru)) key = do
106 _ <- Lru.delete key lru
107 return ()
110--------------------------------------------------------------------------------
111-- | Store an item
112set :: (Binary a, Typeable a) => Store -> [String] -> a -> IO ()
113set store identifier value = do
114 encodeFile (storeDirectory store </> key) value
115 cacheInsert store key value
116 where
117 key = hash identifier
120--------------------------------------------------------------------------------
121-- | Load an item
122get :: (Binary a, Typeable a) => Store -> [String] -> IO (Result a)
123get store identifier = do
124 -- First check the in-memory map
125 ref <- cacheLookup store key
126 case ref of
127 -- Not found in the map, try the filesystem
128 NotFound -> do
129 exists <- doesFileExist path
130 if not exists
131 -- Not found in the filesystem either
132 then return NotFound
133 -- Found in the filesystem
134 else do
135 v <- decodeFile path
136 cacheInsert store key v
137 return $ Found v
138 -- Found in the in-memory map (or wrong type), just return
139 s -> return s
140 where
141 key = hash identifier
142 path = storeDirectory store </> key
145--------------------------------------------------------------------------------
146-- | Delete an item
147delete :: Store -> [String] -> IO ()
148delete store identifier = do
149 cacheDelete store key
150 deleteFile $ storeDirectory store </> key
151 where
152 key = hash identifier
155--------------------------------------------------------------------------------
156-- | Delete a file unless it doesn't exist...
157deleteFile :: FilePath -> IO ()
158deleteFile = handle (\(_ :: IOException) -> return ()) . removeFile
161--------------------------------------------------------------------------------
162-- | Mostly meant for internal usage
163hash :: [String] -> String
164hash = concatMap (printf "%02x") . B.unpack .
165 MD5.hash . T.encodeUtf8 . T.pack . intercalate "/"