Support checking presence of content at a http url that redirects to a ftp url.

5 files changed, 57 insertions, 21 deletions

diff --git a/CHANGELOG b/CHANGELOG
index f1548c711..901d7a04a 100644
--- a/CHANGELOG
+++ b/CHANGELOG
@@ -18,6 +18,8 @@ git-annex (6.20160614) UNRELEASED; urgency=medium
   * uninit: Fix crash due to trying to write to deleted keys db.
     Reversion introduced by v6 mode support, affects v5 too.
   * Fix a similar crash when the webapp is used to delete a repository.
+  * Support checking presence of content at a http url that redirects to
+    a ftp url.
 
  -- Joey Hess <id@joeyh.name>  Mon, 13 Jun 2016 21:52:24 -0400
 
diff --git a/Remote/WebDAV.hs b/Remote/WebDAV.hs
index dd0ff5768..3de8b357e 100644
--- a/Remote/WebDAV.hs
+++ b/Remote/WebDAV.hs
@@ -30,7 +30,7 @@ import Remote.Helper.Http
 import qualified Remote.Helper.Chunked.Legacy as Legacy
 import Creds
 import Utility.Metered
-import Utility.Url (URLString)
+import Utility.Url (URLString, matchStatusCodeException)
 import Annex.UUID
 import Remote.WebDAV.DavLocation
 
@@ -270,12 +270,6 @@ existsDAV l = inLocation l check `catchNonAsync` (\e -> return (Left $ show e))
 			(const $ ispresent False)
 	ispresent = return . Right
 
-matchStatusCodeException :: (Status -> Bool) -> HttpException -> Maybe HttpException
-matchStatusCodeException want e@(StatusCodeException s _ _)
-	| want s = Just e
-	| otherwise = Nothing
-matchStatusCodeException _ _ = Nothing
-
 -- Ignores any exceptions when performing a DAV action.
 safely :: DAVT IO a -> DAVT IO (Maybe a)
 safely = eitherToMaybe <$$> tryNonAsync
diff --git a/Utility/Url.hs b/Utility/Url.hs
index 1e1f14cb8..97536f7cf 100644
--- a/Utility/Url.hs
+++ b/Utility/Url.hs
@@ -25,7 +25,8 @@ module Utility.Url (
 	assumeUrlExists,
 	download,
 	downloadQuiet,
-	parseURIRelaxed
+	parseURIRelaxed,
+	matchStatusCodeException,
 ) where
 
 import Common
@@ -126,6 +127,7 @@ data UrlInfo = UrlInfo
 	, urlSize :: Maybe Integer
 	, urlSuggestedFile :: Maybe FilePath
 	}
+	deriving (Show)
 
 assumeUrlExists :: UrlInfo
 assumeUrlExists = UrlInfo True Nothing Nothing
@@ -135,7 +137,14 @@ assumeUrlExists = UrlInfo True Nothing Nothing
 getUrlInfo :: URLString -> UrlOptions -> IO UrlInfo
 getUrlInfo url uo = case parseURIRelaxed url of
 	Just u -> case parseUrl (show u) of
-		Just req -> existsconduit req `catchNonAsync` const dne
+		Just req -> catchJust
+			-- When http redirects to a protocol which 
+			-- conduit does not support, it will throw
+			-- a StatusCodeException with found302.
+			(matchStatusCodeException (== found302))
+			(existsconduit req)
+			(const (existscurl u))
+			`catchNonAsync` (const dne)
 		-- http-conduit does not support file:, ftp:, etc urls,
 		-- so fall back to reading files and using curl.
 		Nothing
@@ -147,18 +156,7 @@ getUrlInfo url uo = case parseURIRelaxed url of
 						sz <- getFileSize' f stat
 						found (Just sz) Nothing
 					Nothing -> dne
