Merge branch 'master' into s3-aws

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