test/Hspec/Client.hs

   1 {-# LANGUAGE OverloadedStrings #-}
   2 {-# LANGUAGE Rank2Types #-}
   3 {-# LANGUAGE NoMonomorphismRestriction #-}
   4 module Hspec.Client where
   5
   6 import Control.Arrow (left)
   7 import Control.Concurrent (ThreadId, forkIO, killThread)
   8 import Control.Monad (Monad(..), when)
   9 import Data.Bool
  10 import Data.Either (Either(..))
  11 import Data.Eq (Eq(..))
  12 import Data.Function (($), (.))
  13 import Data.Functor ((<$>))
  14 import Data.Int (Int)
  15 import Data.Map.Strict (Map)
  16 import Data.Maybe (Maybe(..), fromJust)
  17 import Data.Proxy (Proxy(..))
  18 import Data.Semigroup (Semigroup(..))
  19 import Data.String (String)
  20 import Data.Text (Text)
  21 import Prelude (fromIntegral, (+))
  22 import System.IO (IO)
  23 import Test.Hspec
  24 import Test.Hspec.Wai (liftIO)
  25 import Test.Tasty
  26 import Test.Tasty.Hspec
  27 import Text.Read (readMaybe)
  28 import Text.Show (Show(..))
  29 import qualified Data.ByteString.Base64 as BS64
  30 import qualified Data.ByteString as BS
  31 import qualified Data.ByteString.Lazy as BSL
  32 import qualified Data.Map.Strict as Map
  33 import qualified Data.Text as Text
  34 import qualified Data.Text.Encoding as Text
  35 import qualified Data.Text.Lazy as TL
  36 import qualified Data.Text.Lazy.Encoding as TL
  37 import qualified Network.HTTP.Client as Client
  38 import qualified Network.HTTP.Types as HTTP
  39 import qualified Network.Socket as Net
  40 import qualified Network.Wai as Wai
  41 import qualified Network.Wai.Handler.Warp as Warp
  42 import qualified Test.Hspec.Wai as Wai
  43
  44 import Symantic.HTTP
  45
  46 api = "auth" </> basicAuth @User "realm"
  47              <.> get @() @'[PlainText]
  48   <!> "body" </> body @() @'[PlainText]
  49              <.> post @() @'[PlainText]
  50
  51 srv = server api $
  52              route_auth
  53          :!: route_body
  54         where
  55         route_auth User{} = return ()
  56         route_body (ServerBodyArg a) = return ()
  57
  58 cli_auth
  59  :!: cli_body
  60  = client api
  61
  62 alice, bob :: User
  63 alice = User "Alice" "pass" True 19
  64 bob   = User "Bob" "pass" False 31
  65
  66 -- * Type "User"
  67 data User
  68  =   User
  69  {   user_name :: Text
  70  ,   user_pass :: Text
  71  ,   user_auth :: Bool
  72  ,   user_age  :: Int
  73  } deriving (Eq, Show)
  74 instance ServerBasicAuth User where
  75         serverBasicAuth user pass =
  76                 return $
  77                         case Map.lookup user users of
  78                          Nothing -> BasicAuth_NoSuchUser
  79                          Just u@User{..}
  80                           | user_pass == pass ->
  81                                 if user_auth
  82                                 then BasicAuth_Authorized u
  83                                 else BasicAuth_Unauthorized
  84                           | otherwise -> BasicAuth_BadPassword
  85
  86 users :: Map Text User
  87 users =
  88         Map.fromList $
  89         (\u -> (user_name u, u)) <$>
  90         [ alice
  91         , bob
  92         ]
  93
  94 {-
  95 instance ToJSON   User
  96 instance ToForm   User
  97 instance FromJSON User
  98 instance FromForm User
  99
 100 instance Arbitrary User where
 101   arbitrary = User <$> arbitrary <*> arbitrary
 102 -}
 103
 104 hspec :: IO [TestTree]
 105 hspec = testSpecs $ describe "Client" $
 106         beforeAll (runTestServer srv) $
 107         afterAll killTestServer $ do
 108                 describe "BasicAuth" $ do
 109                         it "can allow user (200)" $ \TestServer{..} -> do
 110                                 runClient env (cli_auth (user_name alice) (user_pass alice))
 111                                  `shouldReturn` Right ()
 112                         it "can deny user (401)" $ \TestServer{..} -> do
 113                                 Left (ClientError_FailureResponse r) <-
 114                                         runClient env $ cli_auth "no-user" (user_pass alice)
 115                                 clientResStatus r `shouldBe` HTTP.Status 401 "Unauthorized"
 116                         it "can deny pass (401)" $ \TestServer{..} -> do
 117                                 Left (ClientError_FailureResponse r) <-
 118                                         runClient env $ cli_auth (user_name alice) "no-pass"
 119                                 clientResStatus r `shouldBe` HTTP.Status 401 "Unauthorized"
 120                         it "can deny auth (403)" $ \TestServer{..} -> do
 121                                 Left (ClientError_FailureResponse r) <-
 122                                         runClient env $ cli_auth (user_name bob) (user_pass bob)
 123                                 clientResStatus r `shouldBe` HTTP.Status 403 "Forbidden"
 124
 125 {-
 126 import           Control.Arrow (left)
 127 import           Control.Concurrent.STM (atomically)
 128 import           Control.Concurrent.STM.TVar (newTVar, readTVar)
 129 import           Control.Exception (bracket, fromException)
 130 import           Control.Monad.Error.Class (throwError)
 131 import           Data.Char (chr, isPrint)
 132 import           Data.Foldable (forM_, toList)
 133 import           Data.Maybe (isJust, listToMaybe)
 134 import           Data.Monoid ()
 135 import           Data.Proxy
 136 import           Data.Semigroup ((<>))
 137 import           GHC.Generics (Generic)
 138 import qualified Network.HTTP.Client as Client
 139 import qualified Network.HTTP.Types as HTTP
 140 import qualified Network.Wai as Wai
 141 import           Network.Wai.Handler.Warp
 142 import           System.IO.Unsafe (unsafePerformIO)
 143 import           Test.Hspec
 144 import           Test.Hspec.QuickCheck
 145 import           Test.HUnit
 146 import           Test.QuickCheck
 147 import           Web.FormUrlEncoded (FromForm, ToForm)
 148
 149 -- This declaration simply checks that all instances are in place.
 150 _ = client comprehensiveAPIWithoutStreaming
 151
 152 spec :: Spec
 153 spec = describe "Servant.Client" $ do
 154     sucessSpec
 155     failSpec
 156     wrappedApiSpec
 157     basicAuthSpec
 158     genAuthSpec
 159     hoistClientSpec
 160     connectionErrorSpec
 161
 162 -- * test data types
 163
 164 data Person = Person
 165   { _name :: String
 166   , _age  :: Integer
 167   } deriving (Eq, Show, Generic)
 168
 169 instance ToJSON Person
 170 instance FromJSON Person
 171
 172 instance ToForm Person
 173 instance FromForm Person
 174
 175 instance Arbitrary Person where
 176   arbitrary = Person <$> arbitrary <*> arbitrary
 177
 178 alice :: Person
 179 alice = Person "Alice" 42
 180
 181 bob :: Person
 182 bob = Person "Carol" 17
 183
 184 type TestHeaders = '[Header "X-Example1" Int, Header "X-Example2" String]
 185
 186 type Api =
 187   Get '[JSON] Person
 188   :<|> "get" :> Get '[JSON] Person
 189   :<|> "deleteEmpty" :> DeleteNoContent '[JSON] NoContent
 190   :<|> "capture" :> Capture "name" String :> Get '[JSON,FormUrlEncoded] Person
 191   :<|> "captureAll" :> CaptureAll "names" String :> Get '[JSON] [Person]
 192   :<|> "body" :> ReqBody '[FormUrlEncoded,JSON] Person :> Post '[JSON] Person
 193   :<|> "param" :> QueryParam "name" String :> Get '[FormUrlEncoded,JSON] Person
 194   :<|> "params" :> QueryParams "names" String :> Get '[JSON] [Person]
 195   :<|> "flag" :> QueryFlag "flag" :> Get '[JSON] Bool
 196   :<|> "rawSuccess" :> Raw
 197   :<|> "rawFailure" :> Raw
 198   :<|> "multiple" :>
 199             Capture "first" String :>
 200             QueryParam "second" Int :>
 201             QueryFlag "third" :>
 202             ReqBody '[JSON] [(String, [Rational])] :>
 203             Get '[JSON] (String, Maybe Int, Bool, [(String, [Rational])])
 204   :<|> "headers" :> Get '[JSON] (Headers TestHeaders Bool)
 205   :<|> "deleteContentType" :> DeleteNoContent '[JSON] NoContent
 206   :<|> "redirectWithCookie" :> Raw
 207   :<|> "empty" :> EmptyAPI
 208
 209 api :: Proxy Api
 210 api = Proxy
 211
 212 getRoot         :: ClientM Person
 213 getGet          :: ClientM Person
 214 getDeleteEmpty  :: ClientM NoContent
 215 getCapture      :: String -> ClientM Person
 216 getCaptureAll   :: [String] -> ClientM [Person]
 217 getBody         :: Person -> ClientM Person
 218 getQueryParam   :: Maybe String -> ClientM Person
 219 getQueryParams  :: [String] -> ClientM [Person]
 220 getQueryFlag    :: Bool -> ClientM Bool
 221 getRawSuccess   :: HTTP.Method -> ClientM Response
 222 getRawFailure   :: HTTP.Method -> ClientM Response
 223 getMultiple     :: String -> Maybe Int -> Bool -> [(String, [Rational])]
 224   -> ClientM (String, Maybe Int, Bool, [(String, [Rational])])
 225 getRespHeaders  :: ClientM (Headers TestHeaders Bool)
 226 getDeleteContentType :: ClientM NoContent
 227 getRedirectWithCookie :: HTTP.Method -> ClientM Response
 228
 229 getRoot
 230   :<|> getGet
 231   :<|> getDeleteEmpty
 232   :<|> getCapture
 233   :<|> getCaptureAll
 234   :<|> getBody
 235   :<|> getQueryParam
 236   :<|> getQueryParams
 237   :<|> getQueryFlag
 238   :<|> getRawSuccess
 239   :<|> getRawFailure
 240   :<|> getMultiple
 241   :<|> getRespHeaders
 242   :<|> getDeleteContentType
 243   :<|> getRedirectWithCookie
 244   :<|> EmptyClient = client api
 245
 246 server :: Application
 247 server = serve api (
 248        return bob
 249   :<|> return alice
 250   :<|> return NoContent
 251   :<|> (\ name -> return $ Person name 0)
 252   :<|> (\ names -> return (zipWith Person names [0..]))
 253   :<|> return
 254   :<|> (\ name -> case name of
 255                    Just "alice" -> return alice
 256                    Just n -> throwError $ ServerError 400 (n ++ " not found") "" []
 257                    Nothing -> throwError $ ServerError 400 "missing parameter" "" [])
 258   :<|> (\ names -> return (zipWith Person names [0..]))
 259   :<|> return
 260   :<|> (Tagged $ \ _request respond -> respond $ Wai.responseLBS HTTP.ok200 [] "rawSuccess")
 261   :<|> (Tagged $ \ _request respond -> respond $ Wai.responseLBS HTTP.badRequest400 [] "rawFailure")
 262   :<|> (\ a b c d -> return (a, b, c, d))
 263   :<|> (return $ addHeader 1729 $ addHeader "eg2" True)
 264   :<|> return NoContent
 265   :<|> (Tagged $ \ _request respond -> respond $ Wai.responseLBS HTTP.found302 [("Location", "testlocation"), ("Set-Cookie", "testcookie=test")] "")
 266   :<|> emptyServer)
 267
 268 type FailApi =
 269        "get" :> Raw
 270   :<|> "capture" :> Capture "name" String :> Raw
 271   :<|> "body" :> Raw
 272 failApi :: Proxy FailApi
 273 failApi = Proxy
 274
 275 failServer :: Application
 276 failServer = serve failApi (
 277        (Tagged $ \ _request respond -> respond $ Wai.responseLBS HTTP.ok200 [] "")
 278   :<|> (\ _capture -> Tagged $ \_request respond -> respond $ Wai.responseLBS HTTP.ok200 [("content-type", "application/json")] "")
 279   :<|> (Tagged $ \_request respond -> respond $ Wai.responseLBS HTTP.ok200 [("content-type", "fooooo")] "")
 280  )
 281
 282 -- * basic auth stuff
 283
 284 type BasicAuthAPI =
 285        BasicAuth "foo-realm" () :> "private" :> "basic" :> Get '[JSON] Person
 286
 287 basicAuthAPI :: Proxy BasicAuthAPI
 288 basicAuthAPI = Proxy
 289
 290 basicAuthHandler :: BasicAuthCheck ()
 291 basicAuthHandler =
 292   let check (BasicAuthData username password) =
 293         if username == "servant" && password == "server"
 294         then return (Authorized ())
 295         else return Unauthorized
 296   in BasicAuthCheck check
 297
 298 basicServerContext :: Context '[ BasicAuthCheck () ]
 299 basicServerContext = basicAuthHandler :. EmptyContext
 300
 301 basicAuthServer :: Application
 302 basicAuthServer = serveWithContext basicAuthAPI basicServerContext (const (return alice))
 303
 304 -- * general auth stuff
 305
 306 type GenAuthAPI =
 307   AuthProtect "auth-tag" :> "private" :> "auth" :> Get '[JSON] Person
 308
 309 genAuthAPI :: Proxy GenAuthAPI
 310 genAuthAPI = Proxy
 311
 312 type instance AuthServerData (AuthProtect "auth-tag") = ()
 313 type instance Auth.AuthClientData (AuthProtect "auth-tag") = ()
 314
 315 genAuthHandler :: AuthHandler Wai.Request ()
 316 genAuthHandler =
 317   let handler req = case lookup "AuthHeader" (Wai.requestHeaders req) of
 318         Nothing -> throwError (err401 { errBody = "Missing auth header" })
 319         Just _ -> return ()
 320   in mkAuthHandler handler
 321
 322 genAuthServerContext :: Context '[ AuthHandler Wai.Request () ]
 323 genAuthServerContext = genAuthHandler :. EmptyContext
 324
 325 genAuthServer :: Application
 326 genAuthServer = serveWithContext genAuthAPI genAuthServerContext (const (return alice))
 327
 328 {-# NOINLINE manager' #-}
 329 manager' :: Client.Manager
 330 manager' = unsafePerformIO $ Client.newManager Client.defaultManagerSettings
 331
 332 runClient :: BaseUrl -> ClientM a -> IO (Either ClientError a)
 333 runClient x baseUrl' = runClientM x $ mkClientEnv manager' baseUrl'
 334
 335 sucessSpec :: Spec
 336 sucessSpec = beforeAll (runTestServer server) $ afterAll killTestServer $ do
 337     it "Servant.API.Get root" $ \(_, baseUrl) -> do
 338       left show <$> runClient getRoot baseUrl  `shouldReturn` Right bob
 339
 340     it "Servant.API.Get" $ \(_, baseUrl) -> do
 341       left show <$> runClient getGet baseUrl  `shouldReturn` Right alice
 342
 343     describe "Servant.API.Delete" $ do
 344       it "allows empty content type" $ \(_, baseUrl) -> do
 345         left show <$> runClient getDeleteEmpty baseUrl `shouldReturn` Right NoContent
 346
 347       it "allows content type" $ \(_, baseUrl) -> do
 348         left show <$> runClient getDeleteContentType baseUrl `shouldReturn` Right NoContent
 349
 350     it "Servant.API.Capture" $ \(_, baseUrl) -> do
 351       left show <$> runClient (getCapture "Paula") baseUrl `shouldReturn` Right (Person "Paula" 0)
 352
 353     it "Servant.API.CaptureAll" $ \(_, baseUrl) -> do
 354       let expected = [(Person "Paula" 0), (Person "Peta" 1)]
 355       left show <$> runClient (getCaptureAll ["Paula", "Peta"]) baseUrl `shouldReturn` Right expected
 356
 357     it "Servant.API.ReqBody" $ \(_, baseUrl) -> do
 358       let p = Person "Clara" 42
 359       left show <$> runClient (getBody p) baseUrl `shouldReturn` Right p
 360
 361     it "Servant.API FailureResponse" $ \(_, baseUrl) -> do
 362       left show <$> runClient (getQueryParam (Just "alice")) baseUrl `shouldReturn` Right alice
 363       Left (FailureResponse req _) <- runClient (getQueryParam (Just "bob")) baseUrl
 364       Req.requestPath req `shouldBe` (baseUrl, "/param")
 365       toList (Req.requestQueryString req) `shouldBe` [("name", Just "bob")]
 366       Req.requestMethod req `shouldBe` HTTP.methodGet
 367
 368     it "Servant.API.QueryParam" $ \(_, baseUrl) -> do
 369       left show <$> runClient (getQueryParam (Just "alice")) baseUrl `shouldReturn` Right alice
 370       Left (FailureResponse _ r) <- runClient (getQueryParam (Just "bob")) baseUrl
 371       responseStatusCode r `shouldBe` HTTP.Status 400 "bob not found"
 372
 373     it "Servant.API.QueryParam.QueryParams" $ \(_, baseUrl) -> do
 374       left show <$> runClient (getQueryParams []) baseUrl `shouldReturn` Right []
 375       left show <$> runClient (getQueryParams ["alice", "bob"]) baseUrl
 376         `shouldReturn` Right [Person "alice" 0, Person "bob" 1]
 377
 378     context "Servant.API.QueryParam.QueryFlag" $
 379       forM_ [False, True] $ \ flag -> it (show flag) $ \(_, baseUrl) -> do
 380         left show <$> runClient (getQueryFlag flag) baseUrl `shouldReturn` Right flag
 381
 382     it "Servant.API.Raw on success" $ \(_, baseUrl) -> do
 383       res <- runClient (getRawSuccess HTTP.methodGet) baseUrl
 384       case res of
 385         Left e -> assertFailure $ show e
 386         Right r -> do
 387           responseStatusCode r `shouldBe` HTTP.status200
 388           responseBody r `shouldBe` "rawSuccess"
 389
 390     it "Servant.API.Raw should return a Left in case of failure" $ \(_, baseUrl) -> do
 391       res <- runClient (getRawFailure HTTP.methodGet) baseUrl
 392       case res of
 393         Right _ -> assertFailure "expected Left, but got Right"
 394         Left (FailureResponse _ r) -> do
 395           responseStatusCode r `shouldBe` HTTP.status400
 396           responseBody r `shouldBe` "rawFailure"
 397         Left e -> assertFailure $ "expected FailureResponse, but got " ++ show e
 398
 399     it "Returns headers appropriately" $ \(_, baseUrl) -> do
 400       res <- runClient getRespHeaders baseUrl
 401       case res of
 402         Left e -> assertFailure $ show e
 403         Right val -> getHeaders val `shouldBe` [("X-Example1", "1729"), ("X-Example2", "eg2")]
 404
 405     it "Stores Cookie in CookieJar after a redirect" $ \(_, baseUrl) -> do
 406       mgr <- Client.newManager Client.defaultManagerSettings
 407       cj <- atomically . newTVar $ Client.createCookieJar []
 408       _ <- runClientM (getRedirectWithCookie HTTP.methodGet) (ClientEnv mgr baseUrl (Just cj))
 409       cookie <- listToMaybe . Client.destroyCookieJar <$> atomically (readTVar cj)
 410       Client.cookie_name <$> cookie `shouldBe` Just "testcookie"
 411       Client.cookie_value <$> cookie `shouldBe` Just "test"
 412
 413     modifyMaxSuccess (const 20) $ do
 414       it "works for a combination of Capture, QueryParam, QueryFlag and ReqBody" $ \(_, baseUrl) ->
 415         property $ forAllShrink pathGen shrink $ \(NonEmpty cap) num flag body ->
 416           ioProperty $ do
 417             result <- left show <$> runClient (getMultiple cap num flag body) baseUrl
 418             return $
 419               result === Right (cap, num, flag, body)
 420
 421
 422 wrappedApiSpec :: Spec
 423 wrappedApiSpec = describe "error status codes" $ do
 424   let serveW api = serve api $ throwError $ ServerError 500 "error message" "" []
 425   context "are correctly handled by the client" $
 426     let test :: (WrappedApi, String) -> Spec
 427         test (WrappedApi api, desc) =
 428           it desc $ bracket (runTestServer $ serveW api) killTestServer $ \(_, baseUrl) -> do
 429             let getResponse :: ClientM ()
 430                 getResponse = client api
 431             Left (FailureResponse _ r) <- runClient getResponse baseUrl
 432             responseStatusCode r `shouldBe` (HTTP.Status 500 "error message")
 433     in mapM_ test $
 434         (WrappedApi (Proxy :: Proxy (Delete '[JSON] ())), "Delete") :
 435         (WrappedApi (Proxy :: Proxy (Get '[JSON] ())), "Get") :
 436         (WrappedApi (Proxy :: Proxy (Post '[JSON] ())), "Post") :
 437         (WrappedApi (Proxy :: Proxy (Put '[JSON] ())), "Put") :
 438         []
 439
 440 failSpec :: Spec
 441 failSpec = beforeAll (runTestServer failServer) $ afterAll killTestServer $ do
 442
 443     context "client returns errors appropriately" $ do
 444       it "reports FailureResponse" $ \(_, baseUrl) -> do
 445         let (_ :<|> _ :<|> getDeleteEmpty :<|> _) = client api
 446         Left res <- runClient getDeleteEmpty baseUrl
 447         case res of
 448           FailureResponse _ r | responseStatusCode r == HTTP.status404 -> return ()
 449           _ -> fail $ "expected 404 response, but got " <> show res
 450
 451       it "reports DecodeFailure" $ \(_, baseUrl) -> do
 452         let (_ :<|> _ :<|> _ :<|> getCapture :<|> _) = client api
 453         Left res <- runClient (getCapture "foo") baseUrl
 454         case res of
 455           DecodeFailure _ _ -> return ()
 456           _ -> fail $ "expected DecodeFailure, but got " <> show res
 457
 458       it "reports ConnectionError" $ \_ -> do
 459         let (getGetWrongHost :<|> _) = client api
 460         Left res <- runClient getGetWrongHost (BaseUrl Http "127.0.0.1" 19872 "")
 461         case res of
 462           ConnectionError _ -> return ()
 463           _ -> fail $ "expected ConnectionError, but got " <> show res
 464
 465       it "reports UnsupportedContentType" $ \(_, baseUrl) -> do
 466         let (_ :<|> getGet :<|> _ ) = client api
 467         Left res <- runClient getGet baseUrl
 468         case res of
 469           UnsupportedContentType ("application/octet-stream") _ -> return ()
 470           _ -> fail $ "expected UnsupportedContentType, but got " <> show res
 471
 472       it "reports InvalidContentTypeHeader" $ \(_, baseUrl) -> do
 473         let (_ :<|> _ :<|> _ :<|> _ :<|> _ :<|> getBody :<|> _) = client api
 474         Left res <- runClient (getBody alice) baseUrl
 475         case res of
 476           InvalidContentTypeHeader _ -> return ()
 477           _ -> fail $ "expected InvalidContentTypeHeader, but got " <> show res
 478
 479 data WrappedApi where
 480   WrappedApi :: (HasServer (api :: *) '[], Server api ~ Handler a,
 481                  HasClient ClientM api, Client ClientM api ~ ClientM ()) =>
 482     Proxy api -> WrappedApi
 483
 484 basicAuthSpec :: Spec
 485 basicAuthSpec = beforeAll (runTestServer basicAuthServer) $ afterAll killTestServer $ do
 486   context "Authentication works when requests are properly authenticated" $ do
 487
 488     it "Authenticates a BasicAuth protected server appropriately" $ \(_,baseUrl) -> do
 489       let getBasic = client basicAuthAPI
 490       let basicAuthData = BasicAuthData "servant" "server"
 491       left show <$> runClient (getBasic basicAuthData) baseUrl `shouldReturn` Right alice
 492
 493   context "Authentication is rejected when requests are not authenticated properly" $ do
 494
 495     it "Authenticates a BasicAuth protected server appropriately" $ \(_,baseUrl) -> do
 496       let getBasic = client basicAuthAPI
 497       let basicAuthData = BasicAuthData "not" "password"
 498       Left (FailureResponse _ r) <- runClient (getBasic basicAuthData) baseUrl
 499       responseStatusCode r `shouldBe` HTTP.Status 403 "Forbidden"
 500
 501 genAuthSpec :: Spec
 502 genAuthSpec = beforeAll (runTestServer genAuthServer) $ afterAll killTestServer $ do
 503   context "Authentication works when requests are properly authenticated" $ do
 504
 505     it "Authenticates a AuthProtect protected server appropriately" $ \(_, baseUrl) -> do
 506       let getProtected = client genAuthAPI
 507       let authRequest = Auth.mkAuthenticatedRequest () (\_ req -> Req.addHeader "AuthHeader" ("cool" :: String) req)
 508       left show <$> runClient (getProtected authRequest) baseUrl `shouldReturn` Right alice
 509
 510   context "Authentication is rejected when requests are not authenticated properly" $ do
 511
 512     it "Authenticates a AuthProtect protected server appropriately" $ \(_, baseUrl) -> do
 513       let getProtected = client genAuthAPI
 514       let authRequest = Auth.mkAuthenticatedRequest () (\_ req -> Req.addHeader "Wrong" ("header" :: String) req)
 515       Left (FailureResponse _ r) <- runClient (getProtected authRequest) baseUrl
 516       responseStatusCode r `shouldBe` (HTTP.Status 401 "Unauthorized")
 517
 518 -- * hoistClient
 519
 520 type HoistClientAPI = Get '[JSON] Int :<|> Capture "n" Int :> Post '[JSON] Int
 521
 522 hoistClientAPI :: Proxy HoistClientAPI
 523 hoistClientAPI = Proxy
 524
 525 hoistClientServer :: Application -- implements HoistClientAPI
 526 hoistClientServer = serve hoistClientAPI $ return 5 :<|> (\n -> return n)
 527
 528 hoistClientSpec :: Spec
 529 hoistClientSpec = beforeAll (runTestServer hoistClientServer) $ afterAll killTestServer $ do
 530   describe "Servant.Client.hoistClient" $ do
 531     it "allows us to GET/POST/... requests in IO instead of ClientM" $ \(_, baseUrl) -> do
 532       let (getInt :<|> postInt)
 533             = hoistClient hoistClientAPI
 534                           (fmap (either (error . show) id) . flip runClient baseUrl)
 535                           (client hoistClientAPI)
 536
 537       getInt `shouldReturn` 5
 538       postInt 5 `shouldReturn` 5
 539
 540 -- * ConnectionError
 541 type ConnectionErrorAPI = Get '[JSON] Int
 542
 543 connectionErrorAPI :: Proxy ConnectionErrorAPI
 544 connectionErrorAPI = Proxy
 545
 546 connectionErrorSpec :: Spec
 547 connectionErrorSpec = describe "Servant.Client.ClientError" $
 548     it "correctly catches ConnectionErrors when the HTTP request can't go through" $ do
 549         let getInt = client connectionErrorAPI
 550         let baseUrl' = BaseUrl Http "example.invalid" 80 ""
 551         let isHttpError (Left (ConnectionError e)) = isJust $ fromException @Client.HttpException e
 552             isHttpError _ = False
 553         (isHttpError <$> runClient getInt baseUrl') `shouldReturn` True
 554
 555 -- * utils
 556 pathGen :: Gen (NonEmptyList Char)
 557 pathGen = fmap NonEmpty path
 558  where
 559   path = listOf1 $ elements $
 560     filter (not . (`elem` ("?%[]/#;" :: String))) $
 561     filter isPrint $
 562     map chr [0..127]
 563 -}
 564
 565 -- * Type 'TestServer'
 566 data TestServer = TestServer
 567  { thread :: ThreadId
 568  , socket :: Net.Socket
 569  , env    :: ClientEnv
 570  }
 571
 572 runTestServer :: Wai.Application -> IO TestServer
 573 runTestServer waiApp = do
 574         let baseURI = fromJust $ parseURI "http://localhost:8080"
 575         (port, socket) <- openTestSocket
 576         thread <- forkIO $
 577                 Warp.runSettingsSocket
 578                  (Warp.setPort port $ Warp.defaultSettings)
 579                  socket waiApp
 580         manager <- Client.newManager Client.defaultManagerSettings
 581         return $ TestServer
 582          { env = clientEnv manager baseURI
 583          , .. }
 584
 585 killTestServer :: TestServer -> IO ()
 586 killTestServer TestServer{..} = do
 587         Net.close socket
 588         killThread thread
 589
 590 openTestSocket :: IO (Warp.Port, Net.Socket)
 591 openTestSocket = do
 592         let host = Net.tupleToHostAddress (127, 0, 0, 1)
 593         let port = 8080
 594         sock <- Net.socket Net.AF_INET Net.Stream Net.defaultProtocol
 595         Net.setSocketOption sock Net.ReuseAddr 1
 596         Net.bind sock (Net.SockAddrInet port host)
 597         Net.listen sock 1000
 598         return (port, sock)