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