{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Hakyll.Core.Store
( Store
, Result (..)
, toMaybe
, new
, set
, get
, isMember
, delete
, hash
) where
import qualified Data.Hashable as DH
import Data.Binary (Binary, decode, encodeFile)
import qualified Data.ByteString.Lazy as BL
import qualified Data.Cache.LRU.IO as Lru
import Data.List (intercalate)
import Data.Maybe (isJust)
import Data.Typeable (TypeRep, Typeable, cast, typeOf)
import System.Directory (createDirectoryIfMissing, doesFileExist, removeFile)
import System.FilePath ((</>))
import System.IO (IOMode (..), hClose, openFile)
import System.IO.Error (catchIOError, ioeSetFileName,
ioeSetLocation, modifyIOError)
data Box = forall a. Typeable a => Box a
data Store = Store
{
Store -> [Char]
storeDirectory :: FilePath
,
Store -> Maybe (AtomicLRU [Char] Box)
storeMap :: Maybe (Lru.AtomicLRU FilePath Box)
}
instance Show Store where
show :: Store -> [Char]
show Store
_ = [Char]
"<Store>"
data Result a
= Found a
| NotFound
| WrongType TypeRep TypeRep
deriving (Int -> Result a -> ShowS
forall a. Show a => Int -> Result a -> ShowS
forall a. Show a => [Result a] -> ShowS
forall a. Show a => Result a -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [Result a] -> ShowS
$cshowList :: forall a. Show a => [Result a] -> ShowS
show :: Result a -> [Char]
$cshow :: forall a. Show a => Result a -> [Char]
showsPrec :: Int -> Result a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> Result a -> ShowS
Show, Result a -> Result a -> Bool
forall a. Eq a => Result a -> Result a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Result a -> Result a -> Bool
$c/= :: forall a. Eq a => Result a -> Result a -> Bool
== :: Result a -> Result a -> Bool
$c== :: forall a. Eq a => Result a -> Result a -> Bool
Eq)
toMaybe :: Result a -> Maybe a
toMaybe :: forall a. Result a -> Maybe a
toMaybe (Found a
x) = forall a. a -> Maybe a
Just a
x
toMaybe Result a
_ = forall a. Maybe a
Nothing
new :: Bool
-> FilePath
-> IO Store
new :: Bool -> [Char] -> IO Store
new Bool
inMemory [Char]
directory = do
Bool -> [Char] -> IO ()
createDirectoryIfMissing Bool
True [Char]
directory
Maybe (AtomicLRU [Char] Box)
ref <- if Bool
inMemory then forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall key val. Ord key => Maybe Integer -> IO (AtomicLRU key val)
Lru.newAtomicLRU Maybe Integer
csize else forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
forall (m :: * -> *) a. Monad m => a -> m a
return Store
{ storeDirectory :: [Char]
storeDirectory = [Char]
directory
, storeMap :: Maybe (AtomicLRU [Char] Box)
storeMap = Maybe (AtomicLRU [Char] Box)
ref
}
where
csize :: Maybe Integer
csize = forall a. a -> Maybe a
Just Integer
500
withStore :: Store -> String -> (String -> FilePath -> IO a) -> [String] -> IO a
withStore :: forall a.
Store -> [Char] -> ([Char] -> [Char] -> IO a) -> [[Char]] -> IO a
withStore Store
store [Char]
loc [Char] -> [Char] -> IO a
run [[Char]]
identifier = forall a. (IOError -> IOError) -> IO a -> IO a
modifyIOError IOError -> IOError
handle forall a b. (a -> b) -> a -> b
$ [Char] -> [Char] -> IO a
run [Char]
key [Char]
path
where
key :: [Char]
key = [[Char]] -> [Char]
hash [[Char]]
identifier
path :: [Char]
path = Store -> [Char]
storeDirectory Store
store [Char] -> ShowS
</> [Char]
key
handle :: IOError -> IOError
handle IOError
e = IOError
e IOError -> [Char] -> IOError
`ioeSetFileName` ([Char]
path forall a. [a] -> [a] -> [a]
++ [Char]
" for " forall a. [a] -> [a] -> [a]
++ forall a. [a] -> [[a]] -> [a]
intercalate [Char]
"/" [[Char]]
identifier)
IOError -> [Char] -> IOError
`ioeSetLocation` ([Char]
"Store." forall a. [a] -> [a] -> [a]
++ [Char]
loc)
cacheInsert :: Typeable a => Store -> String -> a -> IO ()
cacheInsert :: forall a. Typeable a => Store -> [Char] -> a -> IO ()
cacheInsert (Store [Char]
_ Maybe (AtomicLRU [Char] Box)
Nothing) [Char]
_ a
_ = forall (m :: * -> *) a. Monad m => a -> m a
return ()
cacheInsert (Store [Char]
_ (Just AtomicLRU [Char] Box
lru)) [Char]
key a
x =
forall key val. Ord key => key -> val -> AtomicLRU key val -> IO ()
Lru.insert [Char]
key (forall a. Typeable a => a -> Box
Box a
x) AtomicLRU [Char] Box
lru
cacheLookup :: forall a. Typeable a => Store -> String -> IO (Result a)
cacheLookup :: forall a. Typeable a => Store -> [Char] -> IO (Result a)
cacheLookup (Store [Char]
_ Maybe (AtomicLRU [Char] Box)
Nothing) [Char]
_ = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Result a
NotFound
cacheLookup (Store [Char]
_ (Just AtomicLRU [Char] Box
lru)) [Char]
key = do
Maybe Box
res <- forall key val.
Ord key =>
key -> AtomicLRU key val -> IO (Maybe val)
Lru.lookup [Char]
key AtomicLRU [Char] Box
lru
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ case Maybe Box
res of
Maybe Box
Nothing -> forall a. Result a
NotFound
Just (Box a
x) -> case forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast a
x of
Just a
x' -> forall a. a -> Result a
Found a
x'
Maybe a
Nothing -> forall a. TypeRep -> TypeRep -> Result a
WrongType (forall a. Typeable a => a -> TypeRep
typeOf (forall a. HasCallStack => a
undefined :: a)) (forall a. Typeable a => a -> TypeRep
typeOf a
x)
cacheIsMember :: Store -> String -> IO Bool
cacheIsMember :: Store -> [Char] -> IO Bool
cacheIsMember (Store [Char]
_ Maybe (AtomicLRU [Char] Box)
Nothing) [Char]
_ = forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
cacheIsMember (Store [Char]
_ (Just AtomicLRU [Char] Box
lru)) [Char]
key = forall a. Maybe a -> Bool
isJust forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall key val.
Ord key =>
key -> AtomicLRU key val -> IO (Maybe val)
Lru.lookup [Char]
key AtomicLRU [Char] Box
lru
cacheDelete :: Store -> String -> IO ()
cacheDelete :: Store -> [Char] -> IO ()
cacheDelete (Store [Char]
_ Maybe (AtomicLRU [Char] Box)
Nothing) [Char]
_ = forall (m :: * -> *) a. Monad m => a -> m a
return ()
cacheDelete (Store [Char]
_ (Just AtomicLRU [Char] Box
lru)) [Char]
key = do
Maybe Box
_ <- forall key val.
Ord key =>
key -> AtomicLRU key val -> IO (Maybe val)
Lru.delete [Char]
key AtomicLRU [Char] Box
lru
forall (m :: * -> *) a. Monad m => a -> m a
return ()
set :: (Binary a, Typeable a) => Store -> [String] -> a -> IO ()
set :: forall a. (Binary a, Typeable a) => Store -> [[Char]] -> a -> IO ()
set Store
store [[Char]]
identifier a
value = forall a.
Store -> [Char] -> ([Char] -> [Char] -> IO a) -> [[Char]] -> IO a
withStore Store
store [Char]
"set" (\[Char]
key [Char]
path -> do
forall a. Binary a => [Char] -> a -> IO ()
encodeFile [Char]
path a
value
forall a. Typeable a => Store -> [Char] -> a -> IO ()
cacheInsert Store
store [Char]
key a
value
) [[Char]]
identifier
get :: (Binary a, Typeable a) => Store -> [String] -> IO (Result a)
get :: forall a.
(Binary a, Typeable a) =>
Store -> [[Char]] -> IO (Result a)
get Store
store = forall a.
Store -> [Char] -> ([Char] -> [Char] -> IO a) -> [[Char]] -> IO a
withStore Store
store [Char]
"get" forall a b. (a -> b) -> a -> b
$ \[Char]
key [Char]
path -> do
Result a
ref <- forall a. Typeable a => Store -> [Char] -> IO (Result a)
cacheLookup Store
store [Char]
key
case Result a
ref of
Result a
NotFound -> do
Bool
exists <- [Char] -> IO Bool
doesFileExist [Char]
path
if Bool -> Bool
not Bool
exists
then forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Result a
NotFound
else do
a
v <- forall {b}. Binary b => [Char] -> IO b
decodeClose [Char]
path
forall a. Typeable a => Store -> [Char] -> a -> IO ()
cacheInsert Store
store [Char]
key a
v
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Result a
Found a
v
Result a
s -> forall (m :: * -> *) a. Monad m => a -> m a
return Result a
s
where
decodeClose :: [Char] -> IO b
decodeClose [Char]
path = do
Handle
h <- [Char] -> IOMode -> IO Handle
openFile [Char]
path IOMode
ReadMode
ByteString
lbs <- Handle -> IO ByteString
BL.hGetContents Handle
h
ByteString -> Int64
BL.length ByteString
lbs seq :: forall a b. a -> b -> b
`seq` Handle -> IO ()
hClose Handle
h
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. Binary a => ByteString -> a
decode ByteString
lbs
isMember :: Store -> [String] -> IO Bool
isMember :: Store -> [[Char]] -> IO Bool
isMember Store
store = forall a.
Store -> [Char] -> ([Char] -> [Char] -> IO a) -> [[Char]] -> IO a
withStore Store
store [Char]
"isMember" forall a b. (a -> b) -> a -> b
$ \[Char]
key [Char]
path -> do
Bool
inCache <- Store -> [Char] -> IO Bool
cacheIsMember Store
store [Char]
key
if Bool
inCache then forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True else [Char] -> IO Bool
doesFileExist [Char]
path
delete :: Store -> [String] -> IO ()
delete :: Store -> [[Char]] -> IO ()
delete Store
store = forall a.
Store -> [Char] -> ([Char] -> [Char] -> IO a) -> [[Char]] -> IO a
withStore Store
store [Char]
"delete" forall a b. (a -> b) -> a -> b
$ \[Char]
key [Char]
path -> do
Store -> [Char] -> IO ()
cacheDelete Store
store [Char]
key
[Char] -> IO ()
deleteFile [Char]
path
deleteFile :: FilePath -> IO ()
deleteFile :: [Char] -> IO ()
deleteFile = (forall a. IO a -> (IOError -> IO a) -> IO a
`catchIOError` \IOError
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()) forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> IO ()
removeFile
hash :: [String] -> String
hash :: [[Char]] -> [Char]
hash = forall a. Show a => a -> [Char]
show forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Hashable a => a -> Int
DH.hash forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> [[a]] -> [a]
intercalate [Char]
"/"