{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Hakyll.Core.Store
( Store
, Result (..)
, toMaybe
, new
, set
, get
, isMember
, delete
, hash
) where
import Control.Monad (when)
import Data.Binary (Binary, decode, encodeFile)
import qualified Data.ByteString.Lazy as BL
import qualified Data.Cache.LRU.IO as Lru
import qualified Data.Hashable as DH
import qualified Data.IORef as IORef
import Data.List (intercalate)
import qualified Data.Map as Map
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 -> IORef (Map [Char] Box)
storeWriteAhead :: IORef.IORef (Map.Map String Box)
, 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
[Result a] -> ShowS
Result a -> [Char]
(Int -> Result a -> ShowS)
-> (Result a -> [Char]) -> ([Result a] -> ShowS) -> Show (Result a)
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
$cshowsPrec :: forall a. Show a => Int -> Result a -> ShowS
showsPrec :: Int -> Result a -> ShowS
$cshow :: forall a. Show a => Result a -> [Char]
show :: Result a -> [Char]
$cshowList :: forall a. Show a => [Result a] -> ShowS
showList :: [Result a] -> ShowS
Show, Result a -> Result a -> Bool
(Result a -> Result a -> Bool)
-> (Result a -> Result a -> Bool) -> Eq (Result a)
forall a. Eq a => Result a -> Result a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$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
/= :: Result a -> Result a -> Bool
Eq)
toMaybe :: Result a -> Maybe a
toMaybe :: forall a. Result a -> Maybe a
toMaybe (Found a
x) = a -> Maybe a
forall a. a -> Maybe a
Just a
x
toMaybe Result a
_ = Maybe 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
IORef (Map [Char] Box)
writeAhead <- Map [Char] Box -> IO (IORef (Map [Char] Box))
forall a. a -> IO (IORef a)
IORef.newIORef Map [Char] Box
forall k a. Map k a
Map.empty
Maybe (AtomicLRU [Char] Box)
ref <- if Bool
inMemory then AtomicLRU [Char] Box -> Maybe (AtomicLRU [Char] Box)
forall a. a -> Maybe a
Just (AtomicLRU [Char] Box -> Maybe (AtomicLRU [Char] Box))
-> IO (AtomicLRU [Char] Box) -> IO (Maybe (AtomicLRU [Char] Box))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Integer -> IO (AtomicLRU [Char] Box)
forall key val. Ord key => Maybe Integer -> IO (AtomicLRU key val)
Lru.newAtomicLRU Maybe Integer
csize else Maybe (AtomicLRU [Char] Box) -> IO (Maybe (AtomicLRU [Char] Box))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (AtomicLRU [Char] Box)
forall a. Maybe a
Nothing
Store -> IO Store
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Store
{ storeDirectory :: [Char]
storeDirectory = [Char]
directory
, storeWriteAhead :: IORef (Map [Char] Box)
storeWriteAhead = IORef (Map [Char] Box)
writeAhead
, storeMap :: Maybe (AtomicLRU [Char] Box)
storeMap = Maybe (AtomicLRU [Char] Box)
ref
}
where
csize :: Maybe Integer
csize = Integer -> Maybe Integer
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 = (IOError -> IOError) -> IO a -> IO a
forall a. (IOError -> IOError) -> IO a -> IO a
modifyIOError IOError -> IOError
handle (IO a -> IO a) -> IO a -> IO a
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 [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
" for " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char] -> [[Char]] -> [Char]
forall a. [a] -> [[a]] -> [a]
intercalate [Char]
"/" [[Char]]
identifier)
IOError -> [Char] -> IOError
`ioeSetLocation` ([Char]
"Store." [Char] -> ShowS
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]
_ IORef (Map [Char] Box)
_ Maybe (AtomicLRU [Char] Box)
Nothing) [Char]
_ a
_ = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
cacheInsert (Store [Char]
_ IORef (Map [Char] Box)
_ (Just AtomicLRU [Char] Box
lru)) [Char]
key a
x =
[Char] -> Box -> AtomicLRU [Char] Box -> IO ()
forall key val. Ord key => key -> val -> AtomicLRU key val -> IO ()
Lru.insert [Char]
key (a -> Box
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]
_ IORef (Map [Char] Box)
_ Maybe (AtomicLRU [Char] Box)
Nothing) [Char]
_ = Result a -> IO (Result a)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Result a
forall a. Result a
NotFound
cacheLookup (Store [Char]
_ IORef (Map [Char] Box)
_ (Just AtomicLRU [Char] Box
lru)) [Char]
key = do
Maybe Box
res <- [Char] -> AtomicLRU [Char] Box -> IO (Maybe Box)
forall key val.
Ord key =>
key -> AtomicLRU key val -> IO (Maybe val)
Lru.lookup [Char]
key AtomicLRU [Char] Box
lru
Result a -> IO (Result a)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Result a -> IO (Result a)) -> Result a -> IO (Result a)
forall a b. (a -> b) -> a -> b
$ case Maybe Box
res of
Maybe Box
Nothing -> Result a
forall a. Result a
NotFound
Just (Box a
x) -> case a -> Maybe a
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast a
x of
Just a
x' -> a -> Result a
forall a. a -> Result a
Found a
x'
Maybe a
Nothing -> TypeRep -> TypeRep -> Result a
forall a. TypeRep -> TypeRep -> Result a
WrongType (a -> TypeRep
forall a. Typeable a => a -> TypeRep
typeOf (a
forall a. HasCallStack => a
undefined :: a)) (a -> TypeRep
forall a. Typeable a => a -> TypeRep
typeOf a
x)
cacheIsMember :: Store -> String -> IO Bool
cacheIsMember :: Store -> [Char] -> IO Bool
cacheIsMember (Store [Char]
_ IORef (Map [Char] Box)
_ Maybe (AtomicLRU [Char] Box)
Nothing) [Char]
_ = Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
cacheIsMember (Store [Char]
_ IORef (Map [Char] Box)
_ (Just AtomicLRU [Char] Box
lru)) [Char]
key = Maybe Box -> Bool
forall a. Maybe a -> Bool
isJust (Maybe Box -> Bool) -> IO (Maybe Box) -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> AtomicLRU [Char] Box -> IO (Maybe Box)
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]
_ IORef (Map [Char] Box)
_ Maybe (AtomicLRU [Char] Box)
Nothing) [Char]
_ = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
cacheDelete (Store [Char]
_ IORef (Map [Char] Box)
_ (Just AtomicLRU [Char] Box
lru)) [Char]
key = do
Maybe Box
_ <- [Char] -> AtomicLRU [Char] Box -> IO (Maybe Box)
forall key val.
Ord key =>
key -> AtomicLRU key val -> IO (Maybe val)
Lru.delete [Char]
key AtomicLRU [Char] Box
lru
() -> IO ()
forall a. a -> IO a
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 = Store -> [Char] -> ([Char] -> [Char] -> IO ()) -> [[Char]] -> IO ()
forall a.
Store -> [Char] -> ([Char] -> [Char] -> IO a) -> [[Char]] -> IO a
withStore Store
store [Char]
"set" (\[Char]
key [Char]
path -> do
Bool
first <- IORef (Map [Char] Box)
-> (Map [Char] Box -> (Map [Char] Box, Bool)) -> IO Bool
forall a b. IORef a -> (a -> (a, b)) -> IO b
IORef.atomicModifyIORef' (Store -> IORef (Map [Char] Box)
storeWriteAhead Store
store) ((Map [Char] Box -> (Map [Char] Box, Bool)) -> IO Bool)
-> (Map [Char] Box -> (Map [Char] Box, Bool)) -> IO Bool
forall a b. (a -> b) -> a -> b
$
\Map [Char] Box
wa -> case [Char] -> Map [Char] Box -> Maybe Box
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup [Char]
key Map [Char] Box
wa of
Maybe Box
Nothing -> ([Char] -> Box -> Map [Char] Box -> Map [Char] Box
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert [Char]
key (a -> Box
forall a. Typeable a => a -> Box
Box a
value) Map [Char] Box
wa, Bool
True)
Just Box
_ -> (Map [Char] Box
wa, Bool
False)
Store -> [Char] -> a -> IO ()
forall a. Typeable a => Store -> [Char] -> a -> IO ()
cacheInsert Store
store [Char]
key a
value
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
first (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
[Char] -> a -> IO ()
forall a. Binary a => [Char] -> a -> IO ()
encodeFile [Char]
path a
value
IORef (Map [Char] Box)
-> (Map [Char] Box -> (Map [Char] Box, ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
IORef.atomicModifyIORef' (Store -> IORef (Map [Char] Box)
storeWriteAhead Store
store) ((Map [Char] Box -> (Map [Char] Box, ())) -> IO ())
-> (Map [Char] Box -> (Map [Char] Box, ())) -> IO ()
forall a b. (a -> b) -> a -> b
$
\Map [Char] Box
wa -> ([Char] -> Map [Char] Box -> Map [Char] Box
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete [Char]
key Map [Char] Box
wa, ())
) [[Char]]
identifier
get :: forall a. (Binary a, Typeable a) => Store -> [String] -> IO (Result a)
get :: forall a.
(Binary a, Typeable a) =>
Store -> [[Char]] -> IO (Result a)
get Store
store = Store
-> [Char]
-> ([Char] -> [Char] -> IO (Result a))
-> [[Char]]
-> IO (Result a)
forall a.
Store -> [Char] -> ([Char] -> [Char] -> IO a) -> [[Char]] -> IO a
withStore Store
store [Char]
"get" (([Char] -> [Char] -> IO (Result a)) -> [[Char]] -> IO (Result a))
-> ([Char] -> [Char] -> IO (Result a)) -> [[Char]] -> IO (Result a)
forall a b. (a -> b) -> a -> b
$ \[Char]
key [Char]
path -> do
Map [Char] Box
writeAhead <- IORef (Map [Char] Box) -> IO (Map [Char] Box)
forall a. IORef a -> IO a
IORef.readIORef (IORef (Map [Char] Box) -> IO (Map [Char] Box))
-> IORef (Map [Char] Box) -> IO (Map [Char] Box)
forall a b. (a -> b) -> a -> b
$ Store -> IORef (Map [Char] Box)
storeWriteAhead Store
store
case [Char] -> Map [Char] Box -> Maybe Box
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup [Char]
key Map [Char] Box
writeAhead of
Just (Box a
x) -> case a -> Maybe a
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast a
x of
Just a
x' -> Result a -> IO (Result a)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Result a -> IO (Result a)) -> Result a -> IO (Result a)
forall a b. (a -> b) -> a -> b
$ a -> Result a
forall a. a -> Result a
Found a
x'
Maybe a
Nothing -> Result a -> IO (Result a)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Result a -> IO (Result a)) -> Result a -> IO (Result a)
forall a b. (a -> b) -> a -> b
$ TypeRep -> TypeRep -> Result a
forall a. TypeRep -> TypeRep -> Result a
WrongType (a -> TypeRep
forall a. Typeable a => a -> TypeRep
typeOf (a
forall a. HasCallStack => a
undefined :: a)) (a -> TypeRep
forall a. Typeable a => a -> TypeRep
typeOf a
x)
Maybe Box
Nothing -> do
Result a
ref <- Store -> [Char] -> IO (Result a)
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 Result a -> IO (Result a)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Result a
forall a. Result a
NotFound
else do
a
v <- [Char] -> IO a
forall {b}. Binary b => [Char] -> IO b
decodeClose [Char]
path
Store -> [Char] -> a -> IO ()
forall a. Typeable a => Store -> [Char] -> a -> IO ()
cacheInsert Store
store [Char]
key a
v
Result a -> IO (Result a)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Result a -> IO (Result a)) -> Result a -> IO (Result a)
forall a b. (a -> b) -> a -> b
$ a -> Result a
forall a. a -> Result a
Found a
v
Result a
s -> Result a -> IO (Result a)
forall a. a -> IO a
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 Int64 -> IO () -> IO ()
forall a b. a -> b -> b
`seq` Handle -> IO ()
hClose Handle
h
b -> IO b
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (b -> IO b) -> b -> IO b
forall a b. (a -> b) -> a -> b
$ ByteString -> b
forall a. Binary a => ByteString -> a
decode ByteString
lbs
isMember :: Store -> [String] -> IO Bool
isMember :: Store -> [[Char]] -> IO Bool
isMember Store
store = Store
-> [Char] -> ([Char] -> [Char] -> IO Bool) -> [[Char]] -> IO Bool
forall a.
Store -> [Char] -> ([Char] -> [Char] -> IO a) -> [[Char]] -> IO a
withStore Store
store [Char]
"isMember" (([Char] -> [Char] -> IO Bool) -> [[Char]] -> IO Bool)
-> ([Char] -> [Char] -> IO Bool) -> [[Char]] -> IO Bool
forall a b. (a -> b) -> a -> b
$ \[Char]
key [Char]
path -> do
Map [Char] Box
writeAhead <- IORef (Map [Char] Box) -> IO (Map [Char] Box)
forall a. IORef a -> IO a
IORef.readIORef (IORef (Map [Char] Box) -> IO (Map [Char] Box))
-> IORef (Map [Char] Box) -> IO (Map [Char] Box)
forall a b. (a -> b) -> a -> b
$ Store -> IORef (Map [Char] Box)
storeWriteAhead Store
store
if [Char] -> Map [Char] Box -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.member [Char]
key Map [Char] Box
writeAhead
then Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
else do
Bool
inCache <- Store -> [Char] -> IO Bool
cacheIsMember Store
store [Char]
key
if Bool
inCache then Bool -> IO Bool
forall a. a -> IO a
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 = Store -> [Char] -> ([Char] -> [Char] -> IO ()) -> [[Char]] -> IO ()
forall a.
Store -> [Char] -> ([Char] -> [Char] -> IO a) -> [[Char]] -> IO a
withStore Store
store [Char]
"delete" (([Char] -> [Char] -> IO ()) -> [[Char]] -> IO ())
-> ([Char] -> [Char] -> IO ()) -> [[Char]] -> IO ()
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 = (IO () -> (IOError -> IO ()) -> IO ()
forall a. IO a -> (IOError -> IO a) -> IO a
`catchIOError` \IOError
_ -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()) (IO () -> IO ()) -> ([Char] -> IO ()) -> [Char] -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> IO ()
removeFile
hash :: [String] -> String
hash :: [[Char]] -> [Char]
hash = Int -> [Char]
forall a. Show a => a -> [Char]
show (Int -> [Char]) -> ([[Char]] -> Int) -> [[Char]] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Int
forall a. Hashable a => a -> Int
DH.hash ([Char] -> Int) -> ([[Char]] -> [Char]) -> [[Char]] -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [[Char]] -> [Char]
forall a. [a] -> [[a]] -> [a]
intercalate [Char]
"/"