-			| Build.SysConfig.curl -> do
-				output <- catchDefaultIO "" $
-					readProcess "curl" $ toCommand curlparams
-				let len = extractlencurl output
-				let good = found len Nothing
-				case lastMaybe (lines output) of
-					Just ('2':_:_) -> good
-					-- don't try to parse ftp status
-					-- codes; if curl got a length,
-					-- it's good
-					_ | "ftp" `isInfixOf` uriScheme u && isJust len -> good
-					_ -> dne
+			| Build.SysConfig.curl -> existscurl u
 			| otherwise -> dne
 	Nothing -> dne
   where
@@ -201,6 +199,23 @@ getUrlInfo url uo = case parseURIRelaxed url of
 		liftIO $ closeManager mgr
 		return ret
 
+	existscurl u = do
+		output <- catchDefaultIO "" $
+			readProcess "curl" $ toCommand curlparams
+		let len = extractlencurl output
+		let good = found len Nothing
+		let isftp = or
+			[ "ftp" `isInfixOf` uriScheme u
+			-- Check to see if http redirected to ftp.
+			, "Location: ftp://" `isInfixOf` output
+			]
+		case lastMaybe (lines output) of
+			Just ('2':_:_) -> good
+			-- don't try to parse ftp status codes; if curl
+			-- got a length, it's good
+			_ | isftp && isJust len -> good
+			_ -> dne
+
 -- Parse eg: attachment; filename="fname.ext"
 -- per RFC 2616
 contentDispositionFilename :: String -> Maybe FilePath
@@ -324,3 +339,13 @@ hContentLength = "Content-Length"
 hUserAgent :: CI.CI B.ByteString
 hUserAgent = "User-Agent"
 #endif
+
+{- Use with eg:
+ -
+ - > catchJust (matchStatusCodeException (== notFound404))
+ -}
+matchStatusCodeException :: (Status -> Bool) -> HttpException -> Maybe HttpException
+matchStatusCodeException want e@(StatusCodeException s _ _)
+	| want s = Just e
+	| otherwise = Nothing
+matchStatusCodeException _ _ = Nothing
diff --git a/doc/bugs/annex_drop_fails_to_determine_availability_on_a_http_url_redirecting_to_ftp.mdwn b/doc/bugs/annex_drop_fails_to_determine_availability_on_a_http_url_redirecting_to_ftp.mdwn
index d25f01624..9ecab381f 100644
--- a/doc/bugs/annex_drop_fails_to_determine_availability_on_a_http_url_redirecting_to_ftp.mdwn
+++ b/doc/bugs/annex_drop_fails_to_determine_availability_on_a_http_url_redirecting_to_ftp.mdwn
@@ -127,3 +127,5 @@ Logging in as anonymous ...
 """]]
 
 [[!meta author=yoh]]
+
+> [[fixed|done]] --[[Joey]]
diff --git a/doc/bugs/annex_drop_fails_to_determine_availability_on_a_http_url_redirecting_to_ftp/comment_1_b16b58ac5180be6c7f61a1cf8de55663._comment b/doc/bugs/annex_drop_fails_to_determine_availability_on_a_http_url_redirecting_to_ftp/comment_1_b16b58ac5180be6c7f61a1cf8de55663._comment
new file mode 100644
index 000000000..54a670b99
--- /dev/null
+++ b/doc/bugs/annex_drop_fails_to_determine_availability_on_a_http_url_redirecting_to_ftp/comment_1_b16b58ac5180be6c7f61a1cf8de55663._comment
@@ -0,0 +1,13 @@
+[[!comment format=mdwn
+ username="joey"
+ subject="""comment 1"""
+ date="2016-07-12T20:00:49Z"
+ content="""
+This only affects http to ftp redirects, because there's a special hack
+in place to use curl to check if a ftp url exists.
+
+Seems that http-conduit throws a StatusCodeException with statusCode = 302
+when it is redirected to a protocol that it does not support, such as ftp.
+
+So, it can catch that exception and fall back to curl.
+"""]]