--------------------------------------------------------------------------------
-- | 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 -> FilePath
storeDirectory :: FilePath
    , -- | Optionally, items are also kept in-memory
      Store -> Maybe (AtomicLRU FilePath Box)
storeMap       :: Maybe (Lru.AtomicLRU FilePath Box)
    }


--------------------------------------------------------------------------------
instance Show Store where
    show :: Store -> FilePath
show Store
_ = FilePath
"<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
[Result a] -> ShowS
Result a -> FilePath
(Int -> Result a -> ShowS)
-> (Result a -> FilePath)
-> ([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 -> FilePath
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [Result a] -> ShowS
$cshowList :: forall a. Show a => [Result a] -> ShowS
show :: Result a -> FilePath
$cshow :: forall a. Show a => Result a -> FilePath
showsPrec :: Int -> Result a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> 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
/= :: 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 :: 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


--------------------------------------------------------------------------------
-- | Initialize the store
new :: Bool      -- ^ Use in-memory caching
    -> FilePath  -- ^ Directory to use for hard disk storage
    -> IO Store  -- ^ Store
new :: Bool -> FilePath -> IO Store
new Bool
inMemory FilePath
directory = do
    Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
True FilePath
directory
    Maybe (AtomicLRU FilePath Box)
ref <- if Bool
inMemory then AtomicLRU FilePath Box -> Maybe (AtomicLRU FilePath Box)
forall a. a -> Maybe a
Just (AtomicLRU FilePath Box -> Maybe (AtomicLRU FilePath Box))
-> IO (AtomicLRU FilePath Box)
-> IO (Maybe (AtomicLRU FilePath Box))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Integer -> IO (AtomicLRU FilePath Box)
forall key val. Ord key => Maybe Integer -> IO (AtomicLRU key val)
Lru.newAtomicLRU Maybe Integer
csize else Maybe (AtomicLRU FilePath Box)
-> IO (Maybe (AtomicLRU FilePath Box))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (AtomicLRU FilePath Box)
forall a. Maybe a
Nothing
    Store -> IO Store
forall (m :: * -> *) a. Monad m => a -> m a
return Store :: FilePath -> Maybe (AtomicLRU FilePath Box) -> Store
Store
        { storeDirectory :: FilePath
storeDirectory = FilePath
directory
        , storeMap :: Maybe (AtomicLRU FilePath Box)
storeMap       = Maybe (AtomicLRU FilePath 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 :: Store
-> FilePath -> (FilePath -> FilePath -> IO a) -> [FilePath] -> IO a
withStore Store
store FilePath
loc FilePath -> FilePath -> IO a
run [FilePath]
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
$ FilePath -> FilePath -> IO a
run FilePath
key FilePath
path
  where
    key :: FilePath
key = [FilePath] -> FilePath
hash [FilePath]
identifier
    path :: FilePath
path = Store -> FilePath
storeDirectory Store
store FilePath -> ShowS
</> FilePath
key
    handle :: IOError -> IOError
handle IOError
e = IOError
e IOError -> FilePath -> IOError
`ioeSetFileName` (FilePath
path FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
" for " FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath -> [FilePath] -> FilePath
forall a. [a] -> [[a]] -> [a]
intercalate FilePath
"/" [FilePath]
identifier)
                 IOError -> FilePath -> IOError
`ioeSetLocation` (FilePath
"Store." FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
loc)

--------------------------------------------------------------------------------
-- | Auxiliary: add an item to the in-memory cache
cacheInsert :: Typeable a => Store -> String -> a -> IO ()
cacheInsert :: Store -> FilePath -> a -> IO ()
cacheInsert (Store FilePath
_ Maybe (AtomicLRU FilePath Box)
Nothing)    FilePath
_   a
_     = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
cacheInsert (Store FilePath
_ (Just AtomicLRU FilePath Box
lru)) FilePath
key a
x =
    FilePath -> Box -> AtomicLRU FilePath Box -> IO ()
forall key val. Ord key => key -> val -> AtomicLRU key val -> IO ()
Lru.insert FilePath
key (a -> Box
forall a. Typeable a => a -> Box
Box a
x) AtomicLRU FilePath Box
lru


--------------------------------------------------------------------------------
-- | Auxiliary: get an item from the in-memory cache
cacheLookup :: forall a. Typeable a => Store -> String -> IO (Result a)
cacheLookup :: Store -> FilePath -> IO (Result a)
cacheLookup (Store FilePath
_ Maybe (AtomicLRU FilePath Box)
Nothing)    FilePath
_   = Result a -> IO (Result a)
forall (m :: * -> *) a. Monad m => a -> m a
return Result a
forall a. Result a
NotFound
cacheLookup (Store FilePath
_ (Just AtomicLRU FilePath Box
lru)) FilePath
key = do
    Maybe Box
res <- FilePath -> AtomicLRU FilePath Box -> IO (Maybe Box)
forall key val.
Ord key =>
key -> AtomicLRU key val -> IO (Maybe val)
Lru.lookup FilePath
key AtomicLRU FilePath Box
lru
    Result a -> IO (Result 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 -> FilePath -> IO Bool
cacheIsMember (Store FilePath
_ Maybe (AtomicLRU FilePath Box)
Nothing)    FilePath
_   = Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
cacheIsMember (Store FilePath
_ (Just AtomicLRU FilePath Box
lru)) FilePath
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
<$> FilePath -> AtomicLRU FilePath Box -> IO (Maybe Box)
forall key val.
Ord key =>
key -> AtomicLRU key val -> IO (Maybe val)
Lru.lookup FilePath
key AtomicLRU FilePath Box
lru


--------------------------------------------------------------------------------
-- | Auxiliary: delete an item from the in-memory cache
cacheDelete :: Store -> String -> IO ()
cacheDelete :: Store -> FilePath -> IO ()
cacheDelete (Store FilePath
_ Maybe (AtomicLRU FilePath Box)
Nothing)    FilePath
_   = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
cacheDelete (Store FilePath
_ (Just AtomicLRU FilePath Box
lru)) FilePath
key = do
    Maybe Box
_ <- FilePath -> AtomicLRU FilePath Box -> IO (Maybe Box)
forall key val.
Ord key =>
key -> AtomicLRU key val -> IO (Maybe val)
Lru.delete FilePath
key AtomicLRU FilePath Box
lru
    () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()


--------------------------------------------------------------------------------
-- | Store an item
set :: (Binary a, Typeable a) => Store -> [String] -> a -> IO ()
set :: Store -> [FilePath] -> a -> IO ()
set Store
store [FilePath]
identifier a
value = Store
-> FilePath
-> (FilePath -> FilePath -> IO ())
-> [FilePath]
-> IO ()
forall a.
Store
-> FilePath -> (FilePath -> FilePath -> IO a) -> [FilePath] -> IO a
withStore Store
store FilePath
"set" (\FilePath
key FilePath
path -> do
    FilePath -> a -> IO ()
forall a. Binary a => FilePath -> a -> IO ()
encodeFile FilePath
path a
value
    Store -> FilePath -> a -> IO ()
forall a. Typeable a => Store -> FilePath -> a -> IO ()
cacheInsert Store
store FilePath
key a
value
  ) [FilePath]
identifier


--------------------------------------------------------------------------------
-- | Load an item
get :: (Binary a, Typeable a) => Store -> [String] -> IO (Result a)
get :: Store -> [FilePath] -> IO (Result a)
get Store
store = Store
-> FilePath
-> (FilePath -> FilePath -> IO (Result a))
-> [FilePath]
-> IO (Result a)
forall a.
Store
-> FilePath -> (FilePath -> FilePath -> IO a) -> [FilePath] -> IO a
withStore Store
store FilePath
"get" ((FilePath -> FilePath -> IO (Result a))
 -> [FilePath] -> IO (Result a))
-> (FilePath -> FilePath -> IO (Result a))
-> [FilePath]
-> IO (Result a)
forall a b. (a -> b) -> a -> b
$ \FilePath
key FilePath
path -> do
    -- First check the in-memory map
    Result a
ref <- Store -> FilePath -> IO (Result a)
forall a. Typeable a => Store -> FilePath -> IO (Result a)
cacheLookup Store
store FilePath
key
    case Result a
ref of
        -- Not found in the map, try the filesystem
        Result a
NotFound -> do
            Bool
exists <- FilePath -> IO Bool
doesFileExist FilePath
path
            if Bool -> Bool
not Bool
exists
                -- Not found in the filesystem either
                then Result a -> IO (Result a)
forall (m :: * -> *) a. Monad m => a -> m a
return Result a
forall a. Result a
NotFound
                -- Found in the filesystem
                else do
                    a
v <- FilePath -> IO a
forall b. Binary b => FilePath -> IO b
decodeClose FilePath
path
                    Store -> FilePath -> a -> IO ()
forall a. Typeable a => Store -> FilePath -> a -> IO ()
cacheInsert Store
store FilePath
key a
v
                    Result a -> IO (Result 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
        -- Found in the in-memory map (or wrong type), just return
        Result a
s -> Result a -> IO (Result a)
forall (m :: * -> *) a. Monad m => a -> m a
return Result a
s
  where
    -- 'decodeFile' from Data.Binary which closes the file ASAP
    decodeClose :: FilePath -> IO b
decodeClose FilePath
path = do
        Handle
h   <- FilePath -> IOMode -> IO Handle
openFile FilePath
path IOMode
ReadMode
        ByteString
lbs <- Handle -> IO ByteString
BL.hGetContents Handle
h
        ByteString -> Int64
BL.length ByteString
lbs Int64 -> IO () -> IO ()
`seq` Handle -> IO ()
hClose Handle
h
        b -> IO b
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


--------------------------------------------------------------------------------
-- | Strict function
isMember :: Store -> [String] -> IO Bool
isMember :: Store -> [FilePath] -> IO Bool
isMember Store
store = Store
-> FilePath
-> (FilePath -> FilePath -> IO Bool)
-> [FilePath]
-> IO Bool
forall a.
Store
-> FilePath -> (FilePath -> FilePath -> IO a) -> [FilePath] -> IO a
withStore Store
store FilePath
"isMember" ((FilePath -> FilePath -> IO Bool) -> [FilePath] -> IO Bool)
-> (FilePath -> FilePath -> IO Bool) -> [FilePath] -> IO Bool
forall a b. (a -> b) -> a -> b
$ \FilePath
key FilePath
path -> do
    Bool
inCache <- Store -> FilePath -> IO Bool
cacheIsMember Store
store FilePath
key
    if Bool
inCache then Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True else FilePath -> IO Bool
doesFileExist FilePath
path


--------------------------------------------------------------------------------
-- | Delete an item
delete :: Store -> [String] -> IO ()
delete :: Store -> [FilePath] -> IO ()
delete Store
store = Store
-> FilePath
-> (FilePath -> FilePath -> IO ())
-> [FilePath]
-> IO ()
forall a.
Store
-> FilePath -> (FilePath -> FilePath -> IO a) -> [FilePath] -> IO a
withStore Store
store FilePath
"delete" ((FilePath -> FilePath -> IO ()) -> [FilePath] -> IO ())
-> (FilePath -> FilePath -> IO ()) -> [FilePath] -> IO ()
forall a b. (a -> b) -> a -> b
$ \FilePath
key FilePath
path -> do
    Store -> FilePath -> IO ()
cacheDelete Store
store FilePath
key
    FilePath -> IO ()
deleteFile FilePath
path


--------------------------------------------------------------------------------
-- | Delete a file unless it doesn't exist...
deleteFile :: FilePath -> IO ()
deleteFile :: FilePath -> IO ()
deleteFile = (IO () -> (IOError -> IO ()) -> IO ()
forall a. IO a -> (IOError -> IO a) -> IO a
`catchIOError` \IOError
_ -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()) (IO () -> IO ()) -> (FilePath -> IO ()) -> FilePath -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> IO ()
removeFile


--------------------------------------------------------------------------------
-- | Mostly meant for internal usage
hash :: [String] -> String
hash :: [FilePath] -> FilePath
hash = Int -> FilePath
forall a. Show a => a -> FilePath
show (Int -> FilePath) -> ([FilePath] -> Int) -> [FilePath] -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Int
forall a. Hashable a => a -> Int
DH.hash (FilePath -> Int) -> ([FilePath] -> FilePath) -> [FilePath] -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> [FilePath] -> FilePath
forall a. [a] -> [[a]] -> [a]
intercalate FilePath
"/"