{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}

-- |
-- This module defines the remote caching mechanism of funflow which is used to
-- keep several funflow stores (possibly on different machines) in sync.
module Data.CAS.RemoteCache
  ( Cacher (..),
    PullResult (..),
    PushResult (..),
    AliasResult (..),
    NoCache (..),
    memoryCache,
    pullAsArchive,
    pushAsArchive,
  )
where

import qualified Codec.Archive.Tar as Tar
import Control.Concurrent.MVar
import Control.Monad.IO.Class (MonadIO, liftIO)
import Data.ByteString.Lazy (ByteString)
import Data.CAS.ContentHashable
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import Path

-- |
-- The result of a tentative pull from the remote cache
data PullResult a
  = PullOK a
  | NotInCache
  | PullError String
  deriving (PullResult a -> PullResult a -> Bool
(PullResult a -> PullResult a -> Bool)
-> (PullResult a -> PullResult a -> Bool) -> Eq (PullResult a)
forall a. Eq a => PullResult a -> PullResult a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PullResult a -> PullResult a -> Bool
$c/= :: forall a. Eq a => PullResult a -> PullResult a -> Bool
== :: PullResult a -> PullResult a -> Bool
$c== :: forall a. Eq a => PullResult a -> PullResult a -> Bool
Eq, Eq (PullResult a)
Eq (PullResult a)
-> (PullResult a -> PullResult a -> Ordering)
-> (PullResult a -> PullResult a -> Bool)
-> (PullResult a -> PullResult a -> Bool)
-> (PullResult a -> PullResult a -> Bool)
-> (PullResult a -> PullResult a -> Bool)
-> (PullResult a -> PullResult a -> PullResult a)
-> (PullResult a -> PullResult a -> PullResult a)
-> Ord (PullResult a)
PullResult a -> PullResult a -> Bool
PullResult a -> PullResult a -> Ordering
PullResult a -> PullResult a -> PullResult a
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall a. Ord a => Eq (PullResult a)
forall a. Ord a => PullResult a -> PullResult a -> Bool
forall a. Ord a => PullResult a -> PullResult a -> Ordering
forall a. Ord a => PullResult a -> PullResult a -> PullResult a
min :: PullResult a -> PullResult a -> PullResult a
$cmin :: forall a. Ord a => PullResult a -> PullResult a -> PullResult a
max :: PullResult a -> PullResult a -> PullResult a
$cmax :: forall a. Ord a => PullResult a -> PullResult a -> PullResult a
>= :: PullResult a -> PullResult a -> Bool
$c>= :: forall a. Ord a => PullResult a -> PullResult a -> Bool
> :: PullResult a -> PullResult a -> Bool
$c> :: forall a. Ord a => PullResult a -> PullResult a -> Bool
<= :: PullResult a -> PullResult a -> Bool
$c<= :: forall a. Ord a => PullResult a -> PullResult a -> Bool
< :: PullResult a -> PullResult a -> Bool
$c< :: forall a. Ord a => PullResult a -> PullResult a -> Bool
compare :: PullResult a -> PullResult a -> Ordering
$ccompare :: forall a. Ord a => PullResult a -> PullResult a -> Ordering
$cp1Ord :: forall a. Ord a => Eq (PullResult a)
Ord, Int -> PullResult a -> ShowS
[PullResult a] -> ShowS
PullResult a -> String
(Int -> PullResult a -> ShowS)
-> (PullResult a -> String)
-> ([PullResult a] -> ShowS)
-> Show (PullResult a)
forall a. Show a => Int -> PullResult a -> ShowS
forall a. Show a => [PullResult a] -> ShowS
forall a. Show a => PullResult a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PullResult a] -> ShowS
$cshowList :: forall a. Show a => [PullResult a] -> ShowS
show :: PullResult a -> String
$cshow :: forall a. Show a => PullResult a -> String
showsPrec :: Int -> PullResult a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> PullResult a -> ShowS
Show)

