work around Network.Browser bug that converts a HEAD to a GET when following a redirect

The code explicitly switches from HEAD to GET for most redirects.
Possibly because someone misread a spec (which does require switching from
POST to GET for 303 redirects). Or possibly because the spec really is that
bad. Upstream bug: https://github.com/haskell/HTTP/issues/24

Since we absolutely don't want to download entire (large) files from
the web when checking that they exist with HEAD, I wrote my own redirect
follower, based closely on the one used by Network.Browser, but without
this misfeature.

Note that Network.Browser checks that the redirect url is a http url
and fails if not. I don't, because I want to not need to change this
code when it gets https support (related: I'm surprised to see it
doesn't support https yet..). The check does not seem security significant;
it doesn't support file:// urls for example. If a http url is redirected
to https, the Network.Browser will actually make a http connection again.
This could loop, but only up to 5 times.

1 files changed, 27 insertions, 6 deletions

diff --git a/Utility/Url.hs b/Utility/Url.hs
index efd6ad16d..dfdebaf06 100644
--- a/Utility/Url.hs
+++ b/Utility/Url.hs
@@ -19,6 +19,7 @@ import Control.Monad
 import qualified Network.Browser as Browser
 import Network.HTTP
 import Network.URI
+import Data.Maybe
 
 import Utility.SafeCommand
 import Utility.Path
@@ -87,12 +88,32 @@ get url =
 
 {- Makes a http request of an url. For example, HEAD can be used to
  - check if the url exists, or GET used to get the url content (best for
- - small urls). -}
+ - small urls).
+ -
+ - This does its own redirect following because Browser's is buggy for HEAD
+ - requests.
+ -}
 request :: URI -> RequestMethod -> IO (Response String)
-request url requesttype = Browser.browse $ do
-	Browser.setErrHandler ignore
-	Browser.setOutHandler ignore
-	Browser.setAllowRedirects True
-	snd <$> Browser.request (mkRequest requesttype url :: Request_String)
+request url requesttype = go 5 url
 	where
+		go :: Int -> URI -> IO (Response String)
+		go 0 _ = error "Too many redirects "
+		go n u = do
+			rsp <- Browser.browse $ do
+				Browser.setErrHandler ignore
+				Browser.setOutHandler ignore
+				Browser.setAllowRedirects False
+				snd <$> Browser.request (mkRequest requesttype u :: Request_String)
+			case rspCode rsp of
+				(3,0,x) | x /= 5 -> redir (n - 1) u rsp
+				_ -> return rsp
 		ignore = const $ return ()
+		redir n u rsp = do
+			case retrieveHeaders HdrLocation rsp of
+				[] -> return rsp
+				(Header _ newu:_) ->
+					case parseURIReference newu of
+						Nothing -> return rsp
+						Just newURI -> go n newURI_abs
+							where
+								newURI_abs = fromMaybe newURI (newURI `relativeTo` u)