diff options
Diffstat (limited to 'Remote')
| -rw-r--r-- | Remote/Bup.hs | 8 | ||||
| -rw-r--r-- | Remote/Directory.hs | 8 | ||||
| -rw-r--r-- | Remote/Git.hs | 36 | ||||
| -rw-r--r-- | Remote/Hook.hs | 6 | ||||
| -rw-r--r-- | Remote/Rsync.hs | 2 | ||||
| -rw-r--r-- | Remote/S3real.hs | 2 | ||||
| -rw-r--r-- | Remote/Web.hs | 2 |
7 files changed, 45 insertions, 19 deletions
diff --git a/Remote/Bup.hs b/Remote/Bup.hs index b8d7cd317..866d4b42d 100644 --- a/Remote/Bup.hs +++ b/Remote/Bup.hs @@ -139,17 +139,21 @@ remove _ = 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 IOException Bool) +checkPresent :: Git.Repo -> Git.Repo -> Key -> Annex (Either String Bool) checkPresent r bupr k | Git.repoIsUrl bupr = do showAction $ "checking " ++ Git.repoDescribe r ok <- onBupRemote bupr boolSystem "git" params return $ Right ok - | otherwise = liftIO $ try $ boolSystem "git" $ Git.gitCommandLine params bupr + | otherwise = dispatch <$> localcheck where params = [ Params "show-ref --quiet --verify" , Param $ "refs/heads/" ++ show k] + localcheck = liftIO $ try $ + boolSystem "git" $ Git.gitCommandLine params bupr + dispatch (Left e) = Left $ show e + dispatch (Right v) = Right v {- Store UUID in the annex.uuid setting of the bup repository. -} storeBupUUID :: UUID -> BupRepo -> Annex () diff --git a/Remote/Directory.hs b/Remote/Directory.hs index 8e306e228..6d3a5da7d 100644 --- a/Remote/Directory.hs +++ b/Remote/Directory.hs @@ -114,5 +114,9 @@ remove d k = liftIO $ catchBool $ do file = dirKey d k dir = parentDir file -checkPresent :: FilePath -> Key -> Annex (Either IOException Bool) -checkPresent d k = liftIO $ try $ doesFileExist (dirKey d k) +checkPresent :: FilePath -> Key -> Annex (Either String Bool) +checkPresent d k = dispatch <$> check + where + check = liftIO $ try $ doesFileExist (dirKey d k) + dispatch (Left e) = Left $ show e + dispatch (Right v) = Right v diff --git a/Remote/Git.hs b/Remote/Git.hs index 75f0ac757..b63a8f124 100644 --- a/Remote/Git.hs +++ b/Remote/Git.hs @@ -125,22 +125,38 @@ tryGitConfigRead r else old : exchange ls new {- Checks if a given remote has the content for a key inAnnex. - - If the remote cannot be accessed, returns a Left error. + - If the remote cannot be accessed, or if it cannot determine + - whether it has the content, returns a Left error message. -} -inAnnex :: Git.Repo -> Key -> Annex (Either IOException Bool) +inAnnex :: Git.Repo -> Key -> Annex (Either String Bool) inAnnex r key - | Git.repoIsHttp r = safely checkhttp + | Git.repoIsHttp r = checkhttp | Git.repoIsUrl r = checkremote - | otherwise = safely checklocal + | otherwise = checklocal where - checklocal = onLocal r $ Annex.Content.inAnnex key + checkhttp = dispatch <$> check + where + check = safely $ Url.exists $ keyUrl r key + dispatch (Left e) = Left $ show e + dispatch (Right v) = Right v checkremote = do showAction $ "checking " ++ Git.repoDescribe r - inannex <- onRemote r (boolSystem, False) "inannex" - [Param (show key)] - return $ Right inannex - checkhttp = Url.exists $ keyUrl r key - safely a = liftIO (try a ::IO (Either IOException Bool)) + onRemote r (check, unknown) "inannex" [Param (show key)] + where + check c p = dispatch <$> safeSystem c p + dispatch ExitSuccess = Right True + dispatch (ExitFailure 1) = Right False + dispatch _ = unknown + checklocal = dispatch <$> check + where + check = safely $ onLocal r $ + Annex.Content.inAnnexSafe key + dispatch (Left e) = Left $ show e + dispatch (Right (Just b)) = Right b + dispatch (Right Nothing) = unknown + safely :: IO a -> Annex (Either IOException a) + safely a = liftIO $ try a + unknown = Left $ "unable to check " ++ Git.repoDescribe r {- Runs an action on a local repository inexpensively, by making an annex - monad using that repository. -} diff --git a/Remote/Hook.hs b/Remote/Hook.hs index 06568a3cb..9f9250e41 100644 --- a/Remote/Hook.hs +++ b/Remote/Hook.hs @@ -119,14 +119,16 @@ retrieveEncrypted h (cipher, enck) f = withTmp enck $ \tmp -> remove :: String -> Key -> Annex Bool remove h k = runHook h "remove" k Nothing $ return True -checkPresent :: Git.Repo -> String -> Key -> Annex (Either IOException Bool) +checkPresent :: Git.Repo -> String -> Key -> Annex (Either String Bool) checkPresent r h k = do showAction $ "checking " ++ Git.repoDescribe r v <- lookupHook h "checkpresent" - liftIO (try (check v) ::IO (Either IOException Bool)) + dispatch <$> liftIO (try (check v) ::IO (Either IOException Bool)) where findkey s = show k `elem` lines s env = hookEnv k Nothing + dispatch (Left e) = Left $ show e + dispatch (Right v) = Right v check Nothing = error "checkpresent hook misconfigured" check (Just hook) = do (frompipe, topipe) <- createPipe diff --git a/Remote/Rsync.hs b/Remote/Rsync.hs index 0dfad7293..54834be13 100644 --- a/Remote/Rsync.hs +++ b/Remote/Rsync.hs @@ -128,7 +128,7 @@ remove o k = withRsyncScratchDir $ \tmp -> do , Param $ rsyncKeyDir o k ] -checkPresent :: Git.Repo -> RsyncOpts -> Key -> Annex (Either IOException Bool) +checkPresent :: Git.Repo -> RsyncOpts -> Key -> Annex (Either String Bool) checkPresent r o k = do showAction $ "checking " ++ Git.repoDescribe r -- note: Does not currently differnetiate between rsync failing diff --git a/Remote/S3real.hs b/Remote/S3real.hs index b201b5aad..29117b3a4 100644 --- a/Remote/S3real.hs +++ b/Remote/S3real.hs @@ -172,7 +172,7 @@ remove r k = s3Action r False $ \(conn, bucket) -> do res <- liftIO $ deleteObject conn $ bucketKey r bucket k s3Bool res -checkPresent :: Remote Annex -> Key -> Annex (Either IOException Bool) +checkPresent :: Remote Annex -> Key -> Annex (Either String Bool) checkPresent r k = s3Action r noconn $ \(conn, bucket) -> do showAction $ "checking " ++ name r res <- liftIO $ getObjectInfo conn $ bucketKey r bucket k diff --git a/Remote/Web.hs b/Remote/Web.hs index da7f38472..64fcd51aa 100644 --- a/Remote/Web.hs +++ b/Remote/Web.hs @@ -64,7 +64,7 @@ dropKey _ = do warning "removal from web not supported" return False -checkKey :: Key -> Annex (Either IOException Bool) +checkKey :: Key -> Annex (Either String Bool) checkKey key = do us <- getUrls key if null us |