cas-store 1.0.1 → 1.1.0

raw patch · 5 files changed

+75/−152 lines, 5 filesdep +unliftiodep −monad-controlPVP ok

version bump matches the API change (PVP)

Dependencies added: unliftio

Dependencies removed: monad-control

API changes (from Hackage documentation)

Files

• cas-store.cabal +2/−2
• changelog.md +4/−0
• src/Data/CAS/ContentStore.hs +51/−97
• src/Data/CAS/Lock.hs +6/−5
• test/CAS/ContentStore.hs +12/−48

@@ -1,5 +1,5 @@ Name:                cas-store-Version:             1.0.1+Version:             1.1.0 Synopsis:            A content-addressed storage Description:             A content-addressed storage supporting a remote caching. The API mainly consists of the cacheKleisliIO function which takes a (a -> m b) function@@ -41,7 +41,6 @@                , hashable                , hostname                , lens-               , monad-control                , path                , path-io                , random@@ -51,6 +50,7 @@                , tar                , text                , unix+               , unliftio    if os(linux)      CPP-options: -DOS_Linux      Other-modules: Data.CAS.ContentStore.Notify.Linux

@@ -0,0 +1,4 @@+# Version 1.1.0++- monad-control is no longer a dependency. cas-store is now using unliftio for+  the same effect

