aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorGravatar Joey Hess <joey@kitenet.net>2014-08-06 13:45:19 -0400
committerGravatar Joey Hess <joey@kitenet.net>2014-08-06 13:45:19 -0400
commitcc2606ce542e04c22cf229d536ad621f9e25c12d (patch)
tree27601f447942bcefbfcb89c6588f330d7580098c
parent5cd02fd1a52b3f1c19b01f4a021a7c63b96796dd (diff)
pushed checkPresent exception handling out of Remote implementations
I tend to prefer moving toward explicit exception handling, not away from it, but in this case, I think there are good reasons to let checkPresent throw exceptions: 1. They can all be caught in one place (Remote.hasKey), and we know every possible exception is caught there now, which we didn't before. 2. It simplified the code of the Remotes. I think it makes sense for Remotes to be able to be implemented without needing to worry about catching exceptions inside them. (Mostly.) 3. Types.StoreRetrieve.Preparer can only work on things that return a Bool, which all the other relevant remote methods already did. I do not see a good way to generalize that type; my previous attempts failed miserably.
-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