From 8025decc7f08a175cd36cd8f1cc9c5c1ef3cdff1 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 6 Aug 2014 14:28:36 -0400 Subject: [PATCH] run Preparer to get Remover and CheckPresent actions This will allow special remotes to eg, open a http connection and reuse it, while checking if chunks are present, or removing chunks. S3 and WebDAV both need this to support chunks with reasonable speed. Note that a special remote might want to cache a http connection across multiple requests. A simple case of this is that CheckPresent is typically called before Store or Remove. A remote using this interface can certianly use a Preparer that eg, uses a MVar to cache a http connection. However, it's up to the remote to then deal with things like stale or stalled http connections when eg, doing a series of downloads from a remote and other places. There could be long delays between calls to a remote, which could lead to eg, http connection stalls; the machine might even move to a new network, etc. It might be nice to improve this interface later to allow the simple case without needing to handle the full complex case. One way to do it would be to have a `Transaction SpecialRemote cache`, where SpecialRemote contains methods for Storer, Retriever, Remover, and CheckPresent, that all expect to be passed a `cache`. --- Remote/Bup.hs | 10 ++++++---- Remote/Ddar.hs | 10 ++++++---- Remote/Directory.hs | 10 ++++++---- Remote/External.hs | 10 ++++++---- Remote/GCrypt.hs | 10 ++++++---- Remote/Glacier.hs | 10 ++++++---- Remote/Helper/Messages.hs | 14 ++++++++++++-- Remote/Helper/Special.hs | 40 ++++++++++++++++++++++++++++----------- Remote/Hook.hs | 10 ++++++---- Remote/Rsync.hs | 10 ++++++---- Remote/S3.hs | 16 +++++++++------- 11 files changed, 98 insertions(+), 52 deletions(-) diff --git a/Remote/Bup.hs b/Remote/Bup.hs index 2e68f30ef7..80fffc056c 100644 --- a/Remote/Bup.hs +++ b/Remote/Bup.hs @@ -57,8 +57,8 @@ gen r u c gc = do , storeKey = storeKeyDummy , retrieveKeyFile = retreiveKeyFileDummy , retrieveKeyFileCheap = retrieveCheap buprepo - , removeKey = remove buprepo - , checkPresent = checkKey r bupr' + , removeKey = removeKeyDummy + , checkPresent = checkPresentDummy , checkPresentCheap = bupLocal buprepo , whereisKey = Nothing , remoteFsck = Nothing @@ -76,6 +76,8 @@ gen r u c gc = do return $ Just $ specialRemote' specialcfg c (simplyPrepare $ store this buprepo) (simplyPrepare $ retrieve buprepo) + (simplyPrepare $ remove buprepo) + (simplyPrepare $ checkKey r bupr') this where buprepo = fromMaybe (error "missing buprepo") $ remoteAnnexBupRepo gc @@ -146,7 +148,7 @@ retrieveCheap _ _ _ = return False - - We can, however, remove the git branch that bup created for the key. -} -remove :: BupRepo -> Key -> Annex Bool +remove :: BupRepo -> Remover remove buprepo k = do go =<< liftIO (bup2GitRemote buprepo) warning "content cannot be completely removed from bup remote" @@ -163,7 +165,7 @@ remove buprepo k = do - in a bup repository. One way it to check if the git repository has - a branch matching the name (as created by bup split -n). -} -checkKey :: Git.Repo -> Git.Repo -> Key -> Annex Bool +checkKey :: Git.Repo -> Git.Repo -> CheckPresent checkKey r bupr k | Git.repoIsUrl bupr = do showChecking r diff --git a/Remote/Ddar.hs b/Remote/Ddar.hs index 1227b52755..fba05312be 100644 --- a/Remote/Ddar.hs +++ b/Remote/Ddar.hs @@ -44,6 +44,8 @@ gen r u c gc = do return $ Just $ specialRemote' specialcfg c (simplyPrepare $ store ddarrepo) (simplyPrepare $ retrieve ddarrepo) + (simplyPrepare $ remove ddarrepo) + (simplyPrepare $ checkKey ddarrepo) (this cst) where this cst = Remote @@ -53,8 +55,8 @@ gen r u c gc = do , storeKey = storeKeyDummy , retrieveKeyFile = retreiveKeyFileDummy , retrieveKeyFileCheap = retrieveCheap - , removeKey = remove ddarrepo - , checkPresent = checkKey ddarrepo + , removeKey = removeKeyDummy + , checkPresent = checkPresentDummy , checkPresentCheap = ddarLocal ddarrepo , whereisKey = Nothing , remoteFsck = Nothing @@ -140,7 +142,7 @@ retrieve ddarrepo = byteRetriever $ \k sink -> do retrieveCheap :: Key -> FilePath -> Annex Bool retrieveCheap _ _ = return False -remove :: DdarRepo -> Key -> Annex Bool +remove :: DdarRepo -> Remover remove ddarrepo key = do (cmd, params) <- ddarRemoteCall ddarrepo 'd' [Param $ key2file key] liftIO $ boolSystem cmd params @@ -181,7 +183,7 @@ inDdarManifest ddarrepo k = do where k' = key2file k -checkKey :: DdarRepo -> Key -> Annex Bool +checkKey :: DdarRepo -> CheckPresent checkKey ddarrepo key = do directoryExists <- ddarDirectoryExists ddarrepo case directoryExists of diff --git a/Remote/Directory.hs b/Remote/Directory.hs index 0a2532aa5b..d9419757f0 100644 --- a/Remote/Directory.hs +++ b/Remote/Directory.hs @@ -44,6 +44,8 @@ gen r u c gc = do return $ Just $ specialRemote c (prepareStore dir chunkconfig) (retrieve dir chunkconfig) + (simplyPrepare $ remove dir) + (simplyPrepare $ checkKey dir chunkconfig) Remote { uuid = u, cost = cst, @@ -51,8 +53,8 @@ gen r u c gc = do storeKey = storeKeyDummy, retrieveKeyFile = retreiveKeyFileDummy, retrieveKeyFileCheap = retrieveCheap dir chunkconfig, - removeKey = remove dir, - checkPresent = checkKey dir chunkconfig, + removeKey = removeKeyDummy, + checkPresent = checkPresentDummy, checkPresentCheap = True, whereisKey = Nothing, remoteFsck = Nothing, @@ -161,7 +163,7 @@ retrieveCheap d NoChunks k f = liftIO $ catchBoolIO $ do retrieveCheap _ _ _ _ = return False #endif -remove :: FilePath -> Key -> Annex Bool +remove :: FilePath -> Remover remove d k = liftIO $ removeDirGeneric d (storeDir d k) {- Removes the directory, which must be located under the topdir. @@ -189,7 +191,7 @@ removeDirGeneric topdir dir = do then return ok else doesDirectoryExist topdir <&&> (not <$> doesDirectoryExist dir) -checkKey :: FilePath -> ChunkConfig -> Key -> Annex Bool +checkKey :: FilePath -> ChunkConfig -> CheckPresent checkKey d (LegacyChunks _) k = Legacy.checkKey d locations k checkKey d _ k = liftIO $ ifM (anyM doesFileExist (locations d k)) diff --git a/Remote/External.hs b/Remote/External.hs index ffae94ec99..f326f26ba5 100644 --- a/Remote/External.hs +++ b/Remote/External.hs @@ -45,6 +45,8 @@ gen r u c gc = do return $ Just $ specialRemote c (simplyPrepare $ store external) (simplyPrepare $ retrieve external) + (simplyPrepare $ remove external) + (simplyPrepare $ checkKey external) Remote { uuid = u, cost = cst, @@ -52,8 +54,8 @@ gen r u c gc = do storeKey = storeKeyDummy, retrieveKeyFile = retreiveKeyFileDummy, retrieveKeyFileCheap = \_ _ -> return False, - removeKey = remove external, - checkPresent = checkKey external, + removeKey = removeKeyDummy, + checkPresent = checkPresentDummy, checkPresentCheap = False, whereisKey = Nothing, remoteFsck = Nothing, @@ -109,7 +111,7 @@ retrieve external = fileRetriever $ \d k p -> error errmsg _ -> Nothing -remove :: External -> Key -> Annex Bool +remove :: External -> Remover remove external k = safely $ handleRequest external (REMOVE k) Nothing $ \resp -> case resp of @@ -121,7 +123,7 @@ remove external k = safely $ return False _ -> Nothing -checkKey :: External -> Key -> Annex Bool +checkKey :: External -> CheckPresent checkKey external k = either error id <$> go where go = handleRequest external (CHECKPRESENT k) Nothing $ \resp -> diff --git a/Remote/GCrypt.hs b/Remote/GCrypt.hs index f971ff754f..55a7758112 100644 --- a/Remote/GCrypt.hs +++ b/Remote/GCrypt.hs @@ -107,8 +107,8 @@ gen' r u c gc = do , storeKey = storeKeyDummy , retrieveKeyFile = retreiveKeyFileDummy , retrieveKeyFileCheap = \_ _ -> return False - , removeKey = remove this rsyncopts - , checkPresent = checkKey this rsyncopts + , removeKey = removeKeyDummy + , checkPresent = checkPresentDummy , checkPresentCheap = repoCheap r , whereisKey = Nothing , remoteFsck = Nothing @@ -124,6 +124,8 @@ gen' r u c gc = do return $ Just $ specialRemote' specialcfg c (simplyPrepare $ store this rsyncopts) (simplyPrepare $ retrieve this rsyncopts) + (simplyPrepare $ remove this rsyncopts) + (simplyPrepare $ checkKey this rsyncopts) this where specialcfg @@ -331,7 +333,7 @@ retrieve r rsyncopts | otherwise = unsupportedUrl where -remove :: Remote -> Remote.Rsync.RsyncOpts -> Key -> Annex Bool +remove :: Remote -> Remote.Rsync.RsyncOpts -> Remover remove r rsyncopts k | not $ Git.repoIsUrl (repo r) = guardUsable (repo r) False $ liftIO $ Remote.Directory.removeDirGeneric (Git.repoLocation (repo r)) (parentDir (gCryptLocation r k)) @@ -341,7 +343,7 @@ remove r rsyncopts k removersync = Remote.Rsync.remove rsyncopts k removeshell = Ssh.dropKey (repo r) k -checkKey :: Remote -> Remote.Rsync.RsyncOpts -> Key -> Annex Bool +checkKey :: Remote -> Remote.Rsync.RsyncOpts -> CheckPresent checkKey r rsyncopts k | not $ Git.repoIsUrl (repo r) = guardUsable (repo r) (cantCheck $ repo r) $ diff --git a/Remote/Glacier.hs b/Remote/Glacier.hs index 2ade37011e..dd28def63e 100644 --- a/Remote/Glacier.hs +++ b/Remote/Glacier.hs @@ -42,6 +42,8 @@ gen r u c gc = new <$> remoteCost gc veryExpensiveRemoteCost new cst = Just $ specialRemote' specialcfg c (prepareStore this) (prepareRetrieve this) + (simplyPrepare $ remove this) + (simplyPrepare $ checkKey this) this where this = Remote { @@ -51,8 +53,8 @@ gen r u c gc = new <$> remoteCost gc veryExpensiveRemoteCost storeKey = storeKeyDummy, retrieveKeyFile = retreiveKeyFileDummy, retrieveKeyFileCheap = retrieveCheap this, - removeKey = remove this, - checkPresent = checkKey this, + removeKey = removeKeyDummy, + checkPresent = checkPresentDummy, checkPresentCheap = False, whereisKey = Nothing, remoteFsck = Nothing, @@ -155,7 +157,7 @@ retrieve r k sink = go =<< glacierEnv c u retrieveCheap :: Remote -> Key -> FilePath -> Annex Bool retrieveCheap _ _ _ = return False -remove :: Remote -> Key -> Annex Bool +remove :: Remote -> Remover remove r k = glacierAction r [ Param "archive" @@ -164,7 +166,7 @@ remove r k = glacierAction r , Param $ archive r k ] -checkKey :: Remote -> Key -> Annex Bool +checkKey :: Remote -> CheckPresent checkKey r k = do showAction $ "checking " ++ name r go =<< glacierEnv (config r) (uuid r) diff --git a/Remote/Helper/Messages.hs b/Remote/Helper/Messages.hs index 3088a9ab2b..774716ca1a 100644 --- a/Remote/Helper/Messages.hs +++ b/Remote/Helper/Messages.hs @@ -9,9 +9,19 @@ module Remote.Helper.Messages where import Common.Annex import qualified Git +import qualified Types.Remote as Remote showChecking :: Git.Repo -> Annex () showChecking r = showAction $ "checking " ++ Git.repoDescribe r -cantCheck :: Git.Repo -> a -cantCheck r = error $ "unable to check " ++ Git.repoDescribe r +class Checkable a where + descCheckable :: a -> String + +instance Checkable Git.Repo where + descCheckable = Git.repoDescribe + +instance Checkable (Remote.RemoteA a) where + descCheckable = Remote.name + +cantCheck :: Checkable a => a -> e +cantCheck v = error $ "unable to check " ++ descCheckable v diff --git a/Remote/Helper/Special.hs b/Remote/Helper/Special.hs index 3c19f25eb9..f8428aff7c 100644 --- a/Remote/Helper/Special.hs +++ b/Remote/Helper/Special.hs @@ -11,6 +11,8 @@ module Remote.Helper.Special ( Preparer, Storer, Retriever, + Remover, + CheckPresent, simplyPrepare, ContentSource, checkPrepare, @@ -21,6 +23,8 @@ module Remote.Helper.Special ( byteRetriever, storeKeyDummy, retreiveKeyFileDummy, + removeKeyDummy, + checkPresentDummy, SpecialRemoteCfg(..), specialRemoteCfg, specialRemote, @@ -36,6 +40,7 @@ import Config.Cost import Utility.Metered import Remote.Helper.Chunked as X import Remote.Helper.Encryptable as X hiding (encryptableRemote) +import Remote.Helper.Messages import Annex.Content import Annex.Exception import qualified Git @@ -114,16 +119,27 @@ byteRetriever :: (Key -> (L.ByteString -> Annex Bool) -> Annex Bool) -> Retrieve byteRetriever a k _m callback = a k (callback . ByteContent) {- The base Remote that is provided to specialRemote needs to have - - storeKey and retreiveKeyFile methods, but they are never - - actually used (since specialRemote replaces them). + - storeKey, retreiveKeyFile, removeKey, and checkPresent methods, + - but they are never actually used (since specialRemote replaces them). - Here are some dummy ones. -} storeKeyDummy :: Key -> AssociatedFile -> MeterUpdate -> Annex Bool storeKeyDummy _ _ _ = return False retreiveKeyFileDummy :: Key -> AssociatedFile -> FilePath -> MeterUpdate -> Annex Bool retreiveKeyFileDummy _ _ _ _ = return False +removeKeyDummy :: Key -> Annex Bool +removeKeyDummy _ = return False +checkPresentDummy :: Key -> Annex Bool +checkPresentDummy _ = error "missing checkPresent implementation" -type RemoteModifier = RemoteConfig -> Preparer Storer -> Preparer Retriever -> Remote -> Remote +type RemoteModifier + = RemoteConfig + -> Preparer Storer + -> Preparer Retriever + -> Preparer Remover + -> Preparer CheckPresent + -> Remote + -> Remote data SpecialRemoteCfg = SpecialRemoteCfg { chunkConfig :: ChunkConfig @@ -139,13 +155,14 @@ specialRemote :: RemoteModifier specialRemote c = specialRemote' (specialRemoteCfg c) c specialRemote' :: SpecialRemoteCfg -> RemoteModifier -specialRemote' cfg c preparestorer prepareretriever baser = encr +specialRemote' cfg c preparestorer prepareretriever prepareremover preparecheckpresent baser = encr where encr = baser { storeKey = \k _f p -> cip >>= storeKeyGen k p , retrieveKeyFile = \k _f d p -> cip >>= retrieveKeyFileGen k d p , retrieveKeyFileCheap = \k d -> cip >>= maybe (retrieveKeyFileCheap baser k d) + -- retrieval of encrypted keys is never cheap (\_ -> return False) , removeKey = \k -> cip >>= removeKeyGen k , checkPresent = \k -> cip >>= checkPresentGen k @@ -160,8 +177,7 @@ specialRemote' cfg c preparestorer prepareretriever baser = encr safely a = catchNonAsyncAnnex a (\e -> warning (show e) >> return False) -- chunk, then encrypt, then feed to the storer - storeKeyGen k p enc = - safely $ preparestorer k $ safely . go + storeKeyGen k p enc = safely $ preparestorer k $ safely . go where go (Just storer) = sendAnnex k rollback $ \src -> displayprogress p k $ \p' -> @@ -178,7 +194,7 @@ specialRemote' cfg c preparestorer prepareretriever baser = encr readBytes $ \encb -> storer (enck k) (ByteContent encb) p - -- call retriever to get chunks; decrypt them; stream to dest file + -- call retrieve-r to get chunks; decrypt them; stream to dest file retrieveKeyFileGen k dest p enc = safely $ prepareretriever k $ safely . go where @@ -188,15 +204,17 @@ specialRemote' cfg c preparestorer prepareretriever baser = encr go Nothing = return False enck = maybe id snd enc - removeKeyGen k enc = removeChunks remover (uuid baser) chunkconfig enck k + removeKeyGen k enc = safely $ prepareremover k $ safely . go where + go (Just remover) = removeChunks remover (uuid baser) chunkconfig enck k + go Nothing = return False enck = maybe id snd enc - remover = removeKey baser - checkPresentGen k enc = checkPresentChunks checker (uuid baser) chunkconfig enck k + checkPresentGen k enc = preparecheckpresent k go where + go (Just checker) = checkPresentChunks checker (uuid baser) chunkconfig enck k + go Nothing = cantCheck baser enck = maybe id snd enc - checker = checkPresent baser chunkconfig = chunkConfig cfg diff --git a/Remote/Hook.hs b/Remote/Hook.hs index 037f71ced4..a2d096ecd4 100644 --- a/Remote/Hook.hs +++ b/Remote/Hook.hs @@ -37,6 +37,8 @@ gen r u c gc = do return $ Just $ specialRemote c (simplyPrepare $ store hooktype) (simplyPrepare $ retrieve hooktype) + (simplyPrepare $ remove hooktype) + (simplyPrepare $ checkKey r hooktype) Remote { uuid = u, cost = cst, @@ -44,8 +46,8 @@ gen r u c gc = do storeKey = storeKeyDummy, retrieveKeyFile = retreiveKeyFileDummy, retrieveKeyFileCheap = retrieveCheap hooktype, - removeKey = remove hooktype, - checkPresent = checkKey r hooktype, + removeKey = removeKeyDummy, + checkPresent = checkPresentDummy, checkPresentCheap = False, whereisKey = Nothing, remoteFsck = Nothing, @@ -125,10 +127,10 @@ retrieve h = fileRetriever $ \d k _p -> retrieveCheap :: HookName -> Key -> FilePath -> Annex Bool retrieveCheap _ _ _ = return False -remove :: HookName -> Key -> Annex Bool +remove :: HookName -> Remover remove h k = runHook h "remove" k Nothing $ return True -checkKey :: Git.Repo -> HookName -> Key -> Annex Bool +checkKey :: Git.Repo -> HookName -> CheckPresent checkKey r h k = do showAction $ "checking " ++ Git.repoDescribe r v <- lookupHook h action diff --git a/Remote/Rsync.hs b/Remote/Rsync.hs index 91070fe846..afd13abf03 100644 --- a/Remote/Rsync.hs +++ b/Remote/Rsync.hs @@ -58,6 +58,8 @@ gen r u c gc = do return $ Just $ specialRemote' specialcfg c (simplyPrepare $ fileStorer $ store o) (simplyPrepare $ fileRetriever $ retrieve o) + (simplyPrepare $ remove o) + (simplyPrepare $ checkKey r o) Remote { uuid = u , cost = cst @@ -65,8 +67,8 @@ gen r u c gc = do , storeKey = storeKeyDummy , retrieveKeyFile = retreiveKeyFileDummy , retrieveKeyFileCheap = retrieveCheap o - , removeKey = remove o - , checkPresent = checkKey r o + , removeKey = removeKeyDummy + , checkPresent = checkPresentDummy , checkPresentCheap = False , whereisKey = Nothing , remoteFsck = Nothing @@ -186,7 +188,7 @@ retrieve o f k p = retrieveCheap :: RsyncOpts -> Key -> FilePath -> Annex Bool retrieveCheap o k f = ifM (preseedTmp k f) ( rsyncRetrieve o k f Nothing , return False ) -remove :: RsyncOpts -> Key -> Annex Bool +remove :: RsyncOpts -> Remover remove o k = do ps <- sendParams withRsyncScratchDir $ \tmp -> liftIO $ do @@ -214,7 +216,7 @@ remove o k = do , dir keyFile k "***" ] -checkKey :: Git.Repo -> RsyncOpts -> Key -> Annex Bool +checkKey :: Git.Repo -> RsyncOpts -> CheckPresent checkKey r o k = do showAction $ "checking " ++ Git.repoDescribe r -- note: Does not currently differentiate between rsync failing diff --git a/Remote/S3.hs b/Remote/S3.hs index 4c1f1ecfda..1aba392453 100644 --- a/Remote/S3.hs +++ b/Remote/S3.hs @@ -47,6 +47,8 @@ gen r u c gc = new <$> remoteCost gc expensiveRemoteCost new cst = Just $ specialRemote c (prepareStore this) (prepareRetrieve this) + (simplyPrepare $ remove this c) + (simplyPrepare $ checkKey this) this where this = Remote { @@ -55,9 +57,9 @@ gen r u c gc = new <$> remoteCost gc expensiveRemoteCost name = Git.repoDescribe r, storeKey = storeKeyDummy, retrieveKeyFile = retreiveKeyFileDummy, - retrieveKeyFileCheap = retrieveCheap this, - removeKey = remove this c, - checkPresent = checkKey this, + retrieveKeyFileCheap = retrieveCheap, + removeKey = removeKeyDummy, + checkPresent = checkPresentDummy, checkPresentCheap = False, whereisKey = Nothing, remoteFsck = Nothing, @@ -150,13 +152,13 @@ prepareRetrieve r = resourcePrepare (const $ s3Action r False) $ \(conn, bucket) liftIO (getObject conn $ bucketKey r bucket k) >>= either s3Error (sink . obj_data) -retrieveCheap :: Remote -> Key -> FilePath -> Annex Bool -retrieveCheap _ _ _ = return False +retrieveCheap :: Key -> FilePath -> Annex Bool +retrieveCheap _ _ = return False {- Internet Archive doesn't easily allow removing content. - While it may remove the file, there are generally other files - derived from it that it does not remove. -} -remove :: Remote -> RemoteConfig -> Key -> Annex Bool +remove :: Remote -> RemoteConfig -> Remover remove r c k | isIA c = do warning "Cannot remove content from the Internet Archive" @@ -167,7 +169,7 @@ remove' :: Remote -> Key -> Annex Bool remove' r k = s3Action r False $ \(conn, bucket) -> s3Bool =<< liftIO (deleteObject conn $ bucketKey r bucket k) -checkKey :: Remote -> Key -> Annex Bool +checkKey :: Remote -> CheckPresent checkKey r k = s3Action r noconn $ \(conn, bucket) -> do showAction $ "checking " ++ name r res <- liftIO $ getObjectInfo conn $ bucketKey r bucket k