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.
This commit is contained in:
parent
781833b16f
commit
b4cf22a388
24 changed files with 167 additions and 163 deletions
|
@ -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"
|
||||
|
|
|
@ -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 ':'
|
||||
|
|
|
@ -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"
|
||||
)
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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'
|
||||
|
|
|
@ -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.)"
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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)
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
||||
|
|
|
@ -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. -}
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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 $
|
||||
|
|
16
Remote/S3.hs
16
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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
Loading…
Add table
Add a link
Reference in a new issue