ffbfa42 · typeable/servant

git.iko.soy/typeable/servant

on master help sign in

Tests now pass

ffbfa42Julian K. Arni9 years ago

servant-client-core/src/Servant/Client/Core.hs+4−5

compare with master

unifiedsplit

@@ -225,11 +225,10 @@ instance OVERLAPPABLE_

225 { requestAccept = fromList $ toList accept

226 , requestMethod = method

227 }

228− case mimeUnrender (Proxy :: Proxy ct) $ responseBody response of

228+ response `decodedAs` (Proxy :: Proxy ct)

229− Left err -> throwError $ DecodeFailure (pack err) response

229+ where

230− Right val -> return val

231− where method = reflectMethod (Proxy :: Proxy method)

232− accept = contentTypes (Proxy :: Proxy ct)

230+ accept = contentTypes (Proxy :: Proxy ct)

231+ method = reflectMethod (Proxy :: Proxy method)

233

232

234instance OVERLAPPING_

233instance OVERLAPPING_

235 ( RunClient m, ReflectMethod method

234 ( RunClient m, ReflectMethod method

servant-client-core/src/Servant/Client/Core/Internal/Class.hs+36−3

@@ -1,11 +1,44 @@

1{-# LANGUAGE FlexibleContexts #-}

2{-# LANGUAGE MultiParamTypeClasses #-}

3+{-# LANGUAGE ScopedTypeVariables #-}

4+{-# LANGUAGE TypeFamilies #-}

5+{-# LANGUAGE OverloadedStrings #-}

3{-| Types for possible backends to run client-side `Request` queries -}

6{-| Types for possible backends to run client-side `Request` queries -}

4module Servant.Client.Core.Internal.Class where

7module Servant.Client.Core.Internal.Class where

6−import Control.Monad.Error.Class (MonadError)

9+import Control.Monad (unless)

10+import Control.Monad.Error.Class (MonadError, throwError)

11+import Data.Proxy (Proxy)

12+import qualified Data.Text as T

13+import Network.HTTP.Media (MediaType, matches,

14+ parseAccept, (//))

15+import Servant.API (MimeUnrender,

16+ contentTypes,

17+ mimeUnrender)

7−import Servant.Client.Core.Internal.Request (Request, Response,

18+import Servant.Client.Core.Internal.Request (Request, Response (..),

8− ServantError)

19+ ServantError (..))

20+import Data.Foldable (toList)

10class (MonadError ServantError m) => RunClient m where

22class (MonadError ServantError m) => RunClient m where

23+ -- | How to make a request.

11 runRequest :: Request -> m Response

24 runRequest :: Request -> m Response

25+

26+checkContentTypeHeader :: RunClient m => Response -> m MediaType

27+checkContentTypeHeader response =

28+ case lookup "Content-Type" $ toList $ responseHeaders response of

29+ Nothing -> pure $ "application"//"octet-stream"

30+ Just t -> case parseAccept t of

31+ Nothing -> throwError $ InvalidContentTypeHeader response

32+ Just t' -> pure t'

33+

34+decodedAs :: forall ct a m. (MimeUnrender ct a, RunClient m)

35+ => Response -> Proxy ct -> m a

36+decodedAs response contentType = do

37+ responseContentType <- checkContentTypeHeader response

38+ unless (any (matches responseContentType) accept) $

39+ throwError $ UnsupportedContentType responseContentType response

40+ case mimeUnrender contentType $ responseBody response of

41+ Left err -> throwError $ DecodeFailure (T.pack err) response

42+ Right val -> return val

43+ where

44+ accept = toList $ contentTypes contentType

servant-client/test/Servant/ClientSpec.hs+7−13

@@ -24,7 +24,7 @@

24{-# OPTIONS_GHC -fno-warn-name-shadowing #-}

26#include "overlapping-compat.h"

27−module Servant.ClientSpec where

27+module Servant.ClientSpec (spec) where

29import Prelude ()

30import Prelude.Compat

@@ -35,18 +35,13 @@ import Control.Concurrent (ThreadId, forkIO,

35import Control.Exception (bracket)

36import Control.Monad.Error.Class (throwError)

37import Data.Aeson

38−import qualified Data.ByteString.Lazy as BS

39import Data.Char (chr, isPrint)

38import Data.Char (chr, isPrint)

40−import Data.Foldable (toList)

41import Data.Foldable (forM_)

39import Data.Foldable (forM_)

42−import Data.Maybe (isJust)

43import Data.Monoid hiding (getLast)

40import Data.Monoid hiding (getLast)

44import Data.Proxy

41import Data.Proxy

45−import Data.Sequence (findIndexL)

46import qualified Generics.SOP as SOP

42import qualified Generics.SOP as SOP

47import GHC.Generics (Generic)

43import GHC.Generics (Generic)

48import qualified Network.HTTP.Client as C

44import qualified Network.HTTP.Client as C

49−import Network.HTTP.Media

50import qualified Network.HTTP.Types as HTTP

45import qualified Network.HTTP.Types as HTTP

51import Network.Socket

46import Network.Socket

52import qualified Network.Wai as Wai

47import qualified Network.Wai as Wai

@@ -96,8 +91,8 @@ spec = describe "Servant.Client" $ do

96-- * test data types

91-- * test data types

98data Person = Person

93data Person = Person

99− { name :: String

94+ { _name :: String

100− , age :: Integer

95+ , _age :: Integer

101 } deriving (Eq, Show, Generic)

96 } deriving (Eq, Show, Generic)

102

103instance ToJSON Person

98instance ToJSON Person

@@ -233,14 +228,14 @@ genAuthAPI = Proxy

233type instance AuthServerData (AuthProtect "auth-tag") = ()

228type instance AuthServerData (AuthProtect "auth-tag") = ()

234type instance AuthClientData (AuthProtect "auth-tag") = ()

229type instance AuthClientData (AuthProtect "auth-tag") = ()

235

230

236−genAuthHandler :: AuthHandler Request ()

231+genAuthHandler :: AuthHandler Wai.Request ()

237genAuthHandler =

232genAuthHandler =

238− let handler req = case lookup "AuthHeader" (toList $ requestHeaders req) of

233+ let handler req = case lookup "AuthHeader" (Wai.requestHeaders req) of

239 Nothing -> throwError (err401 { errBody = "Missing auth header" })

234 Nothing -> throwError (err401 { errBody = "Missing auth header" })

240 Just _ -> return ()

235 Just _ -> return ()

241 in mkAuthHandler handler

236 in mkAuthHandler handler

242

237

243−genAuthServerContext :: Context '[ AuthHandler Request () ]

238+genAuthServerContext :: Context '[ AuthHandler Wai.Request () ]

244genAuthServerContext = genAuthHandler :. EmptyContext

239genAuthServerContext = genAuthHandler :. EmptyContext

245

240

246genAuthServer :: Application

241genAuthServer :: Application

@@ -297,6 +292,7 @@ genericClientServer = serve (Proxy :: Proxy GenericClientAPI) (

297manager' :: C.Manager

292manager' :: C.Manager

298manager' = unsafePerformIO $ C.newManager C.defaultManagerSettings

293manager' = unsafePerformIO $ C.newManager C.defaultManagerSettings

299

294

295+runClient :: ClientM a -> BaseUrl -> IO (Either ServantError a)

300runClient x baseUrl' = runClientM x (ClientEnv manager' baseUrl')

296runClient x baseUrl' = runClientM x (ClientEnv manager' baseUrl')

301

297

302sucessSpec :: Spec

298sucessSpec :: Spec

@@ -344,8 +340,6 @@ sucessSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do

344 Right r -> do

340 Right r -> do

345 responseStatusCode r `shouldBe` HTTP.status200

341 responseStatusCode r `shouldBe` HTTP.status200

346 responseBody r `shouldBe` "rawSuccess"

342 responseBody r `shouldBe` "rawSuccess"

347− findIndexL (\x -> fst x == HTTP.hContentType) (responseHeaders r)

348− `shouldSatisfy` isJust

349

343

350 it "Servant.API.Raw should return a Left in case of failure" $ \(_, baseUrl) -> do

344 it "Servant.API.Raw should return a Left in case of failure" $ \(_, baseUrl) -> do

351 res <- runClient (getRawFailure HTTP.methodGet) baseUrl

345 res <- runClient (getRawFailure HTTP.methodGet) baseUrl