--------------------------------------------------------------------------------
-- | 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.ByteArray       as BA
import qualified Crypto.Hash          as CH
import           Data.Binary          (Binary, decode, encodeFile)
import qualified Data.ByteString      as B
import qualified Data.ByteString.Lazy as BL
import qualified Data.Cache.LRU.IO    as Lru
import           Data.List            (intercalate)
import           Data.Maybe           (isJust)
import qualified Data.Text            as T
import qualified Data.Text.Encoding   as T
import           Data.Typeable        (TypeRep, Typeable, cast, typeOf)
import           Numeric              (showHex)
import           System.Directory     (createDirectoryIfMissing)
import           System.Directory     (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 = [Word8] -> FilePath
forall a. (Integral a, Show a) => [a] -> FilePath
toHex ([Word8] -> FilePath)
-> ([FilePath] -> [Word8]) -> [FilePath] -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [Word8]
B.unpack (ByteString -> [Word8])
-> ([FilePath] -> ByteString) -> [FilePath] -> [Word8]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
hashMD5 (ByteString -> ByteString)
-> ([FilePath] -> ByteString) -> [FilePath] -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
T.encodeUtf8 (Text -> ByteString)
-> ([FilePath] -> Text) -> [FilePath] -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Text
T.pack (FilePath -> Text)
-> ([FilePath] -> FilePath) -> [FilePath] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> [FilePath] -> FilePath
forall a. [a] -> [[a]] -> [a]
intercalate FilePath
"/"
  where
    toHex :: [a] -> FilePath
toHex [] = FilePath
""
    toHex (a
x : [a]
xs) | a
x a -> a -> Bool
forall a. Ord a => a -> a -> Bool
< a
16 = Char
'0' Char -> ShowS
forall a. a -> [a] -> [a]
: a -> ShowS
forall a. (Integral a, Show a) => a -> ShowS
showHex a
x ([a] -> FilePath
toHex [a]
xs)
                   | Bool
otherwise = a -> ShowS
forall a. (Integral a, Show a) => a -> ShowS
showHex a
x ([a] -> FilePath
toHex [a]
xs)


--------------------------------------------------------------------------------
-- | Hash by MD5
hashMD5 :: B.ByteString -> B.ByteString
hashMD5 :: ByteString -> ByteString
hashMD5 ByteString
x =
  let
    digest :: CH.Digest CH.MD5
    digest :: Digest MD5
digest = ByteString -> Digest MD5
forall ba a.
(ByteArrayAccess ba, HashAlgorithm a) =>
ba -> Digest a
CH.hash ByteString
x
    bytes :: B.ByteString
    bytes :: ByteString
bytes = Digest MD5 -> ByteString
forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
BA.convert Digest MD5
digest
  in
    ByteString
bytes