Adapt HighLevelTest to user-content host split

tests/HackageClientUtils.hs

@@ -52,7 +52,14 @@ withServerRunning root f
                            info "Finished with server")
 
 serverRunningArgs :: [String]
-serverRunningArgs = ["run", "--ip", "127.0.0.1", "--port", show testPort, "--delay-cache-updates", "0"]
+serverRunningArgs =
+  ["run", "--ip", "127.0.0.1"
+  , "--port", show testPort
+  , "--delay-cache-updates", "0"
+  , "--base-uri", "http://127.0.0.1:" <> show testPort
+  , "--user-content-uri", "http://localhost:" <> show testPort
+  , "--required-base-host-header", "127.0.0.1:" <> show testPort
+  ]
 
 waitForServer :: IO ()
 waitForServer = f 10
@@ -261,9 +268,15 @@ testPort = 8392
 mkUrl :: RelativeURL -> AbsoluteURL
 mkUrl relPath = "http://127.0.0.1:" ++ show testPort ++ relPath
 
+mkUserContentUrl :: RelativeURL -> AbsoluteURL
+mkUserContentUrl relPath = "http://localhost:" ++ show testPort ++ relPath
+
 mkGetReq :: RelativeURL -> Request_String
 mkGetReq url = getRequest (mkUrl url)
 
+mkGetUserContentReq :: RelativeURL -> Request_String
+mkGetUserContentReq url = getRequest (mkUserContentUrl url)
+
 mkPostReq :: RelativeURL -> [(String, String)] -> Request_String
 mkPostReq url vals =
   setRequestBody (postRequest (mkUrl url))
@@ -295,15 +308,27 @@ putRequest urlString =
 getUrl :: Authorization -> RelativeURL -> IO String
 getUrl auth url = Http.execRequest auth (mkGetReq url)
 
+getUserContentUrl :: Authorization -> RelativeURL -> IO String
+getUserContentUrl auth url = Http.execRequest auth (mkGetUserContentReq url)
+
 getETag :: RelativeURL -> IO String
 getETag url = Http.responseHeader HdrETag (mkGetReq url)
 
+getETagUserContent :: RelativeURL -> IO String
+getETagUserContent url = Http.responseHeader HdrETag (mkGetUserContentReq url)
+
 mkGetReqWithETag :: String -> RelativeURL -> Request_String
 mkGetReqWithETag url etag =
     Request (fromJust $ parseURI $ mkUrl url) GET hdrs ""
   where
     hdrs = [mkHeader HdrIfNoneMatch etag]
 
+mkGetUserContentReqWithETag :: String -> RelativeURL -> Request_String
+mkGetUserContentReqWithETag url etag =
+    Request (fromJust $ parseURI $ mkUserContentUrl url) GET hdrs ""
+  where
+    hdrs = [mkHeader HdrIfNoneMatch etag]
+
 validateETagHandling :: RelativeURL -> IO ()
 validateETagHandling url = void $ do
     etag <- getETag url
@@ -313,6 +338,15 @@ validateETagHandling url = void $ do
     checkETag etag = void $ Http.execRequest' NoAuth (mkGetReqWithETag url etag) isNotModified
     checkETagMismatch etag = void $ Http.execRequest NoAuth (mkGetReqWithETag url etag)
 
+validateETagHandlingUserContent :: RelativeURL -> IO ()
+validateETagHandlingUserContent url = void $ do
+    etag <- getETagUserContent url
+    checkETag etag
+    checkETagMismatch (etag ++ "garbled123")
+  where
+    checkETag etag = void $ Http.execRequest' NoAuth (mkGetUserContentReqWithETag url etag) isNotModified
+    checkETagMismatch etag = void $ Http.execRequest NoAuth (mkGetUserContentReqWithETag url etag)
+
 getJSONStrings :: RelativeURL -> IO [String]
 getJSONStrings url = getUrl NoAuth url >>= decodeJSON
 

tests/HighLevelTest.hs

@@ -243,11 +243,11 @@ runPackageTests = do
        unless (tarFile == testpackageTarFileContent) $
            die "Bad tar file"
     do info "Getting testpackage source"
-       hsFile <- getUrl NoAuth ("/package/testpackage/src" </> testpackageHaskellFilename)
+       hsFile <- getUserContentUrl NoAuth ("/package/testpackage/src" </> testpackageHaskellFilename)
        unless (hsFile == testpackageHaskellFileContent) $
            die "Bad Haskell file"
     do info "Getting testpackage source with etag"
-       validateETagHandling ("/package/testpackage/src" </> testpackageHaskellFilename)
+       validateETagHandlingUserContent ("/package/testpackage/src" </> testpackageHaskellFilename)
     do info "Getting testpackage maintainer info"
        xs <- getGroup "/package/testpackage/maintainers/.json"
        unless (map userName (groupMembers xs) == ["HackageTestUser1"]) $

tests/HttpUtils.hs

@@ -25,6 +25,8 @@ module HttpUtils (
 import Control.Exception
 import Control.Monad
 import Data.Maybe
+import Data.Text (unpack)
+import qualified Data.Text.Encoding as Enc
 import Network.HTTP hiding (user)
 import Network.HTTP.Auth
 import Data.Aeson (Result(..), Value(..), FromJSON(..), (.:), fromJSON)
@@ -242,7 +244,19 @@ jsonHandler :: FromJSON a
             -> Streams.InputStream BS.ByteString
             -> IO a
 jsonHandler _ i = do
-    v <- Streams.parseFromStream json' i
-    case fromJSON v of
-      (Success a) -> return a
-      (Error str) -> fail str
+    -- Note that this might not read the _whole_ input
+    -- But the beginning is often good enough for diagnosing the failure
+    mbByteString <- Streams.read i
+    forM_ mbByteString $ \bs -> Streams.unRead bs i
+    eitherV <- try $ Streams.parseFromStream json' i
+    case fromJSON <$> eitherV of
+      Left ex -> do
+        let
+          _ex :: SomeException
+          _ex = ex
+        forM_ mbByteString $ \bs ->
+          forM_ (Enc.decodeUtf8' bs) $ \text ->
+            putStrLn (unpack text)
+        fail "Response was not JSON"
+      Right (Success a) -> return a
+      Right (Error str) -> fail str