-- |
-- The result of a tentative push to the remote cache
data PushResult
  = PushOK
  | PushError String
  deriving (PushResult -> PushResult -> Bool
(PushResult -> PushResult -> Bool)
-> (PushResult -> PushResult -> Bool) -> Eq PushResult
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PushResult -> PushResult -> Bool
$c/= :: PushResult -> PushResult -> Bool
== :: PushResult -> PushResult -> Bool
$c== :: PushResult -> PushResult -> Bool
Eq, Eq PushResult
Eq PushResult
-> (PushResult -> PushResult -> Ordering)
-> (PushResult -> PushResult -> Bool)
-> (PushResult -> PushResult -> Bool)
-> (PushResult -> PushResult -> Bool)
-> (PushResult -> PushResult -> Bool)
-> (PushResult -> PushResult -> PushResult)
-> (PushResult -> PushResult -> PushResult)
-> Ord PushResult
PushResult -> PushResult -> Bool
PushResult -> PushResult -> Ordering
PushResult -> PushResult -> PushResult
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: PushResult -> PushResult -> PushResult
$cmin :: PushResult -> PushResult -> PushResult
max :: PushResult -> PushResult -> PushResult
$cmax :: PushResult -> PushResult -> PushResult
>= :: PushResult -> PushResult -> Bool
$c>= :: PushResult -> PushResult -> Bool
> :: PushResult -> PushResult -> Bool
$c> :: PushResult -> PushResult -> Bool
<= :: PushResult -> PushResult -> Bool
$c<= :: PushResult -> PushResult -> Bool
< :: PushResult -> PushResult -> Bool
$c< :: PushResult -> PushResult -> Bool
compare :: PushResult -> PushResult -> Ordering
$ccompare :: PushResult -> PushResult -> Ordering
$cp1Ord :: Eq PushResult
Ord, Int -> PushResult -> ShowS
[PushResult] -> ShowS
PushResult -> String
(Int -> PushResult -> ShowS)
-> (PushResult -> String)
-> ([PushResult] -> ShowS)
-> Show PushResult
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PushResult] -> ShowS
$cshowList :: [PushResult] -> ShowS
show :: PushResult -> String
$cshow :: PushResult -> String
showsPrec :: Int -> PushResult -> ShowS
$cshowsPrec :: Int -> PushResult -> ShowS
Show)

data AliasResult
  = AliasOK
  | TargetNotInCache
  | AliasError String

-- |
-- A simple mechanism for remote-caching.
--
-- Provides a way to push a path to the cache and pull it back.
--
-- No assumption is made on the availability of a store path. In particular,
-- pushing a path to the cache doesn't mean that we can pull it back.
class Monad m => Cacher m a where
  push ::
    a ->
    -- | "Primary" key: hash of the content
    ContentHash ->
    -- | "Secondary" key: hash of the dependencies
    Maybe ContentHash ->
    -- | Path to the content
    Path Abs Dir ->
    m PushResult
  pull :: a -> ContentHash -> Path Abs Dir -> m (PullResult ())

-- |
-- Push the path as an archive to the remote cache
pushAsArchive ::
  MonadIO m =>
  -- | How to create the aliases
  (ContentHash -> ContentHash -> m (Either String ())) ->
  -- | How to push the content
  (ContentHash -> ByteString -> m PushResult) ->
  -- | Primary key
  ContentHash ->
  -- | Secondary key
  Maybe ContentHash ->
  Path Abs Dir ->
  m PushResult
pushAsArchive :: (ContentHash -> ContentHash -> m (Either String ()))
-> (ContentHash -> ByteString -> m PushResult)
-> ContentHash
-> Maybe ContentHash
-> Path Abs Dir
-> m PushResult
pushAsArchive ContentHash -> ContentHash -> m (Either String ())
alias ContentHash -> ByteString -> m PushResult
pushArchive ContentHash
primaryKey Maybe ContentHash
mSecondaryKey Path Abs Dir
path = do
  ByteString
