diff options
Diffstat (limited to 'Remote')
| -rw-r--r-- | Remote/GCrypt.hs | 6 | ||||
| -rw-r--r-- | Remote/Git.hs | 23 | ||||
| -rw-r--r-- | Remote/Helper/Git.hs | 6 | ||||
| -rw-r--r-- | Remote/WebDAV.hs | 23 |
4 files changed, 36 insertions, 22 deletions
diff --git a/Remote/GCrypt.hs b/Remote/GCrypt.hs index 8891977f7..5edb3d022 100644 --- a/Remote/GCrypt.hs +++ b/Remote/GCrypt.hs @@ -306,7 +306,7 @@ setGcryptEncryption c remotename = do store :: Remote -> Remote.Rsync.RsyncOpts -> Storer store r rsyncopts | not $ Git.repoIsUrl (repo r) = - byteStorer $ \k b p -> guardUsable (repo r) False $ liftIO $ do + byteStorer $ \k b p -> guardUsable (repo r) (return False) $ liftIO $ do let tmpdir = Git.repoLocation (repo r) </> "tmp" </> keyFile k void $ tryIO $ createDirectoryIfMissing True tmpdir let tmpf = tmpdir </> keyFile k @@ -323,7 +323,7 @@ store r rsyncopts retrieve :: Remote -> Remote.Rsync.RsyncOpts -> Retriever retrieve r rsyncopts | not $ Git.repoIsUrl (repo r) = byteRetriever $ \k sink -> - guardUsable (repo r) False $ + guardUsable (repo r) (return False) $ sink =<< liftIO (L.readFile $ gCryptLocation r k) | Git.repoIsSsh (repo r) = if isShell r then fileRetriever $ \f k p -> @@ -335,7 +335,7 @@ retrieve r rsyncopts remove :: Remote -> Remote.Rsync.RsyncOpts -> Remover remove r rsyncopts k - | not $ Git.repoIsUrl (repo r) = guardUsable (repo r) False $ + | not $ Git.repoIsUrl (repo r) = guardUsable (repo r) (return False) $ liftIO $ Remote.Directory.removeDirGeneric (Git.repoLocation (repo r)) (parentDir (gCryptLocation r k)) | Git.repoIsSsh (repo r) = shellOrRsync r removeshell removersync | otherwise = unsupportedUrl diff --git a/Remote/Git.hs b/Remote/Git.hs index 34c60d98f..20955ff5b 100644 --- a/Remote/Git.hs +++ b/Remote/Git.hs @@ -319,14 +319,15 @@ keyUrls r key = map tourl locs' dropKey :: Remote -> Key -> Annex Bool dropKey r key | not $ Git.repoIsUrl (repo r) = - guardUsable (repo r) False $ commitOnCleanup r $ onLocal r $ do - ensureInitialized - whenM (Annex.Content.inAnnex key) $ do - Annex.Content.lockContent key $ - Annex.Content.removeAnnex key - logStatus key InfoMissing - Annex.Content.saveState True - return True + guardUsable (repo r) (return False) $ + commitOnCleanup r $ onLocal r $ do + ensureInitialized + whenM (Annex.Content.inAnnex key) $ do + Annex.Content.lockContent key $ + Annex.Content.removeAnnex key + logStatus key InfoMissing + Annex.Content.saveState True + return True | Git.repoIsHttp (repo r) = error "dropping from http remote not supported" | otherwise = commitOnCleanup r $ Ssh.dropKey (repo r) key @@ -335,7 +336,7 @@ copyFromRemote :: Remote -> Key -> AssociatedFile -> FilePath -> MeterUpdate -> copyFromRemote r key file dest _p = copyFromRemote' r key file dest copyFromRemote' :: Remote -> Key -> AssociatedFile -> FilePath -> Annex Bool copyFromRemote' r key file dest - | not $ Git.repoIsUrl (repo r) = guardUsable (repo r) False $ do + | not $ Git.repoIsUrl (repo r) = guardUsable (repo r) (return False) $ do params <- Ssh.rsyncParams r Download u <- getUUID -- run copy from perspective of remote @@ -409,7 +410,7 @@ copyFromRemote' r key file dest copyFromRemoteCheap :: Remote -> Key -> FilePath -> Annex Bool #ifndef mingw32_HOST_OS copyFromRemoteCheap r key file - | not $ Git.repoIsUrl (repo r) = guardUsable (repo r) False $ do + | not $ Git.repoIsUrl (repo r) = guardUsable (repo r) (return False) $ do loc <- liftIO $ gitAnnexLocation key (repo r) $ fromJust $ remoteGitConfig $ gitconfig r liftIO $ catchBoolIO $ createSymbolicLink loc file >> return True @@ -427,7 +428,7 @@ copyFromRemoteCheap _ _ _ = return False copyToRemote :: Remote -> Key -> AssociatedFile -> MeterUpdate -> Annex Bool copyToRemote r key file p | not $ Git.repoIsUrl (repo r) = - guardUsable (repo r) False $ commitOnCleanup r $ + guardUsable (repo r) (return False) $ commitOnCleanup r $ copylocal =<< Annex.Content.prepSendAnnex key | Git.repoIsSsh (repo r) = commitOnCleanup r $ Annex.Content.sendAnnex key noop $ \object -> do diff --git a/Remote/Helper/Git.hs b/Remote/Helper/Git.hs index d76cb2ee7..b405fd358 100644 --- a/Remote/Helper/Git.hs +++ b/Remote/Helper/Git.hs @@ -26,7 +26,7 @@ availabilityCalc r {- Avoids performing an action on a local repository that's not usable. - Does not check that the repository is still available on disk. -} -guardUsable :: Git.Repo -> a -> Annex a -> Annex a -guardUsable r onerr a - | Git.repoIsLocalUnknown r = return onerr +guardUsable :: Git.Repo -> Annex a -> Annex a -> Annex a +guardUsable r fallback a + | Git.repoIsLocalUnknown r = fallback | otherwise = a diff --git a/Remote/WebDAV.hs b/Remote/WebDAV.hs index d344e0a74..4d5887c6c 100644 --- a/Remote/WebDAV.hs +++ b/Remote/WebDAV.hs @@ -255,14 +255,14 @@ existsDAV l = inLocation l check `catchNonAsync` (\e -> return (Left $ show e)) check = do setDepth Nothing catchJust - (matchStatusCodeException notFound404) + (matchStatusCodeException (== notFound404)) (getPropsM >> ispresent True) (const $ ispresent False) ispresent = return . Right -matchStatusCodeException :: Status -> HttpException -> Maybe () -matchStatusCodeException want (StatusCodeException s _ _) - | s == want = Just () +matchStatusCodeException :: (Status -> Bool) -> HttpException -> Maybe HttpException +matchStatusCodeException want e@(StatusCodeException s _ _) + | want s = Just e | otherwise = Nothing matchStatusCodeException _ _ = Nothing @@ -289,12 +289,25 @@ withDAVHandle r a = do _ -> a Nothing goDAV :: DavHandle -> DAVT IO a -> IO a -goDAV (DavHandle ctx user pass _) a = choke $ run $ do +goDAV (DavHandle ctx user pass _) a = choke $ run $ prettifyExceptions $ do prepDAV user pass a where run = fst <$$> runDAVContext ctx +{- Catch StatusCodeException and trim it to only the statusMessage part, + - eliminating a lot of noise, which can include the whole request that + - failed. The rethrown exception is no longer a StatusCodeException. -} +prettifyExceptions :: DAVT IO a -> DAVT IO a +prettifyExceptions a = catchJust (matchStatusCodeException (const True)) a go + where + go (StatusCodeException status _ _) = error $ unwords + [ "DAV failure:" + , show (statusCode status) + , show (statusMessage status) + ] + go e = throwM e + prepDAV :: DavUser -> DavPass -> DAVT IO () prepDAV user pass = do setResponseTimeout Nothing -- disable default (5 second!) timeout |