summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--Remote/Bup.hs10
-rw-r--r--Remote/Ddar.hs10
-rw-r--r--Remote/Directory.hs10
-rw-r--r--Remote/External.hs10
-rw-r--r--Remote/GCrypt.hs10
-rw-r--r--Remote/Glacier.hs10
-rw-r--r--Remote/Helper/Messages.hs14
-rw-r--r--Remote/Helper/Special.hs40
-rw-r--r--Remote/Hook.hs10
-rw-r--r--Remote/Rsync.hs10
-rw-r--r--Remote/S3.hs16
11 files changed, 98 insertions, 52 deletions
diff --git a/Remote/Bup.hs b/Remote/Bup.hs
index 2e68f30ef..80fffc056 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 1227b5275..fba05312b 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 0a2532aa5..d9419757f 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 ffae94ec9..f326f26ba 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 f971ff754..55a775811 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 2ade37011..dd28def63 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 3088a9ab2..774716ca1 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 3c19f25eb..f8428aff7 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 037f71ced..a2d096ecd 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 91070fe84..afd13abf0 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 4c1f1ecfd..1aba39245 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
generated by cgit v1.2.3 (git 2.39.1) at 2024-06-29 21:28:57 +0000