archive <- IO ByteString -> m ByteString
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ByteString -> m ByteString) -> IO ByteString -> m ByteString
forall a b. (a -> b) -> a -> b
$ [Entry] -> ByteString
Tar.write ([Entry] -> ByteString) -> IO [Entry] -> IO ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> [String] -> IO [Entry]
Tar.pack (Path Abs Dir -> String
forall b t. Path b t -> String
toFilePath Path Abs Dir
path) [String
"."]
  ContentHash -> ByteString -> m PushResult
pushArchive ContentHash
primaryKey ByteString
archive m PushResult -> (PushResult -> m PushResult) -> m PushResult
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    PushError String
e -> PushResult -> m PushResult
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PushResult -> m PushResult) -> PushResult -> m PushResult
forall a b. (a -> b) -> a -> b
$ String -> PushResult
PushError String
e
    PushResult
res ->
      case Maybe ContentHash
mSecondaryKey of
        Just ContentHash
secondaryKey ->
          ContentHash -> ContentHash -> m (Either String ())
alias ContentHash
primaryKey ContentHash
secondaryKey m (Either String ())
-> (Either String () -> m PushResult) -> m PushResult
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Left String
err -> PushResult -> m PushResult
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PushResult -> m PushResult) -> PushResult -> m PushResult
forall a b. (a -> b) -> a -> b
$ String -> PushResult
PushError String
err
            Right () -> PushResult -> m PushResult
forall (f :: * -> *) a. Applicative f => a -> f a
pure PushResult
res
        Maybe ContentHash
Nothing -> PushResult -> m PushResult
forall (f :: * -> *) a. Applicative f => a -> f a
pure PushResult
res

pullAsArchive ::
  MonadIO m =>
  (ContentHash -> m (PullResult ByteString)) ->
  ContentHash ->
  Path Abs Dir ->
  m (PullResult ())
pullAsArchive :: (ContentHash -> m (PullResult ByteString))
-> ContentHash -> Path Abs Dir -> m (PullResult ())
pullAsArchive ContentHash -> m (PullResult ByteString)
pullArchive ContentHash
hash Path Abs Dir
path =
  ContentHash -> m (PullResult ByteString)
pullArchive ContentHash
hash m (PullResult ByteString)
-> (PullResult ByteString -> m (PullResult ()))
-> m (PullResult ())
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    PullOK ByteString
archive -> do
      IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ String -> Entries FormatError -> IO ()
forall e. Exception e => String -> Entries e -> IO ()
Tar.unpack (Path Abs Dir -> String
forall b t. Path b t -> String
toFilePath Path Abs Dir
path) (Entries FormatError -> IO ()) -> Entries FormatError -> IO ()
forall a b. (a -> b) -> a -> b
$ ByteString -> Entries FormatError
Tar.read ByteString
archive
      PullResult () -> m (PullResult ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PullResult () -> m (PullResult ()))
-> PullResult () -> m (PullResult ())
forall a b. (a -> b) -> a -> b
$ () -> PullResult ()
forall a. a -> PullResult a
PullOK ()
    PullResult ByteString
