    --------------------------------------------------------------------------------
    -- | 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>"

    --------------------------------------------------------------------------------
    -- | 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 x :: a
    x) = a -> Maybe a
    forall a. a -> Maybe a
    Just a
    x
    toMaybe _         = 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 inMemory :: Bool
    inMemory directory :: 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 500

    --------------------------------------------------------------------------------
    withStore :: Store -> String -> (String -> FilePath -> IO a) -> [String] -> IO a
    withStore :: Store
    -> FilePath -> (FilePath -> FilePath -> IO a) -> [FilePath] -> IO a
    withStore store :: Store
    store loc :: FilePath
    loc run :: FilePath -> FilePath -> IO a
    run identifier :: [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 e :: IOError
    e = IOError
    e IOError -> FilePath -> IOError
    `ioeSetFileName` (FilePath
    path FilePath -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ " for " FilePath -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ FilePath -> [FilePath] -> FilePath
    forall a. [a] -> [[a]] -> [a]
    intercalate "/" [FilePath]
    identifier)
                     IOError -> FilePath -> IOError
    `ioeSetLocation` ("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 _ Nothing)    _   _     = () -> IO ()
    forall (m :: * -> *) a. Monad m => a -> m a
    return ()
    cacheInsert (Store _ (Just lru :: AtomicLRU FilePath Box
    lru)) key :: FilePath
    key x :: 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 _ Nothing)    _   = Result a -> IO (Result a)
    forall (m :: * -> *) a. Monad m => a -> m a
    return Result a
    forall a. Result a
    NotFound
    cacheLookup (Store _ (Just lru :: AtomicLRU FilePath Box
    lru)) key :: 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
            Nothing      -> Result a
    forall a. Result a
    NotFound
            Just (Box x :: a
    x) -> case a -> Maybe a
    forall a b. (Typeable a, Typeable b) => a -> Maybe b
    cast a
    x of
                Just x' :: a
    x' -> a -> Result a
    forall a. a -> Result a
    Found a
    x'
                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 _ Nothing)    _   = Bool -> IO Bool
    forall (m :: * -> *) a. Monad m => a -> m a
    return Bool
    False
    cacheIsMember (Store _ (Just lru :: AtomicLRU FilePath Box
    lru)) key :: 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 _ Nothing)    _   = () -> IO ()
    forall (m :: * -> *) a. Monad m => a -> m a
    return ()
    cacheDelete (Store _ (Just lru :: AtomicLRU FilePath Box
    lru)) key :: 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
    store identifier :: [FilePath]
    identifier value :: a
    value = Store
    -> FilePath
    -> (FilePath -> FilePath -> IO ())
    -> [FilePath]
    -> IO ()
    forall a.
    Store
    -> FilePath -> (FilePath -> FilePath -> IO a) -> [FilePath] -> IO a
    withStore Store
    store "set" (\key :: FilePath
    key path :: 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 = 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 "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
    $ \key :: FilePath
    key path :: 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
            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
            s :: 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 path :: 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 ()
    forall a b. a -> b -> b
    `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 = Store
    -> FilePath
    -> (FilePath -> FilePath -> IO Bool)
    -> [FilePath]
    -> IO Bool
    forall a.
    Store
    -> FilePath -> (FilePath -> FilePath -> IO a) -> [FilePath] -> IO a
    withStore Store
    store "isMember" ((FilePath -> FilePath -> IO Bool) -> [FilePath] -> IO Bool)
    -> (FilePath -> FilePath -> IO Bool) -> [FilePath] -> IO Bool
    forall a b. (a -> b) -> a -> b
    $ \key :: FilePath
    key path :: 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 = Store
    -> FilePath
    -> (FilePath -> FilePath -> IO ())
    -> [FilePath]
    -> IO ()
    forall a.
    Store
    -> FilePath -> (FilePath -> FilePath -> IO a) -> [FilePath] -> IO a
    withStore Store
    store "delete" ((FilePath -> FilePath -> IO ()) -> [FilePath] -> IO ())
    -> (FilePath -> FilePath -> IO ()) -> [FilePath] -> IO ()
    forall a b. (a -> b) -> a -> b
    $ \key :: FilePath
    key path :: 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` \_ -> () -> 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 "/"
      where
        toHex :: [a] -> FilePath
    toHex [] = ""
        toHex (x :: a
    x : xs :: [a]
    xs) | a
    x a -> a -> Bool
    forall a. Ord a => a -> a -> Bool
    < 16 = '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 x :: 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