--------------------------------------------------------------------------------
-- | A store for storing and retreiving items
{-# 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)


--------------------------------------------------------------------------------
-- | Simple wrapper type
data Box = forall a. Typeable a => Box a


--------------------------------------------------------------------------------
data Store = Store
    { -- | All items are stored on the filesystem
      Store -> [Char]
storeDirectory :: FilePath
    , -- | Optionally, items are also kept in-memory
      Store -> Maybe (AtomicLRU [Char] Box)
storeMap       :: Maybe (Lru.AtomicLRU FilePath Box)
    }


--------------------------------------------------------------------------------
instance Show Store where
    show :: Store -> [Char]
show Store
_ = [Char]
"<Store>"


--------------------------------------------------------------------------------
-- | Result of a store query
data Result a
    = Found a                    -- ^ Found, result
    | NotFound                   -- ^ Not found
    | WrongType TypeRep TypeRep  -- ^ Expected, true type
    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)


--------------------------------------------------------------------------------
-- | Convert result to 'Maybe'
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


--------------------------------------------------------------------------------
-- | Initialize the store
new :: Bool      -- ^ Use in-memory caching
    -> FilePath  -- ^ Directory to use for hard disk storage
    -> IO Store  -- ^ 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)

--------------------------------------------------------------------------------
-- | Auxiliary: add an item to the in-memory cache
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


--------------------------------------------------------------------------------
-- | Auxiliary: get an item from the in-memory cache
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


--------------------------------------------------------------------------------
-- | Auxiliary: delete an item from the in-memory cache
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 ()


--------------------------------------------------------------------------------
-- | Store an item
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


--------------------------------------------------------------------------------
-- | Load an item
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
    -- First check the in-memory map
    Result a
ref <- forall a. Typeable a => Store -> [Char] -> IO (Result a)
cacheLookup Store
store [Char]
key
    case Result a
ref of
        -- Not found in the map, try the filesystem
        Result a
NotFound -> do
            Bool
exists <- [Char] -> IO Bool
doesFileExist [Char]
path
            if Bool -> Bool
not Bool
exists
                -- Not found in the filesystem either
                then forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Result a
NotFound
                -- Found in the filesystem
                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
        -- Found in the in-memory map (or wrong type), just return
        Result a
s -> forall (m :: * -> *) a. Monad m => a -> m a
return Result a
s
  where
    -- 'decodeFile' from Data.Binary which closes the file ASAP
    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


--------------------------------------------------------------------------------
-- | Strict function
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 an item
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


--------------------------------------------------------------------------------
-- | Delete a file unless it doesn't exist...
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


--------------------------------------------------------------------------------
-- | Mostly meant for internal usage
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]
"/"