NotInCache -> PullResult () -> m (PullResult ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure PullResult ()
forall a. PullResult a
NotInCache
    PullError String
e -> PullResult () -> m (PullResult ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PullResult () -> m (PullResult ()))
-> PullResult () -> m (PullResult ())
forall a b. (a -> b) -> a -> b
$ String -> PullResult ()
forall a. String -> PullResult a
PullError String
e

-- |
-- A dummy remote cache implementation which does nothing
data NoCache = NoCache

instance Monad m => Cacher m NoCache where
  pull :: NoCache -> ContentHash -> Path Abs Dir -> m (PullResult ())
pull NoCache
_ ContentHash
_ Path Abs Dir
_ = PullResult () -> m (PullResult ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure PullResult ()
forall a. PullResult a
NotInCache
  push :: NoCache
-> ContentHash -> Maybe ContentHash -> Path Abs Dir -> m PushResult
push NoCache
_ ContentHash
_ Maybe ContentHash
_ Path Abs Dir
_ = PushResult -> m PushResult
forall (f :: * -> *) a. Applicative f => a -> f a
pure PushResult
PushOK

-- |
-- An in-memory cache, for testing purposes
data MemoryCache = MemoryCache (MVar (Map ContentHash ByteString))

instance MonadIO m => Cacher m MemoryCache where
  pull :: MemoryCache -> ContentHash -> Path Abs Dir -> m (PullResult ())
pull (MemoryCache MVar (Map ContentHash ByteString)
cacheVar) = (ContentHash -> m (PullResult ByteString))
-> ContentHash -> Path Abs Dir -> m (PullResult ())
forall (m :: * -> *).
MonadIO m =>
(ContentHash -> m (PullResult ByteString))
-> ContentHash -> Path Abs Dir -> m (PullResult ())
pullAsArchive ((ContentHash -> m (PullResult ByteString))
 -> ContentHash -> Path Abs Dir -> m (PullResult ()))
-> (ContentHash -> m (PullResult ByteString))
-> ContentHash
-> Path Abs Dir
-> m (PullResult ())
forall a b. (a -> b) -> a -> b
$ \ContentHash
hash -> do
    Map ContentHash ByteString
cacheMap <- IO (Map ContentHash ByteString) -> m (Map ContentHash ByteString)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Map ContentHash ByteString) -> m (Map ContentHash ByteString))
-> IO (Map ContentHash ByteString)
-> m (Map ContentHash ByteString)
forall a b. (a -> b) -> a -> b
$ MVar (Map ContentHash ByteString)
-> IO (Map ContentHash ByteString)
forall a. MVar a -> IO a
readMVar MVar (Map ContentHash ByteString)
cacheVar
    case ContentHash -> Map ContentHash ByteString -> Maybe ByteString
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ContentHash
hash Map ContentHash ByteString
cacheMap of
      Maybe ByteString
Nothing -> PullResult ByteString -> m (PullResult ByteString)
forall (f :: * -> *) a. Applicative f => a -> f a
pure PullResult ByteString
forall a. PullResult a
NotInCache
      Just ByteString
x -> PullResult ByteString -> m (PullResult ByteString)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ByteString -> PullResult ByteString
forall a. a -> PullResult a
PullOK ByteString
x)
  push :: MemoryCache
-> ContentHash -> Maybe ContentHash -> Path Abs Dir -> m PushResult
push (MemoryCache MVar (Map ContentHash ByteString)
cacheVar) = (ContentHash -> ContentHash -> m (Either String ()))
-> (ContentHash -> ByteString -> m PushResult)
-> ContentHash
-> Maybe ContentHash
-> Path Abs Dir
-> m PushResult
forall (m :: * -> *).
MonadIO m =>
(ContentHash -> ContentHash -> m (Either String ()))
-> (ContentHash -> ByteString -> m PushResult)
-> ContentHash
-> Maybe ContentHash
-> Path Abs Dir
-> m PushResult
pushAsArchive ContentHash -> ContentHash -> m (Either String ())
forall (m :: * -> *) a.
MonadIO m =>
ContentHash -> ContentHash -> m (Either a ())
alias ((ContentHash -> ByteString -> m PushResult)
 -> ContentHash
 -> Maybe ContentHash
 -> Path Abs Dir
 -> m PushResult)
-> (ContentHash -> ByteString -> m PushResult)
-> ContentHash
-> Maybe ContentHash
-> Path Abs Dir
-> m PushResult
forall a b. (a -> b) -> a -> b
$ \ContentHash
hash ByteString
content -> do
    IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$
      MVar (Map ContentHash ByteString)
-> (Map ContentHash ByteString -> IO (Map ContentHash ByteString))
-> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_
        MVar (Map ContentHash ByteString)
cacheVar
        (\Map ContentHash ByteString
cacheMap -> Map ContentHash ByteString -> IO (Map ContentHash ByteString)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Map ContentHash ByteString -> IO (Map ContentHash ByteString))
-> Map ContentHash ByteString -> IO (Map ContentHash ByteString)
forall a b. (a -> b) -> a -> b
$ ContentHash
-> ByteString
-> Map ContentHash ByteString
-> Map ContentHash ByteString
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert ContentHash
hash ByteString
content Map ContentHash ByteString
cacheMap)
    PushResult -> m PushResult
