Fixed compiling tests.

Network/Wreq/Session.hs

@@ -109,11 +109,11 @@ withSessionControl :: Maybe HTTP.CookieJar
                -> (Session -> IO a) -> IO a
 withSessionControl mj settings act = do
   mref <- maybe (return Nothing) (fmap Just . newIORef) mj
-  HTTP.withManager settings $ \mgr ->
-    act Session { seshCookies = mref
-                , seshManager = mgr
-                , seshRun = runWith
-                }
+  mgr <- HTTP.newManager settings
+  act Session { seshCookies = mref
+              , seshManager = mgr
+              , seshRun = runWith
+              }
 
 -- | 'Session'-specific version of 'Network.Wreq.get'.
 get :: Session -> String -> IO (Response L.ByteString)

tests/UnitTests.hs

@@ -8,7 +8,7 @@ module UnitTests (testWith) where
 import Control.Applicative ((<$>))
 import Control.Concurrent (forkIO, killThread)
 import Control.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar)
-import Control.Exception (Exception, toException)
+import Control.Exception (Exception, throwIO)
 import Control.Lens ((^.), (^?), (.~), (?~), (&))
 import Control.Monad (unless, void)
 import Data.Aeson
@@ -18,8 +18,8 @@ import Data.Char (toUpper)
 import Data.Maybe (isJust)
 import Data.Monoid ((<>))
 import HttpBin.Server (serve)