@@ -61,7 +61,7 @@   , cacheKleisliIO   , putInStore   , contentPath-  +   -- * List Contents   , listAll   , listPending@@ -78,8 +78,7 @@   , waitUntilComplete    -- * Construct Items-  , constructOrAsync-  , constructOrWait+  , cacheComputation   , constructIfMissing   , withConstructIfMissing   , markPending@@ -138,7 +137,6 @@                                                       void, when, (<=<), (>=>),                                                       mzero) import           Control.Monad.IO.Class              (MonadIO, liftIO)-import           Control.Monad.Trans.Control         (MonadBaseControl) import           Crypto.Hash                         (hashUpdate) import           Data.Aeson                          (FromJSON, ToJSON) import           Data.Bits                           (complement)@@ -151,11 +149,9 @@ import qualified Data.Hashable import           Data.List                           (foldl', stripPrefix) import           Data.Maybe                          (fromMaybe, listToMaybe)-import           Data.Monoid                         ((<>)) import qualified Data.Store import           Data.String                         (IsString (..)) import qualified Data.Text                           as T-import           Data.Typeable                       (Typeable) import           Data.Void import qualified Database.SQLite.Simple              as SQL import qualified Database.SQLite.Simple.FromField    as SQL@@ -178,6 +174,7 @@                                                       toBytes) import           Data.CAS.Lock import qualified Data.CAS.RemoteCache                as Remote+import           UnliftIO                            (MonadUnliftIO)   -- | Status of an item in the store.@@ -320,7 +317,7 @@ All item ^</> path = item :</> path (item :</> dir) ^</> path = item :</> dir </> path infixl 4 ^</>-  + newtype Alias = Alias { unAlias :: T.Text }   deriving (ContentHashable IO, Eq, Ord, Show, SQL.FromField, SQL.ToField, Data.Store.Store) @@ -469,55 +466,8 @@     Failed -> return Nothing  -- | Atomically query the state under the given key and mark pending if missing.------ Returns @'Complete' item@ if the item is complete.--- Returns @'Pending' async@ if the item is pending, where @async@ is an--- 'Control.Concurrent.Async' to await updates on.--- Returns @'Missing' buildDir@ if the item was missing, and is now pending.--- It should be constructed in the given @buildDir@,--- and then marked as complete using 'markComplete'.-constructOrAsync-  :: forall m remoteCache.-     (MonadIO m, MonadBaseControl IO m, MonadMask m, Remote.Cacher m remoteCache)-  => ContentStore-  -> remoteCache-  -> ContentHash-  -> m (Status (Path Abs Dir) (Async Update) Item)-constructOrAsync store remoteCacher hash =-  constructIfMissing store remoteCacher hash >>= \case-    Complete item -> return $ Complete item-    Missing path -> return $ Missing path-    Pending _ -> Pending <$> liftIO (internalWatchPending store hash)---- | Atomically query the state under the given key and mark pending if missing.--- Wait for the item to be completed, if already pending.--- Throws a 'FailedToConstruct' error if construction fails.------ Returns @'Complete' item@ if the item is complete.--- Returns @'Missing' buildDir@ if the item was missing, and is now pending.--- It should be constructed in the given @buildDir@,--- and then marked as complete using 'markComplete'.-constructOrWait-  :: (MonadIO m, MonadMask m, MonadBaseControl IO m, Remote.Cacher m remoteCache)-  => ContentStore-  -> remoteCache-  -> ContentHash-  -> m (Status (Path Abs Dir) Void Item)-constructOrWait store remoteCacher hash = constructOrAsync store remoteCacher hash >>= \case-  Pending a -> liftIO (wait a) >>= \case-    Completed item -> return $ Complete item-    -- XXX: Consider extending 'Status' with a 'Failed' constructor.-    --   If the store contains metadata as well, it could keep track of the-    --   number of failed attempts and further details about the failure.-    --   If an external task is responsible for the failure, the client could-    --   choose to resubmit a certain number of times.-    Failed -> liftIO . throwIO $ FailedToConstruct hash-  Complete item -> return $ Complete item-  Missing dir -> return $ Missing dir---- | Atomically query the state under the given key and mark pending if missing. constructIfMissing-  :: (MonadIO m, MonadBaseControl IO m, MonadMask m, Remote.Cacher m remoteCache)+  :: (MonadIO m, MonadUnliftIO m, MonadMask m, Remote.Cacher m remoteCache)   => ContentStore   -> remoteCache   -> ContentHash@@ -531,7 +481,7 @@         Remote.PullOK () -> return $ Complete (Item hash)         Remote.NotInCache ->           Missing <$> liftIO (internalMarkPending store hash)-        Remote.PullError _ ->+        Remote.PullError _ ->  -- TODO: That error should not be silenced           Missing <$> liftIO (internalMarkPending store hash)     Pending _ -> return $ Pending () @@ -540,18 +490,21 @@ -- and remove on failure. Forcibly removes if an uncaught exception occurs -- during item construction. withConstructIfMissing-  :: (MonadIO m, MonadBaseControl IO m, MonadMask m, Remote.Cacher m remoteCache)+  :: (MonadIO m, MonadUnliftIO m, MonadMask m, Remote.Cacher m remoteCache)   => ContentStore   -> remoteCache+  -> m () -- ^ In case an exception occurs (to log something for instance)   -> ContentHash   -> (Path Abs Dir -> m (Either e a))   -> m (Status e () (Maybe a, Item))-withConstructIfMissing store remoteCacher hash f =+withConstructIfMissing store remoteCacher ifExc hash f =   bracketOnError     (constructIfMissing store remoteCacher hash)-    (\case-      Missing _ -> removeForcibly store hash-      _ -> return ())+    (\status -> do+        case status of+          Missing _ -> removeForcibly store hash+          _ -> return ()+        ifExc)     (\case       Pending () -> return (Pending ())       Complete item -> return (Complete (Nothing, item))@@ -785,8 +738,8 @@     Pending _ -> do       let path = mkMetadataFilePath store hash file       createDirIfMissing True (parent path)-      handle <- openFile (fromAbsFile path) WriteMode-      pure (path, handle)+      hndl <- openFile (fromAbsFile path) WriteMode+      pure (path, hndl)     _ -> throwIO $ NotPending hash  -- | Return the path to a metadata file if it exists.@@ -815,7 +768,7 @@  -- | Holds a lock on the global 'MVar' and on the global lock file -- for the duration of the given action.-withStoreLock :: MonadBaseControl IO m => ContentStore -> m a -> m a+withStoreLock :: MonadUnliftIO m => ContentStore -> m a -> m a withStoreLock store = withLock (storeLock store)  prefixHashPath :: C8.ByteString -> ContentHash -> Path Rel Dir@@ -1088,11 +1041,31 @@ defaultIOCacherWithIdent ident = c{cacherKey = \x i -> liftIO $ cacherKey c x i}   where c = defaultCacherWithIdent ident +-- | Runs a computation only if the ContentHash isn't already associated to an+-- entry in the store+cacheComputation+  :: (MonadIO m, MonadUnliftIO m, MonadMask m, Remote.Cacher m remoteCache)+  => ContentStore+  -> remoteCache+  -> m ()                  -- ^ In case an exception occurs+  -> ContentHash           -- ^ A ContentHash to identify the computation inputs+  -> (Path Abs Dir -> m a) -- ^ The computation to cache, receving the path of a+                           -- store folder to which it should write its results+  -> m (Maybe a, Item)     -- ^ The result if it was just computed, and the item+                           -- corresponding to the store folder+cacheComputation store remoteCacher ifExc inputCHash computation =+  withConstructIfMissing store remoteCacher ifExc inputCHash (fmap Right . computation) >>= \case+    Missing e -> absurd e+    Pending _ ->+      liftIO (waitUntilComplete store inputCHash) >>= \case+        Just item -> return (Nothing, item)+        Nothing -> throwM $ FailedToConstruct inputCHash+    Complete resultAndItem -> return resultAndItem  -- | Caches a Kleisli of some MonadIO action in the store given the required -- properties cacheKleisliIO-  :: (MonadIO m, MonadBaseControl IO m, MonadMask m, Remote.Cacher m remoteCache)+  :: (MonadIO m, MonadUnliftIO m, MonadMask m, Remote.Cacher m remoteCache)   => Maybe Int  -- ^ This can be used to disambiguate the same program run in                 -- multiple configurations. If Nothing, then it means this                 -- program has no identity, this implies that steps will be@@ -1106,31 +1079,23 @@ cacheKleisliIO confIdent c@Cache{} store remoteCacher f i   | Just confIdent' <- confIdent = do       chash <- cacherKey c confIdent' i-      let computeAndStore fp = do-            res <- f i  -- Do the actual computation-            liftIO $ BS.writeFile (toFilePath $ fp </> [relfile|out|])-                   . cacherStoreValue c $ res-            return $ Right res-          readItem item = do-            bs <- liftIO . BS.readFile $ simpleOutPath item-            return . cacherReadValue c $ bs-      withConstructIfMissing store remoteCacher chash computeAndStore >>= \case-        Missing e -> absurd e-        Pending _ ->-          liftIO (waitUntilComplete store chash) >>= \case-            Just item -> readItem item-            Nothing -> throwM $ FailedToConstruct chash-        Complete (Just a, _) -> return a-        Complete (_, item) -> readItem item-  where-    simpleOutPath item =-      toFilePath $ itemPath store item </> [relfile|out|]+      (res, item) <- cacheComputation store remoteCacher (return ()) chash computeAndStore+      case res of+        Just r -> return r+        Nothing -> do+          bs <- liftIO . BS.readFile $ toFilePath $ itemPath store item </> [relfile|out|]+          return $ cacherReadValue c $ bs+  where computeAndStore fp = do+          res <- f i  -- Do the actual computation+          liftIO $ BS.writeFile (toFilePath $ fp </> [relfile|out|])+                 $ cacherStoreValue c $ res+          return res cacheKleisliIO _ _ _ _ f i = f i  -- | Caches an action that writes content-addressed data to the store. Returns -- the Item of the written content. putInStore-  :: (MonadIO m, MonadMask m, MonadBaseControl IO m+  :: (MonadIO m, MonadMask m, MonadUnliftIO m      ,Remote.Cacher m remoteCacher      ,ContentHashable IO t)   => ContentStore@@ -1142,15 +1107,4 @@   -> m Item -- ^ The Item in the store to which @t@ has been written putInStore store remoteCacher ifExc f x = do   chash <- liftIO $ contentHash x-  constructOrWait store remoteCacher chash >>= \case-    Pending y -> absurd y-    Complete item -> return item-    Missing fp ->-      do-        f fp x-        finalItem <- markComplete store chash-        _ <- Remote.push remoteCacher (itemHash finalItem) (Just chash) (itemPath store finalItem)-        pure finalItem-      `onException`-        (do ifExc chash-            removeFailed store chash)+  snd <$> cacheComputation store remoteCacher (ifExc chash) chash (flip f x)

@@ -16,10 +16,9 @@   , withLock   ) where -import           Control.Concurrent+import           Control.Concurrent          (threadDelay) import           Control.Exception.Safe import           Control.Monad               (unless)-import           Control.Monad.Trans.Control (MonadBaseControl, liftBaseOp_) import           Network.HostName            (getHostName) import           Path import           Path.IO@@ -27,6 +26,8 @@ import           System.Posix.IO import           System.Posix.Process import           System.Random+import           UnliftIO                    (MonadUnliftIO, withRunInIO)+import           UnliftIO.MVar  -- | Thread and process write lock. --@@ -60,11 +61,11 @@   takeMVar (lockMVar lock)  -- | Acquire the lock for the duration of the given action and release after.-withLock :: MonadBaseControl IO m => Lock -> m a -> m a-withLock lock = liftBaseOp_ $ \action ->+withLock :: MonadUnliftIO m => Lock -> m a -> m a+withLock lock action = withRunInIO $ \unliftIO ->   withMVar (lockMVar lock) $ \() ->     bracket_ (acquireDirLock $ lockDir lock) (releaseDirLock $ lockDir lock) $-      action+      unliftIO action  ---------------------------------------------------------------------- -- Internals

@@ -96,7 +96,7 @@     withEmptyStore $ \store -> do       hash <- contentHash ("test" :: String) -      ContentStore.constructOrAsync store myCache hash >>= \case+      ContentStore.constructIfMissing store myCache hash >>= \case         ContentStore.Pending _ ->           assertFailure "missing already under construction"         ContentStore.Complete _ ->@@ -104,15 +104,13 @@         ContentStore.Missing _ ->           return () -      a <- ContentStore.constructOrAsync store Remote.NoCache hash >>= \case+      ContentStore.constructIfMissing store Remote.NoCache hash >>= \case         ContentStore.Missing _ -> do           assertFailure "under construction still missing"-          undefined         ContentStore.Complete _ -> do           assertFailure "under construction already complete"-          undefined-        ContentStore.Pending a ->-          return a+        ContentStore.Pending _ ->+          return ()        b <- ContentStore.lookupOrWait store hash >>= \case         ContentStore.Missing _ -> do@@ -126,13 +124,10 @@        item <- ContentStore.markComplete store hash -      item' <- wait a-      item' @?= ContentStore.Completed item-       item'' <- wait b       item'' @?= ContentStore.Completed item -      ContentStore.constructOrAsync store Remote.NoCache hash >>= \case+      ContentStore.constructIfMissing store Remote.NoCache hash >>= \case         ContentStore.Missing _ -> do           assertFailure "complete still missing"         ContentStore.Pending _ -> do@@ -144,7 +139,7 @@     withEmptyStore $ \store -> do       hash <- contentHash ("test" :: String) -      ContentStore.constructOrAsync store Remote.NoCache hash >>= \case+      ContentStore.constructIfMissing store Remote.NoCache hash >>= \case         ContentStore.Pending _ ->           assertFailure "missing already under construction"         ContentStore.Complete _ ->@@ -152,15 +147,13 @@         ContentStore.Missing _ ->           return () -      a <- ContentStore.constructOrAsync store Remote.NoCache hash >>= \case+      ContentStore.constructIfMissing store Remote.NoCache hash >>= \case         ContentStore.Missing _ -> do           assertFailure "under construction still missing"-          undefined         ContentStore.Complete _ -> do           assertFailure "under construction already complete"-          undefined-        ContentStore.Pending a ->-          return a+        ContentStore.Pending _ ->+          return ()        b <- ContentStore.lookupOrWait store hash >>= \case         ContentStore.Missing _ -> do@@ -174,13 +167,10 @@        ContentStore.removeFailed store hash -      item' <- wait a-      item' @?= ContentStore.Failed-       item'' <- wait b       item'' @?= ContentStore.Failed -      ContentStore.constructOrAsync store Remote.NoCache hash >>= \case+      ContentStore.constructIfMissing store Remote.NoCache hash >>= \case         ContentStore.Pending _ -> do           assertFailure "failed still under construction"         ContentStore.Complete _ -> do@@ -386,32 +376,6 @@         r <- ContentStore.lookupAlias store aliasB         r @?= Nothing -    , testCase "Remote caching (constructOrAsync)" $ do-      cacher <- Remote.memoryCache-      hash <- contentHash ("test" :: String)-      let file = [relfile|file|]-          expectedContent = "Hello World"--      -- Populate the remote cache-      withEmptyStore $ \store -> do-        ContentStore.constructOrAsync store cacher hash >>= \case-          ContentStore.Pending _ ->-            assertFailure "missing already under construction"-          ContentStore.Complete _ ->-            assertFailure "missing already complete"-          ContentStore.Missing subtree -> do-            isWritable subtree @? "under construction not writable"-            writeFile (fromAbsFile $ subtree </> file) expectedContent-            Remote.push cacher hash Nothing subtree--      -- Expects having the item in cache-      withEmptyStore $ \store -> do-        ContentStore.constructOrAsync store cacher hash >>= \case-          ContentStore.Pending _ ->-            assertFailure "missing already under construction"-          ContentStore.Complete _ -> pure ()-          ContentStore.Missing _ -> assertFailure "Not found in the cache"-     , testCase "Remote caching (withConstructIfMissing)" $ do       cacher <- Remote.memoryCache       hash <- contentHash ("test" :: String)@@ -424,7 +388,7 @@              -- Populates the remote cache       withEmptyStore $ \store -> do-        ContentStore.withConstructIfMissing store cacher hash doWrite >>= \case+        ContentStore.withConstructIfMissing store cacher (return ()) hash doWrite >>= \case           ContentStore.Missing _ -> assertFailure "not found in the cache"           ContentStore.Pending _ ->             assertFailure "missing already under construction"@@ -435,7 +399,7 @@            -- Expects having the item in the remote cache       withEmptyStore $ \store -> do-        ContentStore.withConstructIfMissing store cacher hash+        ContentStore.withConstructIfMissing store cacher (return ()) hash           (const $ assertFailure "should not try to write the file a second time") >>= \case             ContentStore.Missing _ -> assertFailure "Not found in the cache"             ContentStore.Pending _ ->