summaryrefslogtreecommitdiff
path: root/src/Control/Funflow/RemoteCache.hs
blob: 803c466d323ad5d85120c5f9726342b66625531b (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
{-# 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 Control.Funflow.RemoteCache
  ( Cacher(..)
  , PullResult(..), PushResult(..), AliasResult(..)
  , NoCache(..), memoryCache
  , pullAsArchive, pushAsArchive
  ) where

import qualified Codec.Archive.Tar               as Tar
import           Control.Concurrent.MVar
import           Control.Funflow.ContentHashable
import           Control.Monad.IO.Class          (MonadIO, liftIO)
import           Data.ByteString.Lazy            (ByteString)
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 (Eq, Ord, Show)

-- |
-- The result of a tentative push to the remote cache
data PushResult
  = PushOK
  | PushError String
  deriving (Eq, Ord, 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
    -> ContentHash -- ^ "Primary" key: hash of the content
    -> Maybe ContentHash -- ^ "Secondary" key: hash of the dependencies
    -> Path Abs Dir -- ^ Path to the content
    -> m PushResult
  pull :: a -> ContentHash -> Path Abs Dir -> m (PullResult ())

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

pullAsArchive ::
     MonadIO m
  => (ContentHash -> m (PullResult ByteString))
  -> ContentHash
  -> Path Abs Dir
  -> m (PullResult ())
pullAsArchive pullArchive hash path =
  pullArchive hash >>= \case
    PullOK archive -> do
      liftIO $ Tar.unpack (toFilePath path) $ Tar.read archive
      pure $ PullOK ()
    NotInCache -> pure NotInCache
    PullError e -> pure $ PullError e

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

instance Monad m => Cacher m NoCache where
  pull _ _ _ = pure NotInCache
  push _ _ _ _ = pure PushOK

-- |
-- An in-memory cache, for testing purposes
data MemoryCache = MemoryCache (MVar (Map ContentHash ByteString))
instance MonadIO m => Cacher m MemoryCache where
  pull (MemoryCache cacheVar) = pullAsArchive $ \hash -> do
    cacheMap <- liftIO $ readMVar cacheVar
    case Map.lookup hash cacheMap of
      Nothing -> pure NotInCache
      Just x  -> pure (PullOK x)
  push (MemoryCache cacheVar) = pushAsArchive alias $ \hash content -> do
    liftIO $ modifyMVar_
      cacheVar
      (\cacheMap -> pure $ Map.insert hash content cacheMap)
    pure PushOK
    where
      alias from to = liftIO $ Right <$> modifyMVar_ cacheVar
        (\cacheMap -> pure $ Map.insert to (cacheMap Map.! from) cacheMap)

memoryCache :: MonadIO m => m MemoryCache
memoryCache = liftIO $ MemoryCache <$> newMVar 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 (Just x) = pull x
  pull Nothing  = pull NoCache

  push (Just x) = push x
  push Nothing  = push NoCache