forall (f :: * -> *) a. Applicative f => a -> f a
pure PushResult
PushOK
    where
      alias :: ContentHash -> ContentHash -> m (Either a ())
alias ContentHash
from ContentHash
to =
        IO (Either a ()) -> m (Either a ())
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either a ()) -> m (Either a ()))
-> IO (Either a ()) -> m (Either a ())
forall a b. (a -> b) -> a -> b
$
          () -> Either a ()
forall a b. b -> Either a b
Right
            (() -> Either a ()) -> IO () -> IO (Either a ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MVar (Map ContentHash ByteString)
-> (Map ContentHash ByteString -> IO (Map ContentHash ByteString))
-> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_
              MVar (Map ContentHash ByteString)
cacheVar
              (\Map ContentHash ByteString
cacheMap -> Map ContentHash ByteString -> IO (Map ContentHash ByteString)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Map ContentHash ByteString -> IO (Map ContentHash ByteString))
-> Map ContentHash ByteString -> IO (Map ContentHash ByteString)
forall a b. (a -> b) -> a -> b
$ ContentHash
-> ByteString
-> Map ContentHash ByteString
-> Map ContentHash ByteString
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert ContentHash
to (Map ContentHash ByteString
cacheMap Map ContentHash ByteString -> ContentHash -> ByteString
forall k a. Ord k => Map k a -> k -> a
Map.! ContentHash
from) Map ContentHash ByteString
cacheMap)

memoryCache :: MonadIO m => m MemoryCache
memoryCache :: m MemoryCache
memoryCache = IO MemoryCache -> m MemoryCache
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO MemoryCache -> m MemoryCache)
-> IO MemoryCache -> m MemoryCache
forall a b. (a -> b) -> a -> b
$ MVar (Map ContentHash ByteString) -> MemoryCache
MemoryCache (MVar (Map ContentHash ByteString) -> MemoryCache)
-> IO (MVar (Map ContentHash ByteString)) -> IO MemoryCache
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map ContentHash ByteString
-> IO (MVar (Map ContentHash ByteString))
forall a. a -> IO (MVar a)
newMVar Map ContentHash ByteString
forall a. Monoid a => a
mempty

-- |
-- If 'a' is a 'Cacher' then 'Maybe a' is a cacher such that 'Just x' behavies
-- like 'x' and 'Nothing' doesn't cache anything
instance Cacher m a => Cacher m (Maybe a) where
  pull :: Maybe a -> ContentHash -> Path Abs Dir -> m (PullResult ())
pull (Just a
x) = a -> ContentHash -> Path Abs Dir -> m (PullResult ())
forall (m :: * -> *) a.
Cacher m a =>
a -> ContentHash -> Path Abs Dir -> m (PullResult ())
pull a
x
  pull Maybe a
Nothing = NoCache -> ContentHash -> Path Abs Dir -> m (PullResult ())
forall (m :: * -> *) a.
Cacher m a =>
a -> ContentHash -> Path Abs Dir -> m (PullResult ())
pull NoCache
NoCache

  push :: Maybe a
-> ContentHash -> Maybe ContentHash -> Path Abs Dir -> m PushResult
push (Just a
x) = a
-> ContentHash -> Maybe ContentHash -> Path Abs Dir -> m PushResult
forall (m :: * -> *) a.
Cacher m a =>
a
-> ContentHash -> Maybe ContentHash -> Path Abs Dir -> m PushResult
push a
x
  push Maybe a
Nothing = NoCache
-> ContentHash -> Maybe ContentHash -> Path Abs Dir -> m PushResult
forall (m :: * -> *) a.
Cacher m a =>
a
-> ContentHash -> Maybe ContentHash -> Path Abs Dir -> m PushResult
push NoCache
NoCache