test/Hspec/Client.hs

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