-import Network.HTTP.Client (HttpException(..))
-import Network.HTTP.Types.Status (Status(Status), status200, status401)
+import Network.HTTP.Client (HttpException(..), HttpExceptionContent(..))
+import Network.HTTP.Types.Status (status200, status401)
 import Network.HTTP.Types.Version (http11)
 import Network.Wreq hiding
   (get, post, head_, put, options, delete,
@@ -41,13 +41,13 @@ import qualified Network.Wreq as Wreq
 data Verb = Verb {
     get :: String -> IO (Response L.ByteString)
   , getWith :: Options -> String -> IO (Response L.ByteString)
-  , post :: Postable a => String -> a -> IO (Response L.ByteString)
-  , postWith :: Postable a => Options -> String -> a
+  , post :: forall a. Postable a => String -> a -> IO (Response L.ByteString)
+  , postWith :: forall a. Postable a => Options -> String -> a
              -> IO (Response L.ByteString)
   , head_ :: String -> IO (Response ())
   , headWith :: Options -> String -> IO (Response ())
-  , put :: Putable a => String -> a -> IO (Response L.ByteString)
-  , putWith :: Putable a => Options -> String -> a -> IO (Response L.ByteString)
+  , put :: forall a. Putable a => String -> a -> IO (Response L.ByteString)
+  , putWith :: forall a. Putable a => Options -> String -> a -> IO (Response L.ByteString)
   , options :: String -> IO (Response ())
   , optionsWith :: Options -> String -> IO (Response ())
   , delete :: String -> IO (Response L.ByteString)
@@ -155,18 +155,21 @@ basicDelete Verb{..} site = do
 throwsStatusCode Verb{..} site =
     assertThrows "404 causes exception to be thrown" inspect $
     head_ (site "/status/404")
-  where inspect e = case e of
-                      StatusCodeException _ _ _ -> return ()
+  where inspect (HttpExceptionRequest _ e) = case e of
+                      StatusCodeException _ _ -> return ()
                       _ -> assertFailure "unexpected exception thrown"
+        inspect _ = assertFailure "unexpected exception thrown"
 
 getBasicAuth Verb{..} site = do
   let opts = defaults & auth ?~ basicAuth "user" "passwd"
   r <- getWith opts (site "/basic-auth/user/passwd")
   assertEqual "basic auth GET succeeds" status200 (r ^. responseStatus)
-  let inspect e = case e of
-                    StatusCodeException status _ _ ->
+  let inspect (HttpExceptionRequest _ e) = case e of
+                    StatusCodeException resp _ ->
                       assertEqual "basic auth failed GET gives 401"
-                        status401 status
+                        status401 (resp ^. responseStatus)
+      inspect _ = assertFailure "unexpected exception thrown"
+
   assertThrows "basic auth GET fails if password is bad" inspect $
     getWith opts (site "/basic-auth/user/asswd")
 
@@ -175,10 +178,11 @@ getOAuth2 Verb{..} kind ctor site = do
   r <- getWith opts (site $ "/oauth2/" <> kind <> "/token1234")
   assertEqual ("oauth2 " <> kind <> " GET succeeds")
     status200 (r ^. responseStatus)
-  let inspect e = case e of
-                    StatusCodeException status _ _ ->
+  let inspect (HttpExceptionRequest _ e) = case e of
+                    StatusCodeException resp _ ->
                       assertEqual ("oauth2 " <> kind <> " failed GET gives 401")
-                        status401 status
+                        status401 (resp ^. responseStatus)
+      inspect _ = assertFailure "unexpected exception thrown"
   assertThrows ("oauth2 " <> kind <> " GET fails if token is bad") inspect $
     getWith opts (site $ "/oauth2/" <> kind <> "/token123")
 
@@ -212,44 +216,51 @@ getHeaders Verb{..} site = do
     (r ^. responseBody ^? key "headers" . key "X-Wibble")
 
 getCheckStatus Verb {..} site = do
-  let opts = defaults & checkStatus .~ (Just customCs)
+  let opts = defaults & checkResponse .~ Just customRc
   r <- getWith opts (site "/status/404")
   assertThrows "Non 404 throws error" inspect $
     getWith opts (site "/get")
   assertEqual "Status 404"
     404
     (r ^. responseStatus . statusCode)
   where
-    customCs (Status 404 _) _ _ = Nothing
-    customCs s h cj             = Just . toException . StatusCodeException s h $ cj
+    customRc :: ResponseChecker
+    customRc _ resp
+        | resp ^. responseStatus . statusCode == 404 = return ()
+    customRc req resp = throwIO $ HttpExceptionRequest req (StatusCodeException (void resp) "")
+
+    inspect (HttpExceptionRequest _ e) = case e of
+        (StatusCodeException resp _) ->
+            assertEqual "200 Status Error" (resp ^. responseStatus) status200
+    inspect _ = assertFailure "unexpected exception thrown"
 
-    inspect e = case e of
-      (StatusCodeException (Status sc _) _ _) ->
-        assertEqual "200 Status Error" sc 200
 
 getGzip Verb{..} site = do
   r <- get (site "/gzip")
   assertEqual "gzip decoded for us" (Just (Bool True))
     (r ^. responseBody ^? key "gzipped")
 
-headRedirect Verb{..} site =
+headRedirect Verb{..} site = do
   assertThrows "HEAD of redirect throws exception" inspect $
     head_ (site "/redirect/3")
-  where inspect e = case e of
-                      StatusCodeException status _ _ ->
-                        let code = status ^. statusCode
+  where inspect (HttpExceptionRequest _ e) = case e of
+                      StatusCodeException resp _ ->
+                        let code = resp ^. responseStatus . statusCode
                         in assertBool "code is redirect"
                            (code >= 300 && code < 400)
+        inspect _ = assertFailure "unexpected exception thrown"
+
 
 redirectOverflow Verb{..} site =
   assertThrows "GET with too many redirects throws exception" inspect $
     getWith (defaults & redirects .~ 3) (site "/redirect/5")
-  where inspect e = case e of TooManyRedirects _ -> return ()
+  where inspect (HttpExceptionRequest _ e) = case e of TooManyRedirects _ -> return ()
+        inspect _ = assertFailure "unexpected exception thrown"
 
 invalidURL Verb{..} _site = do
   let noProto (InvalidUrlException _ _) = return ()
   assertThrows "exception if no protocol" noProto (get "wheeee")
-  let noHost (InvalidDestinationHost _) = return ()
+  let noHost (HttpExceptionRequest _ (InvalidDestinationHost _)) = return ()
   assertThrows "exception if no host" noHost (get "http://")
 
 funkyScheme Verb{..} site = do

wreq.cabal

@@ -160,6 +160,7 @@ test-suite tests
   other-modules:
     Properties.Store
     UnitTests
+    HttpBin.Server
 
   if flag(aws)
     cpp-options: -DAWS_TESTS