module Hakyll.Core.Store
( Store
, StoreGet (..)
, makeStore
, storeSet
, storeGet
) where
import Control.Applicative ((<$>))
import System.FilePath ((</>))
import System.Directory (doesFileExist)
import Data.Maybe (fromMaybe)
import Data.Binary (Binary, encodeFile, decodeFile)
import Data.Typeable (Typeable, TypeRep, cast, typeOf)
import Hakyll.Core.Identifier
import Hakyll.Core.Util.File
import qualified Data.Cache.LRU.IO as LRU
data Storable = forall a. (Binary a, Typeable a) => Storable a
data StoreGet a = Found a
| NotFound
| WrongType TypeRep TypeRep
deriving (Show, Eq)
data Store = Store
{
storeDirectory :: FilePath
,
storeLRU :: Maybe (LRU.AtomicLRU FilePath Storable)
}
storeLRUSize :: Maybe Integer
storeLRUSize = Just 500
makeStore :: Bool
-> FilePath
-> IO Store
makeStore inMemory directory = do
lru <- if inMemory
then Just <$> LRU.newAtomicLRU storeLRUSize
else return Nothing
return Store
{ storeDirectory = directory
, storeLRU = lru
}
cacheInsert :: (Binary a, Typeable a) => Store -> FilePath -> a -> IO ()
cacheInsert (Store _ Nothing) _ _ = return ()
cacheInsert (Store _ (Just lru)) path value =
LRU.insert path (Storable value) lru
cacheLookup :: forall a. (Binary a, Typeable a)
=> Store -> FilePath -> IO (StoreGet a)
cacheLookup (Store _ Nothing) _ = return NotFound
cacheLookup (Store _ (Just lru)) path = do
res <- LRU.lookup path lru
case res of
Nothing -> return NotFound
Just (Storable s) -> return $ case cast s of
Nothing -> WrongType (typeOf s) $ typeOf (undefined :: a)
Just s' -> Found s'
makePath :: Store -> String -> Identifier a -> FilePath
makePath store name identifier = storeDirectory store </> name
</> group </> toFilePath identifier </> "hakyllstore"
where
group = fromMaybe "" $ identifierGroup identifier
storeSet :: (Binary a, Typeable a)
=> Store -> String -> Identifier a -> a -> IO ()
storeSet store name identifier value = do
makeDirectories path
encodeFile path value
cacheInsert store path value
where
path = makePath store name identifier
storeGet :: (Binary a, Typeable a)
=> Store -> String -> Identifier a -> IO (StoreGet a)
storeGet store name identifier = do
mv <- cacheLookup store path
case mv of
NotFound -> do
exists <- doesFileExist path
if not exists
then return NotFound
else do v <- decodeFile path
cacheInsert store path v
return $ Found v
s -> return s
where
path = makePath store name identifier