aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--Remote.hs8
-rw-r--r--Remote/Bup.hs15
-rw-r--r--Remote/Ddar.hs15
-rw-r--r--Remote/Directory.hs21
-rw-r--r--Remote/Directory/LegacyChunked.hs9
-rw-r--r--Remote/External.hs8
-rw-r--r--Remote/GCrypt.hs14
-rw-r--r--Remote/Git.hs25
-rw-r--r--Remote/Glacier.hs28
-rw-r--r--Remote/Helper/Chunked.hs47
-rw-r--r--Remote/Helper/Encryptable.hs6
-rw-r--r--Remote/Helper/Hooks.hs2
-rw-r--r--Remote/Helper/Messages.hs4
-rw-r--r--Remote/Helper/Special.hs8
-rw-r--r--Remote/Helper/Ssh.hs6
-rw-r--r--Remote/Hook.hs10
-rw-r--r--Remote/Rsync.hs14
-rw-r--r--Remote/S3.hs16
-rw-r--r--Remote/Tahoe.hs20
-rw-r--r--Remote/Web.hs10
-rw-r--r--Remote/WebDAV.hs10
-rw-r--r--Types/Remote.hs10
-rw-r--r--Types/StoreRetrieve.hs8
-rw-r--r--doc/design/assistant/chunks.mdwn16
24 files changed, 167 insertions, 163 deletions
diff --git a/Remote.hs b/Remote.hs
index 29097f77d..5ee75823f 100644
--- a/Remote.hs
+++ b/Remote.hs
@@ -56,6 +56,7 @@ import Data.Ord
import Common.Annex
import Types.Remote
import qualified Annex
+import Annex.Exception
import Annex.UUID
import Logs.UUID
import Logs.Trust
@@ -312,3 +313,10 @@ isXMPPRemote :: Remote -> Bool
isXMPPRemote remote = Git.repoIsUrl r && "xmpp::" `isPrefixOf` Git.repoLocation r
where
r = repo remote
+
+hasKey :: Remote -> Key -> Annex (Either String Bool)
+hasKey r k = either (Left . show) Right
+ <$> tryNonAsyncAnnex (checkPresent r k)
+
+hasKeyCheap :: Remote -> Bool
+hasKeyCheap = checkPresentCheap
diff --git a/Remote/Bup.hs b/Remote/Bup.hs
index 6a04ad5f7..2e68f30ef 100644
--- a/Remote/Bup.hs
+++ b/Remote/Bup.hs
@@ -58,8 +58,8 @@ gen r u c gc = do
, retrieveKeyFile = retreiveKeyFileDummy
, retrieveKeyFileCheap = retrieveCheap buprepo
, removeKey = remove buprepo
- , hasKey = checkPresent r bupr'
- , hasKeyCheap = bupLocal buprepo
+ , checkPresent = checkKey r bupr'
+ , checkPresentCheap = bupLocal buprepo
, whereisKey = Nothing
, remoteFsck = Nothing
, repairRepo = Nothing
@@ -163,14 +163,13 @@ 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).
-}
-checkPresent :: Git.Repo -> Git.Repo -> Key -> Annex (Either String Bool)
-checkPresent r bupr k
+checkKey :: Git.Repo -> Git.Repo -> Key -> Annex Bool
+checkKey r bupr k
| Git.repoIsUrl bupr = do
showChecking r
- ok <- onBupRemote bupr boolSystem "git" params
- return $ Right ok
- | otherwise = liftIO $ catchMsgIO $
- boolSystem "git" $ Git.Command.gitCommandLine params bupr
+ onBupRemote bupr boolSystem "git" params
+ | otherwise = liftIO $ boolSystem "git" $
+ Git.Command.gitCommandLine params bupr
where
params =
[ Params "show-ref --quiet --verify"
diff --git a/Remote/Ddar.hs b/Remote/Ddar.hs
index b4c7ac1e6..1227b5275 100644
--- a/Remote/Ddar.hs
+++ b/Remote/Ddar.hs
@@ -54,8 +54,8 @@ gen r u c gc = do
, retrieveKeyFile = retreiveKeyFileDummy
, retrieveKeyFileCheap = retrieveCheap
, removeKey = remove ddarrepo
- , hasKey = checkPresent ddarrepo
- , hasKeyCheap = ddarLocal ddarrepo
+ , checkPresent = checkKey ddarrepo
+ , checkPresentCheap = ddarLocal ddarrepo
, whereisKey = Nothing
, remoteFsck = Nothing
, repairRepo = Nothing
@@ -181,13 +181,14 @@ inDdarManifest ddarrepo k = do
where
k' = key2file k
-checkPresent :: DdarRepo -> Key -> Annex (Either String Bool)
-checkPresent ddarrepo key = do
+checkKey :: DdarRepo -> Key -> Annex Bool
+checkKey ddarrepo key = do
directoryExists <- ddarDirectoryExists ddarrepo
case directoryExists of
- Left e -> return $ Left e
- Right True -> inDdarManifest ddarrepo key
- Right False -> return $ Right False
+ Left e -> error e
+ Right True -> either error return
+ =<< inDdarManifest ddarrepo key
+ Right False -> return False
ddarLocal :: DdarRepo -> Bool
ddarLocal = notElem ':'
diff --git a/Remote/Directory.hs b/Remote/Directory.hs
index 9b3c15695..0a2532aa5 100644
--- a/Remote/Directory.hs
+++ b/Remote/Directory.hs
@@ -52,8 +52,8 @@ gen r u c gc = do
retrieveKeyFile = retreiveKeyFileDummy,
retrieveKeyFileCheap = retrieveCheap dir chunkconfig,
removeKey = remove dir,
- hasKey = checkPresent dir chunkconfig,
- hasKeyCheap = True,
+ checkPresent = checkKey dir chunkconfig,
+ checkPresentCheap = True,
whereisKey = Nothing,
remoteFsck = Nothing,
repairRepo = Nothing,
@@ -189,13 +189,10 @@ removeDirGeneric topdir dir = do
then return ok
else doesDirectoryExist topdir <&&> (not <$> doesDirectoryExist dir)
-checkPresent :: FilePath -> ChunkConfig -> Key -> Annex (Either String Bool)
-checkPresent d (LegacyChunks _) k = Legacy.checkPresent d locations k
-checkPresent d _ k = liftIO $ do
- v <- catchMsgIO $ anyM doesFileExist (locations d k)
- case v of
- Right False -> ifM (doesDirectoryExist d)
- ( return v
- , return $ Left $ "directory " ++ d ++ " is not accessible"
- )
- _ -> return v
+checkKey :: FilePath -> ChunkConfig -> Key -> Annex Bool
+checkKey d (LegacyChunks _) k = Legacy.checkKey d locations k
+checkKey d _ k = liftIO $
+ ifM (anyM doesFileExist (locations d k))
+ ( return True
+ , error $ "directory " ++ d ++ " is not accessible"
+ )
diff --git a/Remote/Directory/LegacyChunked.hs b/Remote/Directory/LegacyChunked.hs
index 1be885db2..b2248c5f6 100644
--- a/Remote/Directory/LegacyChunked.hs
+++ b/Remote/Directory/LegacyChunked.hs
@@ -103,8 +103,7 @@ retrieve locations d basek a = do
liftIO $ nukeFile tmp
sink b
-checkPresent :: FilePath -> (FilePath -> Key -> [FilePath]) -> Key -> Annex (Either String Bool)
-checkPresent d locations k = liftIO $ catchMsgIO $
- withStoredFiles d locations k $
- -- withStoredFiles checked that it exists
- const $ return True
+checkKey :: FilePath -> (FilePath -> Key -> [FilePath]) -> Key -> Annex Bool
+checkKey d locations k = liftIO $ withStoredFiles d locations k $
+ -- withStoredFiles checked that it exists
+ const $ return True
diff --git a/Remote/External.hs b/Remote/External.hs
index c00093402..ffae94ec9 100644
--- a/Remote/External.hs
+++ b/Remote/External.hs
@@ -53,8 +53,8 @@ gen r u c gc = do
retrieveKeyFile = retreiveKeyFileDummy,
retrieveKeyFileCheap = \_ _ -> return False,
removeKey = remove external,
- hasKey = checkPresent external,
- hasKeyCheap = False,
+ checkPresent = checkKey external,
+ checkPresentCheap = False,
whereisKey = Nothing,
remoteFsck = Nothing,
repairRepo = Nothing,
@@ -121,8 +121,8 @@ remove external k = safely $
return False
_ -> Nothing
-checkPresent :: External -> Key -> Annex (Either String Bool)
-checkPresent external k = either (Left . show) id <$> tryAnnex go
+checkKey :: External -> Key -> Annex Bool
+checkKey external k = either error id <$> go
where
go = handleRequest external (CHECKPRESENT k) Nothing $ \resp ->
case resp of
diff --git a/Remote/GCrypt.hs b/Remote/GCrypt.hs
index d969e02f8..f971ff754 100644
--- a/Remote/GCrypt.hs
+++ b/Remote/GCrypt.hs
@@ -46,7 +46,6 @@ import Utility.Tmp
import Logs.Remote
import Logs.Transfer
import Utility.Gpg
-import Utility.FileMode
remote :: RemoteType
remote = RemoteType {
@@ -109,8 +108,8 @@ gen' r u c gc = do
, retrieveKeyFile = retreiveKeyFileDummy
, retrieveKeyFileCheap = \_ _ -> return False
, removeKey = remove this rsyncopts
- , hasKey = checkPresent this rsyncopts
- , hasKeyCheap = repoCheap r
+ , checkPresent = checkKey this rsyncopts
+ , checkPresentCheap = repoCheap r
, whereisKey = Nothing
, remoteFsck = Nothing
, repairRepo = Nothing
@@ -342,16 +341,15 @@ remove r rsyncopts k
removersync = Remote.Rsync.remove rsyncopts k
removeshell = Ssh.dropKey (repo r) k
-checkPresent :: Remote -> Remote.Rsync.RsyncOpts -> Key -> Annex (Either String Bool)
-checkPresent r rsyncopts k
+checkKey :: Remote -> Remote.Rsync.RsyncOpts -> Key -> Annex Bool
+checkKey r rsyncopts k
| not $ Git.repoIsUrl (repo r) =
guardUsable (repo r) (cantCheck $ repo r) $
- liftIO $ catchDefaultIO (cantCheck $ repo r) $
- Right <$> doesFileExist (gCryptLocation r k)
+ liftIO $ doesFileExist (gCryptLocation r k)
| Git.repoIsSsh (repo r) = shellOrRsync r checkshell checkrsync
| otherwise = unsupportedUrl
where
- checkrsync = Remote.Rsync.checkPresent (repo r) rsyncopts k
+ checkrsync = Remote.Rsync.checkKey (repo r) rsyncopts k
checkshell = Ssh.inAnnex (repo r) k
{- Annexed objects are hashed using lower-case directories for max
diff --git a/Remote/Git.hs b/Remote/Git.hs
index c35f9f32a..da5ca4c4a 100644
--- a/Remote/Git.hs
+++ b/Remote/Git.hs
@@ -141,8 +141,8 @@ gen r u c gc
, retrieveKeyFile = copyFromRemote new
, retrieveKeyFileCheap = copyFromRemoteCheap new
, removeKey = dropKey new
- , hasKey = inAnnex new
- , hasKeyCheap = repoCheap r
+ , checkPresent = inAnnex new
+ , checkPresentCheap = repoCheap r
, whereisKey = Nothing
, remoteFsck = if Git.repoIsUrl r
then Nothing
@@ -284,11 +284,8 @@ tryGitConfigRead r
void $ tryAnnex $ ensureInitialized
Annex.getState Annex.repo
-{- Checks if a given remote has the content for a key inAnnex.
- - If the remote cannot be accessed, or if it cannot determine
- - whether it has the content, returns a Left error message.
- -}
-inAnnex :: Remote -> Key -> Annex (Either String Bool)
+{- Checks if a given remote has the content for a key in its annex. -}
+inAnnex :: Remote -> Key -> Annex Bool
inAnnex rmt key
| Git.repoIsHttp r = checkhttp
| Git.repoIsUrl r = checkremote
@@ -298,17 +295,13 @@ inAnnex rmt key
checkhttp = do
showChecking r
ifM (Url.withUrlOptions $ \uo -> anyM (\u -> Url.checkBoth u (keySize key) uo) (keyUrls rmt key))
- ( return $ Right True
- , return $ Left "not found"
+ ( return True
+ , error "not found"
)
checkremote = Ssh.inAnnex r key
- checklocal = guardUsable r (cantCheck r) $ dispatch <$> check
- where
- check = either (Left . show) Right
- <$> tryAnnex (onLocal rmt $ Annex.Content.inAnnexSafe key)
- dispatch (Left e) = Left e
- dispatch (Right (Just b)) = Right b
- dispatch (Right Nothing) = cantCheck r
+ checklocal = guardUsable r (cantCheck r) $
+ fromMaybe (cantCheck r)
+ <$> onLocal rmt (Annex.Content.inAnnexSafe key)
keyUrls :: Remote -> Key -> [String]
keyUrls r key = map tourl locs'
diff --git a/Remote/Glacier.hs b/Remote/Glacier.hs
index c5bfefa64..2ade37011 100644
--- a/Remote/Glacier.hs
+++ b/Remote/Glacier.hs
@@ -52,8 +52,8 @@ gen r u c gc = new <$> remoteCost gc veryExpensiveRemoteCost
retrieveKeyFile = retreiveKeyFileDummy,
retrieveKeyFileCheap = retrieveCheap this,
removeKey = remove this,
- hasKey = checkPresent this,
- hasKeyCheap = False,
+ checkPresent = checkKey this,
+ checkPresentCheap = False,
whereisKey = Nothing,
remoteFsck = Nothing,
repairRepo = Nothing,
@@ -164,25 +164,21 @@ remove r k = glacierAction r
, Param $ archive r k
]
-checkPresent :: Remote -> Key -> Annex (Either String Bool)
-checkPresent r k = do
+checkKey :: Remote -> Key -> Annex Bool
+checkKey r k = do
showAction $ "checking " ++ name r
go =<< glacierEnv (config r) (uuid r)
where
- go Nothing = return $ Left "cannot check glacier"
+ go Nothing = error "cannot check glacier"
go (Just e) = do
{- glacier checkpresent outputs the archive name to stdout if
- it's present. -}
- v <- liftIO $ catchMsgIO $
- readProcessEnv "glacier" (toCommand params) (Just e)
- case v of
- Right s -> do
- let probablypresent = key2file k `elem` lines s
- if probablypresent
- then ifM (Annex.getFlag "trustglacier")
- ( return $ Right True, untrusted )
- else return $ Right False
- Left err -> return $ Left err
+ s <- liftIO $ readProcessEnv "glacier" (toCommand params) (Just e)
+ let probablypresent = key2file k `elem` lines s
+ if probablypresent
+ then ifM (Annex.getFlag "trustglacier")
+ ( return True, error untrusted )
+ else return False
params = glacierParams (config r)
[ Param "archive"
@@ -192,7 +188,7 @@ checkPresent r k = do
, Param $ archive r k
]
- untrusted = return $ Left $ unlines
+ untrusted = unlines
[ "Glacier's inventory says it has a copy."
, "However, the inventory could be out of date, if it was recently removed."
, "(Use --trust-glacier if you're sure it's still in Glacier.)"
diff --git a/Remote/Helper/Chunked.hs b/Remote/Helper/Chunked.hs
index 7ad790cb1..953c533b6 100644
--- a/Remote/Helper/Chunked.hs
+++ b/Remote/Helper/Chunked.hs
@@ -12,7 +12,7 @@ module Remote.Helper.Chunked (
storeChunks,
removeChunks,
retrieveChunks,
- hasKeyChunks,
+ checkPresentChunks,
) where
import Common.Annex
@@ -94,8 +94,8 @@ storeChunks
-> Key
-> FilePath
-> MeterUpdate
- -> (Key -> ContentSource -> MeterUpdate -> Annex Bool)
- -> (Key -> Annex (Either String Bool))
+ -> Storer
+ -> CheckPresent
-> Annex Bool
storeChunks u chunkconfig k f p storer checker =
case chunkconfig of
@@ -158,7 +158,7 @@ storeChunks u chunkconfig k f p storer checker =
seekResume
:: Handle
-> ChunkKeyStream
- -> (Key -> Annex (Either String Bool))
+ -> CheckPresent
-> Annex (ChunkKeyStream, BytesProcessed)
seekResume h chunkkeys checker = do
sz <- liftIO (hFileSize h)
@@ -172,7 +172,7 @@ seekResume h chunkkeys checker = do
liftIO $ hSeek h AbsoluteSeek sz
return (cks, toBytesProcessed sz)
| otherwise = do
- v <- checker k
+ v <- tryNonAsyncAnnex (checker k)
case v of
Right True ->
check pos' cks' sz
@@ -331,43 +331,48 @@ setupResume ls currsize = map dropunneeded ls
{- Checks if a key is present in a remote. This requires any one
- of the lists of options returned by chunkKeys to all check out
- as being present using the checker action.
+ -
+ - Throws an exception if the remote is not accessible.
-}
-hasKeyChunks
- :: (Key -> Annex (Either String Bool))
+checkPresentChunks
+ :: CheckPresent
-> UUID
-> ChunkConfig
-> EncKey
-> Key
- -> Annex (Either String Bool)
-hasKeyChunks checker u chunkconfig encryptor basek
- | noChunks chunkconfig =
+ -> Annex Bool
+checkPresentChunks checker u chunkconfig encryptor basek
+ | noChunks chunkconfig = do
-- Optimisation: Try the unchunked key first, to avoid
-- looking in the git-annex branch for chunk counts
-- that are likely not there.
- ifM ((Right True ==) <$> checker (encryptor basek))
- ( return (Right True)
- , checklists Nothing =<< chunkKeysOnly u basek
- )
+ v <- check basek
+ case v of
+ Right True -> return True
+ _ -> checklists Nothing =<< chunkKeysOnly u basek
| otherwise = checklists Nothing =<< chunkKeys u chunkconfig basek
where
- checklists Nothing [] = return (Right False)
- checklists (Just deferrederror) [] = return (Left deferrederror)
+ checklists Nothing [] = return False
+ checklists (Just deferrederror) [] = error deferrederror
checklists d (l:ls)
| not (null l) = do
v <- checkchunks l
case v of
Left e -> checklists (Just e) ls
- Right True -> return (Right True)
+ Right True -> return True
Right False -> checklists Nothing ls
| otherwise = checklists d ls
checkchunks :: [Key] -> Annex (Either String Bool)
checkchunks [] = return (Right True)
checkchunks (k:ks) = do
- v <- checker (encryptor k)
- if v == Right True
- then checkchunks ks
- else return v
+ v <- check k
+ case v of
+ Right True -> checkchunks ks
+ Right False -> return $ Right False
+ Left e -> return $ Left $ show e
+
+ check = tryNonAsyncAnnex . checker . encryptor
{- A key can be stored in a remote unchunked, or as a list of chunked keys.
- This can be the case whether or not the remote is currently configured
diff --git a/Remote/Helper/Encryptable.hs b/Remote/Helper/Encryptable.hs
index 65a3ba284..c364a69e7 100644
--- a/Remote/Helper/Encryptable.hs
+++ b/Remote/Helper/Encryptable.hs
@@ -91,9 +91,9 @@ encryptableRemote c storeKeyEncrypted retrieveKeyFileEncrypted r = r
, removeKey = \k -> cip k >>= maybe
(removeKey r k)
(\(_, enckey) -> removeKey r enckey)
- , hasKey = \k -> cip k >>= maybe
- (hasKey r k)
- (\(_, enckey) -> hasKey r enckey)
+ , checkPresent = \k -> cip k >>= maybe
+ (checkPresent r k)
+ (\(_, enckey) -> checkPresent r enckey)
, cost = maybe
(cost r)
(const $ cost r + encryptedRemoteCostAdj)
diff --git a/Remote/Helper/Hooks.hs b/Remote/Helper/Hooks.hs
index c3ff970c6..907400bd1 100644
--- a/Remote/Helper/Hooks.hs
+++ b/Remote/Helper/Hooks.hs
@@ -39,7 +39,7 @@ addHooks' r starthook stophook = r'
, retrieveKeyFile = \k f d p -> wrapper $ retrieveKeyFile r k f d p
, retrieveKeyFileCheap = \k f -> wrapper $ retrieveKeyFileCheap r k f
, removeKey = wrapper . removeKey r
- , hasKey = wrapper . hasKey r
+ , checkPresent = wrapper . checkPresent r
}
where
wrapper = runHooks r' starthook stophook
diff --git a/Remote/Helper/Messages.hs b/Remote/Helper/Messages.hs
index c4b1966dc..3088a9ab2 100644
--- a/Remote/Helper/Messages.hs
+++ b/Remote/Helper/Messages.hs
@@ -13,5 +13,5 @@ import qualified Git
showChecking :: Git.Repo -> Annex ()
showChecking r = showAction $ "checking " ++ Git.repoDescribe r
-cantCheck :: Git.Repo -> Either String Bool
-cantCheck r = Left $ "unable to check " ++ Git.repoDescribe r
+cantCheck :: Git.Repo -> a
+cantCheck r = error $ "unable to check " ++ Git.repoDescribe r
diff --git a/Remote/Helper/Special.hs b/Remote/Helper/Special.hs
index 2bcb7d530..3c19f25eb 100644
--- a/Remote/Helper/Special.hs
+++ b/Remote/Helper/Special.hs
@@ -148,7 +148,7 @@ specialRemote' cfg c preparestorer prepareretriever baser = encr
(retrieveKeyFileCheap baser k d)
(\_ -> return False)
, removeKey = \k -> cip >>= removeKeyGen k
- , hasKey = \k -> cip >>= hasKeyGen k
+ , checkPresent = \k -> cip >>= checkPresentGen k
, cost = maybe
(cost baser)
(const $ cost baser + encryptedRemoteCostAdj)
@@ -167,7 +167,7 @@ specialRemote' cfg c preparestorer prepareretriever baser = encr
displayprogress p k $ \p' ->
storeChunks (uuid baser) chunkconfig k src p'
(storechunk enc storer)
- (hasKey baser)
+ (checkPresent baser)
go Nothing = return False
rollback = void $ removeKey encr k
@@ -193,10 +193,10 @@ specialRemote' cfg c preparestorer prepareretriever baser = encr
enck = maybe id snd enc
remover = removeKey baser
- hasKeyGen k enc = hasKeyChunks checker (uuid baser) chunkconfig enck k
+ checkPresentGen k enc = checkPresentChunks checker (uuid baser) chunkconfig enck k
where
enck = maybe id snd enc
- checker = hasKey baser
+ checker = checkPresent baser
chunkconfig = chunkConfig cfg
diff --git a/Remote/Helper/Ssh.hs b/Remote/Helper/Ssh.hs
index 05a98865f..42d77ea59 100644
--- a/Remote/Helper/Ssh.hs
+++ b/Remote/Helper/Ssh.hs
@@ -81,14 +81,14 @@ onRemote r (with, errorval) command params fields = do
Nothing -> return errorval
{- Checks if a remote contains a key. -}
-inAnnex :: Git.Repo -> Key -> Annex (Either String Bool)
+inAnnex :: Git.Repo -> Key -> Annex Bool
inAnnex r k = do
showChecking r
onRemote r (check, cantCheck r) "inannex" [Param $ key2file k] []
where
check c p = dispatch <$> safeSystem c p
- dispatch ExitSuccess = Right True
- dispatch (ExitFailure 1) = Right False
+ dispatch ExitSuccess = True
+ dispatch (ExitFailure 1) = False
dispatch _ = cantCheck r
{- Removes a key from a remote. -}
diff --git a/Remote/Hook.hs b/Remote/Hook.hs
index efbd9f8ba..037f71ced 100644
--- a/Remote/Hook.hs
+++ b/Remote/Hook.hs
@@ -45,8 +45,8 @@ gen r u c gc = do
retrieveKeyFile = retreiveKeyFileDummy,
retrieveKeyFileCheap = retrieveCheap hooktype,
removeKey = remove hooktype,
- hasKey = checkPresent r hooktype,
- hasKeyCheap = False,
+ checkPresent = checkKey r hooktype,
+ checkPresentCheap = False,
whereisKey = Nothing,
remoteFsck = Nothing,
repairRepo = Nothing,
@@ -128,11 +128,11 @@ retrieveCheap _ _ _ = return False
remove :: HookName -> Key -> Annex Bool
remove h k = runHook h "remove" k Nothing $ return True
-checkPresent :: Git.Repo -> HookName -> Key -> Annex (Either String Bool)
-checkPresent r h k = do
+checkKey :: Git.Repo -> HookName -> Key -> Annex Bool
+checkKey r h k = do
showAction $ "checking " ++ Git.repoDescribe r
v <- lookupHook h action
- liftIO $ catchMsgIO $ check v
+ liftIO $ check v
where
action = "checkpresent"
findkey s = key2file k `elem` lines s
diff --git a/Remote/Rsync.hs b/Remote/Rsync.hs
index 421c451bd..91070fe84 100644
--- a/Remote/Rsync.hs
+++ b/Remote/Rsync.hs
@@ -12,7 +12,7 @@ module Remote.Rsync (
store,
retrieve,
remove,
- checkPresent,
+ checkKey,
withRsyncScratchDir,
genRsyncOpts,
RsyncOpts
@@ -66,8 +66,8 @@ gen r u c gc = do
, retrieveKeyFile = retreiveKeyFileDummy
, retrieveKeyFileCheap = retrieveCheap o
, removeKey = remove o
- , hasKey = checkPresent r o
- , hasKeyCheap = False
+ , checkPresent = checkKey r o
+ , checkPresentCheap = False
, whereisKey = Nothing
, remoteFsck = Nothing
, repairRepo = Nothing
@@ -214,14 +214,12 @@ remove o k = do
, dir </> keyFile k </> "***"
]
-checkPresent :: Git.Repo -> RsyncOpts -> Key -> Annex (Either String Bool)
-checkPresent r o k = do
+checkKey :: Git.Repo -> RsyncOpts -> Key -> Annex Bool
+checkKey r o k = do
showAction $ "checking " ++ Git.repoDescribe r
-- note: Does not currently differentiate between rsync failing
-- to connect, and the file not being present.
- Right <$> check
- where
- check = untilTrue (rsyncUrls o k) $ \u ->
+ untilTrue (rsyncUrls o k) $ \u ->
liftIO $ catchBoolIO $ do
withQuietOutput createProcessSuccess $
proc "rsync" $ toCommand $
diff --git a/Remote/S3.hs b/Remote/S3.hs
index 8603757eb..4c1f1ecfd 100644
--- a/Remote/S3.hs
+++ b/Remote/S3.hs
@@ -57,8 +57,8 @@ gen r u c gc = new <$> remoteCost gc expensiveRemoteCost
retrieveKeyFile = retreiveKeyFileDummy,
retrieveKeyFileCheap = retrieveCheap this,
removeKey = remove this c,
- hasKey = checkPresent this,
- hasKeyCheap = False,
+ checkPresent = checkKey this,
+ checkPresentCheap = False,
whereisKey = Nothing,
remoteFsck = Nothing,
repairRepo = Nothing,
@@ -167,16 +167,16 @@ remove' :: Remote -> Key -> Annex Bool
remove' r k = s3Action r False $ \(conn, bucket) ->
s3Bool =<< liftIO (deleteObject conn $ bucketKey r bucket k)
-checkPresent :: Remote -> Key -> Annex (Either String Bool)
-checkPresent r k = s3Action r noconn $ \(conn, bucket) -> do
+checkKey :: Remote -> Key -> Annex Bool
+checkKey r k = s3Action r noconn $ \(conn, bucket) -> do
showAction $ "checking " ++ name r
res <- liftIO $ getObjectInfo conn $ bucketKey r bucket k
case res of
- Right _ -> return $ Right True
- Left (AWSError _ _) -> return $ Right False
- Left e -> return $ Left (s3Error e)
+ Right _ -> return True
+ Left (AWSError _ _) -> return False
+ Left e -> s3Error e
where
- noconn = Left $ error "S3 not configured"
+ noconn = error "S3 not configured"
s3Warning :: ReqError -> Annex Bool
s3Warning e = do
diff --git a/Remote/Tahoe.hs b/Remote/Tahoe.hs
index d265d7ac1..6e52c0981 100644
--- a/Remote/Tahoe.hs
+++ b/Remote/Tahoe.hs
@@ -72,8 +72,8 @@ gen r u c gc = do
retrieveKeyFile = retrieve u hdl,
retrieveKeyFileCheap = \_ _ -> return False,
removeKey = remove,
- hasKey = checkPresent u hdl,
- hasKeyCheap = False,
+ checkPresent = checkKey u hdl,
+ checkPresentCheap = False,
whereisKey = Nothing,
remoteFsck = Nothing,
repairRepo = Nothing,
@@ -123,14 +123,16 @@ remove _k = do
warning "content cannot be removed from tahoe remote"
return False
-checkPresent :: UUID -> TahoeHandle -> Key -> Annex (Either String Bool)
-checkPresent u hdl k = go =<< getCapability u k
+checkKey :: UUID -> TahoeHandle -> Key -> Annex Bool
+checkKey u hdl k = go =<< getCapability u k
where
- go Nothing = return (Right False)
- go (Just cap) = liftIO $ parseCheck <$> readTahoe hdl "check"
- [ Param "--raw"
- , Param cap
- ]
+ go Nothing = return False
+ go (Just cap) = liftIO $ do
+ v <- parseCheck <$> readTahoe hdl "check"
+ [ Param "--raw"
+ , Param cap
+ ]
+ either error return v
defaultTahoeConfigDir :: UUID -> IO TahoeConfigDir
defaultTahoeConfigDir u = do
diff --git a/Remote/Web.hs b/Remote/Web.hs
index ddd1fc1cc..7bdd8d185 100644
--- a/Remote/Web.hs
+++ b/Remote/Web.hs
@@ -50,8 +50,8 @@ gen r _ c gc =
retrieveKeyFile = downloadKey,
retrieveKeyFileCheap = downloadKeyCheap,
removeKey = dropKey,
- hasKey = checkKey,
- hasKeyCheap = False,
+ checkPresent = checkKey,
+ checkPresentCheap = False,
whereisKey = Just getUrls,
remoteFsck = Nothing,
repairRepo = Nothing,
@@ -98,12 +98,12 @@ dropKey k = do
mapM_ (setUrlMissing k) =<< getUrls k
return True
-checkKey :: Key -> Annex (Either String Bool)
+checkKey :: Key -> Annex Bool
checkKey key = do
us <- getUrls key
if null us
- then return $ Right False
- else return =<< checkKey' key us
+ then return False
+ else either error return =<< checkKey' key us
checkKey' :: Key -> [URLString] -> Annex (Either String Bool)
checkKey' key us = firsthit us (Right False) $ \u -> do
let (u', downloader) = getDownloader u
diff --git a/Remote/WebDAV.hs b/Remote/WebDAV.hs
index 0bdd38360..f0bcac10e 100644
--- a/Remote/WebDAV.hs
+++ b/Remote/WebDAV.hs
@@ -63,8 +63,8 @@ gen r u c gc = new <$> remoteCost gc expensiveRemoteCost
retrieveKeyFile = retrieve this,
retrieveKeyFileCheap = retrieveCheap this,
removeKey = remove this,
- hasKey = checkPresent this,
- hasKeyCheap = False,
+ checkPresent = checkKey this,
+ checkPresentCheap = False,
whereisKey = Nothing,
remoteFsck = Nothing,
repairRepo = Nothing,
@@ -170,10 +170,10 @@ remove r k = davAction r False $ \(baseurl, user, pass) -> liftIO $ do
let url = davLocation baseurl k
isJust . eitherToMaybe <$> tryNonAsync (deleteDAV url user pass)
-checkPresent :: Remote -> Key -> Annex (Either String Bool)
-checkPresent r k = davAction r noconn go
+checkKey :: Remote -> Key -> Annex Bool
+checkKey r k = davAction r noconn (either error id <$$> go)
where
- noconn = Left $ error $ name r ++ " not configured"
+ noconn = error $ name r ++ " not configured"
go (baseurl, user, pass) = do
showAction $ "checking " ++ name r
diff --git a/Types/Remote.hs b/Types/Remote.hs
index 805b98474..b657cfcdc 100644
--- a/Types/Remote.hs
+++ b/Types/Remote.hs
@@ -68,12 +68,12 @@ data RemoteA a = Remote {
retrieveKeyFileCheap :: Key -> FilePath -> a Bool,
-- removes a key's contents (succeeds if the contents are not present)
removeKey :: Key -> a Bool,
- -- Checks if a key is present in the remote; if the remote
- -- cannot be accessed returns a Left error message.
- hasKey :: Key -> a (Either String Bool),
- -- Some remotes can check hasKey without an expensive network
+ -- Checks if a key is present in the remote.
+ -- Throws an exception if the remote cannot be accessed.
+ checkPresent :: Key -> a Bool,
+ -- Some remotes can checkPresent without an expensive network
-- operation.
- hasKeyCheap :: Bool,
+ checkPresentCheap :: Bool,
-- Some remotes can provide additional details for whereis.
whereisKey :: Maybe (Key -> a [String]),
-- Some remotes can run a fsck operation on the remote,
diff --git a/Types/StoreRetrieve.hs b/Types/StoreRetrieve.hs
index 9fc0634c4..a21fa7866 100644
--- a/Types/StoreRetrieve.hs
+++ b/Types/StoreRetrieve.hs
@@ -33,3 +33,11 @@ type Storer = Key -> ContentSource -> MeterUpdate -> Annex Bool
-- callback, which will fully consume the content before returning.
-- Throws exception if key is not present, or remote is not accessible.
type Retriever = Key -> MeterUpdate -> (ContentSource -> Annex Bool) -> Annex Bool
+
+-- Action that removes a Key's content from a remote.
+-- Succeeds if key is already not present; never throws exceptions.
+type Remover = Key -> Annex Bool
+
+-- Checks if a Key's content is present on a remote.
+-- Throws an exception if the remote is not accessible.
+type CheckPresent = Key -> Annex Bool
diff --git a/doc/design/assistant/chunks.mdwn b/doc/design/assistant/chunks.mdwn
index a9709a778..0aa389899 100644
--- a/doc/design/assistant/chunks.mdwn
+++ b/doc/design/assistant/chunks.mdwn
@@ -91,7 +91,7 @@ cannot tell when we've gotten the last chunk. (Also, we cannot strip
padding.) Note that `addurl` sometimes generates keys w/o size info
(particularly, it does so by design when using quvi).
-Problem: Also, this makes `hasKey` hard to implement: How can it know if
+Problem: Also, this makes `checkPresent` hard to implement: How can it know if
all the chunks are present, if the key size is not known?
Problem: Also, this makes it difficult to download encrypted keys, because
@@ -111,7 +111,7 @@ So, SHA256-1048576-c1--xxxxxxx for the first chunk of 1 megabyte.
Before any chunks are stored, write a chunkcount file, eg
SHA256-s12345-c0--xxxxxxx. Note that this key is the same as the original
object's key, except with chunk number set to 0. This file contains both
-the number of chunks, and also the chunk size used. `hasKey` downloads this
+the number of chunks, and also the chunk size used. `checkPresent` downloads this
file, and then verifies that each chunk is present, looking for keys with
the expected chunk numbers and chunk size.
@@ -126,7 +126,7 @@ Note: This design lets an attacker with logs tell the (appoximate) size of
objects, by finding the small files that contain a chunk count, and
correlating when that is written/read and when other files are
written/read. That could be solved by padding the chunkcount key up to the
-size of the rest of the keys, but that's very innefficient; `hasKey` is not
+size of the rest of the keys, but that's very innefficient; `checkPresent` is not
designed to need to download large files.
# design 3
@@ -139,7 +139,7 @@ This seems difficult; attacker could probably tell where the first encrypted
part stops and the next encrypted part starts by looking for gpg headers,
and so tell which files are the first chunks.
-Also, `hasKey` would need to download some or all of the first file.
+Also, `checkPresent` would need to download some or all of the first file.
If all, that's a lot more expensive. If only some is downloaded, an
attacker can guess that the file that was partially downloaded is the
first chunk in a series, and wait for a time when it's fully downloaded to
@@ -163,7 +163,7 @@ The location log does not record locations of individual chunk keys
(too space-inneficient). Instead, look at a chunk log in the
git-annex branch to get the chunk count and size for a key.
-`hasKey` would check if any of the logged sets of chunks is
+`checkPresent` would check if any of the logged sets of chunks is
present on the remote. It would also check if the non-chunked key is
present, as a fallback.
@@ -225,7 +225,7 @@ Reasons:
Note that this means that the chunks won't exactly match the configured
chunk size. gpg does compression, which might make them a
-lot smaller. Or gpg overhead could make them slightly larger. So `hasKey`
+lot smaller. Or gpg overhead could make them slightly larger. So `checkPresent`
cannot check exact file sizes.
If padding is enabled, gpg compression should be disabled, to not leak
@@ -250,10 +250,10 @@ and skip forward to the next needed chunk. Easy.
Uploads: Check if the 1st chunk is present. If so, check the second chunk,
etc. Once the first missing chunk is found, start uploading from there.
-That adds one extra hasKey call per upload. Probably a win in most cases.
+That adds one extra checkPresent call per upload. Probably a win in most cases.
Can be improved by making special remotes open a persistent
connection that is used for transferring all chunks, as well as for
-checking hasKey.
+checking checkPresent.
Note that this is safe to do only as long as the Key being transferred
cannot possibly have 2 different contents in different repos. Notably not
generated by cgit v1.2.3 (git 2.39.1) at 2024-06-29 00:04:08 +0000