git.iko.soy/typeable/servant
on master help sign in
Tests now pass
commitffbfa42a14b4bd922784b3a21f67e3148fb9421d authorJulian K. Arni <jkarni@gmail.com> dateTue 12 Sep 2017, 19:49 (9 years ago) parent5bd9d25
3 files changed+47−21
compare with master
unifiedsplit
servant-client-core/src/Servant/Client/Core.hs+4−5 servant-client-core/src/Servant/Client/Core/Internal/Class.hs+36−3 servant-client/test/Servant/ClientSpec.hs+7−13
servant-client-core/src/Servant/Client/Core.hs+4−5
@@ -225,11 +225,10 @@ instance OVERLAPPABLE_
225225 { requestAccept = fromList $ toList accept
226226 , requestMethod = method
227227 }
228− case mimeUnrender (Proxy :: Proxy ct) $ responseBody response of
229− Left err -> throwError $ DecodeFailure (pack err) response
230− Right val -> return val
231− where method = reflectMethod (Proxy :: Proxy method)
232− accept = contentTypes (Proxy :: Proxy ct)
228+ response `decodedAs` (Proxy :: Proxy ct)
229+ where
230+ accept = contentTypes (Proxy :: Proxy ct)
231+ method = reflectMethod (Proxy :: Proxy method)
233232
234233instance OVERLAPPING_
235234 ( RunClient m, ReflectMethod method
servant-client-core/src/Servant/Client/Core/Internal/Class.hs+36−3
@@ -1,11 +1,44 @@
11{-# LANGUAGE FlexibleContexts #-}
22{-# LANGUAGE MultiParamTypeClasses #-}
3+{-# LANGUAGE ScopedTypeVariables #-}
4+{-# LANGUAGE TypeFamilies #-}
5+{-# LANGUAGE OverloadedStrings #-}
36{-| Types for possible backends to run client-side `Request` queries -}
47module Servant.Client.Core.Internal.Class where
58
6−import Control.Monad.Error.Class (MonadError)
7−import Servant.Client.Core.Internal.Request (Request, Response,
8− ServantError)
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)
18+import Servant.Client.Core.Internal.Request (Request, Response (..),
19+ ServantError (..))
20+import Data.Foldable (toList)
921
1022class (MonadError ServantError m) => RunClient m where
23+ -- | How to make a request.
1124 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 @@
2424{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
2525
2626#include "overlapping-compat.h"
27−module Servant.ClientSpec where
27+module Servant.ClientSpec (spec) where
2828
2929import Prelude ()
3030import Prelude.Compat
@@ -35,18 +35,13 @@ import Control.Concurrent (ThreadId, forkIO,
3535import Control.Exception (bracket)
3636import Control.Monad.Error.Class (throwError)
3737import Data.Aeson
38−import qualified Data.ByteString.Lazy as BS
3938import Data.Char (chr, isPrint)
40−import Data.Foldable (toList)
4139import Data.Foldable (forM_)
42−import Data.Maybe (isJust)
4340import Data.Monoid hiding (getLast)
4441import Data.Proxy
45−import Data.Sequence (findIndexL)
4642import qualified Generics.SOP as SOP
4743import GHC.Generics (Generic)
4844import qualified Network.HTTP.Client as C
49−import Network.HTTP.Media
5045import qualified Network.HTTP.Types as HTTP
5146import Network.Socket
5247import qualified Network.Wai as Wai
@@ -96,8 +91,8 @@ spec = describe "Servant.Client" $ do
9691-- * test data types
9792
9893data Person = Person
99− { name :: String
100− , age :: Integer
94+ { _name :: String
95+ , _age :: Integer
10196 } deriving (Eq, Show, Generic)
10297
10398instance ToJSON Person
@@ -233,14 +228,14 @@ genAuthAPI = Proxy
233228type instance AuthServerData (AuthProtect "auth-tag") = ()
234229type instance AuthClientData (AuthProtect "auth-tag") = ()
235230
236−genAuthHandler :: AuthHandler Request ()
231+genAuthHandler :: AuthHandler Wai.Request ()
237232genAuthHandler =
238− let handler req = case lookup "AuthHeader" (toList $ requestHeaders req) of
233+ let handler req = case lookup "AuthHeader" (Wai.requestHeaders req) of
239234 Nothing -> throwError (err401 { errBody = "Missing auth header" })
240235 Just _ -> return ()
241236 in mkAuthHandler handler
242237
243−genAuthServerContext :: Context '[ AuthHandler Request () ]
238+genAuthServerContext :: Context '[ AuthHandler Wai.Request () ]
244239genAuthServerContext = genAuthHandler :. EmptyContext
245240
246241genAuthServer :: Application
@@ -297,6 +292,7 @@ genericClientServer = serve (Proxy :: Proxy GenericClientAPI) (
297292manager' :: C.Manager
298293manager' = unsafePerformIO $ C.newManager C.defaultManagerSettings
299294
295+runClient :: ClientM a -> BaseUrl -> IO (Either ServantError a)
300296runClient x baseUrl' = runClientM x (ClientEnv manager' baseUrl')
301297
302298sucessSpec :: Spec
@@ -344,8 +340,6 @@ sucessSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do
344340 Right r -> do
345341 responseStatusCode r `shouldBe` HTTP.status200
346342 responseBody r `shouldBe` "rawSuccess"
347− findIndexL (\x -> fst x == HTTP.hContentType) (responseHeaders r)
348− `shouldSatisfy` isJust
349343
350344 it "Servant.API.Raw should return a Left in case of failure" $ \(_, baseUrl) -> do
351345 res <- runClient (getRawFailure HTTP.methodGet) baseUrl