git.iko.soy/servant
on master help sign in
Refactor servant-client-core
420ebd0Oleg Grenrus
.gitignore+1−1
compare with master
unifiedsplit
@@ -1,5 +1,5 @@
1**/*/dist
1**/*/dist
2−dist-newstyle
2+dist-*
3.ghc.environment.*
3.ghc.environment.*
4/bin
4/bin
5/lib
5/lib
Makefilenew file+13
@@ -0,0 +1,13 @@
1+# With common maintenance tasks
2+
3+all :
4+ @echo "Don't try to make all at once!"
5+
6+build-ghc :
7+ cabal v2-build all
8+
9+build-ghcjs :
10+ cabal v2-build --builddir=dist-newstyle-ghcjs --project-file=cabal.ghcjs.project all
11+
12+packdeps :
13+ packdeps */*.cabal
cabal.ghcjs.project−15
@@ -1,6 +1,4 @@
1-- Using https://launchpad.net/~hvr/+archive/ubuntu/ghcjs
1-- Using https://launchpad.net/~hvr/+archive/ubuntu/ghcjs
2−--
3−-- $ cabal new-build --project-file cabal.ghcjs.project all -w /opt/ghcjs/8.4/bin/ghcjs
4
2
5packages:
3packages:
6 servant/
4 servant/
@@ -9,16 +7,3 @@ packages:
9
7
10-- we need to tell cabal we are using GHCJS
8-- we need to tell cabal we are using GHCJS
11compiler: ghcjs
9compiler: ghcjs
12−
13−-- https://github.com/ghcjs/ghcjs/issues/665
14−constraints: primitive <0.6.4
15−
16−-- ghcjs-base wants old aeson
17−allow-newer: ghcjs-base:aeson
18−
19−-- https://github.com/nomeata/hackage-ghcjs-overlay
20−repository ghcjs-overlay
21− url: http://hackage-ghcjs-overlay.nomeata.de/
22− secure: True
23− root-keys:
24− key-threshold: 0
doc/cookbook/using-free-client/UsingFreeClient.lhs−2
@@ -99,8 +99,6 @@ test = case getSquare 42 of
99 putStrLn $ "ERROR: got pure result: " ++ show n
99 putStrLn $ "ERROR: got pure result: " ++ show n
100 Free (Throw err) ->
100 Free (Throw err) ->
101 putStrLn $ "ERROR: got error right away: " ++ show err
101 putStrLn $ "ERROR: got error right away: " ++ show err
102− Free (StreamingRequest _req _k) ->
103− putStrLn $ "ERROR: need to do streaming request" -- TODO: no Show Req :(
104```
102```
105
103
106We are interested in `RunRequest`, that's what client should block on:
104We are interested in `RunRequest`, that's what client should block on:
servant-client-core/servant-client-core.cabal+11−11
@@ -36,16 +36,17 @@ library
36 Servant.Client.Free
36 Servant.Client.Free
37 Servant.Client.Generic
37 Servant.Client.Generic
38 Servant.Client.Core.Reexport
38 Servant.Client.Core.Reexport
39− Servant.Client.Core.Internal.Auth
39+ Servant.Client.Core.Auth
40− Servant.Client.Core.Internal.BaseUrl
40+ Servant.Client.Core.BaseUrl
41− Servant.Client.Core.Internal.BasicAuth
41+ Servant.Client.Core.BasicAuth
42− Servant.Client.Core.Internal.ClientError
42+ Servant.Client.Core.ClientError
43− Servant.Client.Core.Internal.ClientF
43+ Servant.Client.Core.HasClient
44− Servant.Client.Core.Internal.Generic
45− Servant.Client.Core.Internal.HasClient
46− Servant.Client.Core.Internal.Request
44+ Servant.Client.Core.Request
47− Servant.Client.Core.Internal.Response
45+ Servant.Client.Core.Response
48− Servant.Client.Core.Internal.RunClient
46+ Servant.Client.Core.RunClient
47+
48+ other-modules:
49+ Servant.Client.Core.Internal
49
50
50 -- Bundled with GHC: Lower bound to not force re-installs
51 -- Bundled with GHC: Lower bound to not force re-installs
51 -- text and mtl are bundled starting with GHC-8.4
52 -- text and mtl are bundled starting with GHC-8.4
@@ -76,7 +77,6 @@ library
76 , base64-bytestring >= 1.0.0.1 && < 1.1
77 , base64-bytestring >= 1.0.0.1 && < 1.1
77 , exceptions >= 0.10.0 && < 0.11
78 , exceptions >= 0.10.0 && < 0.11
78 , free >= 5.1 && < 5.2
79 , free >= 5.1 && < 5.2
79− , generics-sop >= 0.4.0.1 && < 0.5
80 , http-media >= 0.7.1.3 && < 0.8
80 , http-media >= 0.7.1.3 && < 0.8
81 , http-types >= 0.12.2 && < 0.13
81 , http-types >= 0.12.2 && < 0.13
82 , network-uri >= 2.6.1.0 && < 2.7
82 , network-uri >= 2.6.1.0 && < 2.7
servant-client-core/src/Servant/Client/Core.hs+16−15
@@ -32,18 +32,20 @@ module Servant.Client.Core
32 , AuthClientData
32 , AuthClientData
33
33
34 -- * Generic Client
34 -- * Generic Client
35− , ClientLike(..)
36− , genericMkClientL
37− , genericMkClientP
38 , ServantError(..)
35 , ServantError(..)
39 , EmptyClient(..)
36 , EmptyClient(..)
40
37
41−
42 -- * Response
38 -- * Response
43 , Response
39 , Response
44 , ResponseF (..)
40 , ResponseF (..)
45 , RunClient(..)
41 , RunClient(..)
46− , module Servant.Client.Core.Internal.BaseUrl
42+ -- * BaseUrl
43+ , BaseUrl (..)
44+ , Scheme (..)
45+ , showBaseUrl
46+ , parseBaseUrl
47+ , InvalidBaseUrlException (..)
48+
47 -- ** Streaming
49 -- ** Streaming
48 , RunStreamingClient(..)
50 , RunStreamingClient(..)
49 , StreamingResponse
51 , StreamingResponse
@@ -56,14 +58,13 @@ module Servant.Client.Core
56 , setRequestBodyLBS
58 , setRequestBodyLBS
57 , setRequestBody
59 , setRequestBody
58 ) where
60 ) where
59−import Servant.Client.Core.Internal.Auth
61+import Servant.Client.Core.Auth
60−import Servant.Client.Core.Internal.BaseUrl
62+import Servant.Client.Core.BaseUrl
61− (BaseUrl (..), InvalidBaseUrlException, Scheme (..),
63+ (BaseUrl (..), InvalidBaseUrlException (..), Scheme (..),
62 parseBaseUrl, showBaseUrl)
64 parseBaseUrl, showBaseUrl)
63−import Servant.Client.Core.Internal.BasicAuth
65+import Servant.Client.Core.BasicAuth
64−import Servant.Client.Core.Internal.Generic
66+import Servant.Client.Core.ClientError
65−import Servant.Client.Core.Internal.HasClient
67+import Servant.Client.Core.HasClient
66−import Servant.Client.Core.Internal.Request
68+import Servant.Client.Core.Request
67−import Servant.Client.Core.Internal.Response
69+import Servant.Client.Core.Response
68−import Servant.Client.Core.Internal.ClientError
70+import Servant.Client.Core.RunClient
69−import Servant.Client.Core.Internal.RunClient
servant-client-core/src/Servant/Client/Core/Internal/Auth.hs → servant-client-core/src/Servant/Client/Core/Auth.hsrenamed+6−2
@@ -4,9 +4,13 @@
4
4
5-- | Authentication for clients
5-- | Authentication for clients
6
6
7−module Servant.Client.Core.Internal.Auth where
7+module Servant.Client.Core.Auth (
8+ AuthClientData,
9+ AuthenticatedRequest (..),
10+ mkAuthenticatedRequest,
11+ ) where
8
12
9−import Servant.Client.Core.Internal.Request
13+import Servant.Client.Core.Request
10 (Request)
14 (Request)
11
15
12-- | For a resource protected by authentication (e.g. AuthProtect), we need
16-- | For a resource protected by authentication (e.g. AuthProtect), we need
servant-client-core/src/Servant/Client/Core/Internal/BaseUrl.hs → servant-client-core/src/Servant/Client/Core/BaseUrl.hsrenamed+7−1
@@ -2,7 +2,13 @@
2{-# LANGUAGE DeriveGeneric #-}
2{-# LANGUAGE DeriveGeneric #-}
3{-# LANGUAGE DeriveLift #-}
3{-# LANGUAGE DeriveLift #-}
4{-# LANGUAGE ViewPatterns #-}
4{-# LANGUAGE ViewPatterns #-}
5−module Servant.Client.Core.Internal.BaseUrl where
5+module Servant.Client.Core.BaseUrl (
6+ BaseUrl (..),
7+ Scheme (..),
8+ showBaseUrl,
9+ parseBaseUrl,
10+ InvalidBaseUrlException (..),
11+ ) where
6
12
7import Control.DeepSeq
13import Control.DeepSeq
8 (NFData (..))
14 (NFData (..))
servant-client-core/src/Servant/Client/Core/Internal/BasicAuth.hs → servant-client-core/src/Servant/Client/Core/BasicAuth.hsrenamed+4−3
@@ -3,8 +3,9 @@
3{-# LANGUAGE TypeSynonymInstances #-}
3{-# LANGUAGE TypeSynonymInstances #-}
4
4
5-- | Basic Authentication for clients
5-- | Basic Authentication for clients
6−
7−module Servant.Client.Core.Internal.BasicAuth where
6+module Servant.Client.Core.BasicAuth (
7+ basicAuthReq,
8+ ) where
8
9
9import Data.ByteString.Base64
10import Data.ByteString.Base64
10 (encode)
11 (encode)
@@ -14,7 +15,7 @@ import Data.Text.Encoding
14 (decodeUtf8)
15 (decodeUtf8)
15import Servant.API.BasicAuth
16import Servant.API.BasicAuth
16 (BasicAuthData (BasicAuthData))
17 (BasicAuthData (BasicAuthData))
17−import Servant.Client.Core.Internal.Request
18+import Servant.Client.Core.Request
18 (Request, addHeader)
19 (Request, addHeader)
19
20
20-- | Authenticate a request using Basic Authentication
21-- | Authenticate a request using Basic Authentication
servant-client-core/src/Servant/Client/Core/Internal/ClientError.hs → servant-client-core/src/Servant/Client/Core/ClientError.hsrenamed+11−7
@@ -8,7 +8,9 @@
8{-# LANGUAGE RankNTypes #-}
8{-# LANGUAGE RankNTypes #-}
9{-# LANGUAGE ScopedTypeVariables #-}
9{-# LANGUAGE ScopedTypeVariables #-}
10{-# LANGUAGE TypeFamilies #-}
10{-# LANGUAGE TypeFamilies #-}
11−module Servant.Client.Core.Internal.ClientError where
11+module Servant.Client.Core.ClientError (
12+ ServantError (..),
13+ ) where
12
14
13import Prelude ()
15import Prelude ()
14import Prelude.Compat
16import Prelude.Compat
@@ -19,20 +21,22 @@ import Control.Exception
19 (SomeException (..))
21 (SomeException (..))
20import Control.Monad.Catch
22import Control.Monad.Catch
21 (Exception)
23 (Exception)
22−import qualified Data.ByteString as BS
24+import qualified Data.ByteString as BS
23import Data.Text
25import Data.Text
24 (Text)
26 (Text)
25import Data.Typeable
27import Data.Typeable
26 (Typeable, typeOf)
28 (Typeable, typeOf)
27import GHC.Generics
29import GHC.Generics
28 (Generic)
30 (Generic)
29−import Network.HTTP.Media (MediaType)
31+import Network.HTTP.Media
32+ (MediaType)
30import Network.HTTP.Types ()
33import Network.HTTP.Types ()
31
34
32−import Servant.Client.Core.Internal.BaseUrl
35+import Servant.Client.Core.BaseUrl
33−import Servant.Client.Core.Internal.Request
36+import Servant.Client.Core.Internal
37+ (mediaTypeRnf)
38+import Servant.Client.Core.Request
34−import Servant.Client.Core.Internal.Response
39+import Servant.Client.Core.Response
35−
36
40
37
41
38-- | A type representing possible errors in a request
42-- | A type representing possible errors in a request
servant-client-core/src/Servant/Client/Core/Internal/HasClient.hs → servant-client-core/src/Servant/Client/Core/HasClient.hsrenamed+41−7
@@ -11,11 +11,17 @@
11{-# LANGUAGE TypeOperators #-}
11{-# LANGUAGE TypeOperators #-}
12{-# LANGUAGE UndecidableInstances #-}
12{-# LANGUAGE UndecidableInstances #-}
13
13
14−module Servant.Client.Core.Internal.HasClient where
14+module Servant.Client.Core.HasClient (
15+ clientIn,
16+ HasClient (..),
17+ EmptyClient (..),
18+ ) where
15
19
16import Prelude ()
20import Prelude ()
17import Prelude.Compat
21import Prelude.Compat
18
22
23+import Control.Monad
24+ (unless)
19import qualified Data.ByteString.Lazy as BL
25import qualified Data.ByteString.Lazy as BL
20import Data.Foldable
26import Data.Foldable
21 (toList)
27 (toList)
@@ -25,6 +31,9 @@ import Data.Proxy
25 (Proxy (Proxy))
31 (Proxy (Proxy))
26import Data.Sequence
32import Data.Sequence
27 (fromList)
33 (fromList)
34+import qualified Data.Text as T
35+import Network.HTTP.Media
36+ (MediaType, matches, parseAccept, (//))
28import Data.String
37import Data.String
29 (fromString)
38 (fromString)
30import Data.Text
39import Data.Text
@@ -48,12 +57,12 @@ import Servant.API.ContentTypes
48import Servant.API.Modifiers
57import Servant.API.Modifiers
49 (FoldRequired, RequiredArgument, foldRequiredArgument)
58 (FoldRequired, RequiredArgument, foldRequiredArgument)
50
59
51−import Servant.Client.Core.Internal.Auth
60+import Servant.Client.Core.Auth
52−import Servant.Client.Core.Internal.BasicAuth
61+import Servant.Client.Core.BasicAuth
53−import Servant.Client.Core.Internal.ClientError
62+import Servant.Client.Core.ClientError
54−import Servant.Client.Core.Internal.Request
63+import Servant.Client.Core.Request
55−import Servant.Client.Core.Internal.Response
64+import Servant.Client.Core.Response
56−import Servant.Client.Core.Internal.RunClient
65+import Servant.Client.Core.RunClient
57
66
58-- * Accessing APIs as a Client
67-- * Accessing APIs as a Client
59
68
@@ -627,6 +636,7 @@ instance HasClient m api => HasClient m (BasicAuth realm usr :> api) where
627 hoistClientMonad pm (Proxy :: Proxy api) f (cl bauth)
636 hoistClientMonad pm (Proxy :: Proxy api) f (cl bauth)
628
637
629
638
639+
630{- Note [Non-Empty Content Types]
640{- Note [Non-Empty Content Types]
631~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
641~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
632Rather than have
642Rather than have
@@ -642,3 +652,27 @@ non-empty lists, but is otherwise more specific, no instance will be overall
642more specific. This in turn generally means adding yet another instance (one
652more specific. This in turn generally means adding yet another instance (one
643for empty and one for non-empty lists).
653for empty and one for non-empty lists).
644-}
654-}
655+
656+-------------------------------------------------------------------------------
657+-- helpers
658+-------------------------------------------------------------------------------
659+
660+checkContentTypeHeader :: RunClient m => Response -> m MediaType
661+checkContentTypeHeader response =
662+ case lookup "Content-Type" $ toList $ responseHeaders response of
663+ Nothing -> return $ "application"//"octet-stream"
664+ Just t -> case parseAccept t of
665+ Nothing -> throwServantError $ InvalidContentTypeHeader response
666+ Just t' -> return t'
667+
668+decodedAs :: forall ct a m. (MimeUnrender ct a, RunClient m)
669+ => Response -> Proxy ct -> m a
670+decodedAs response ct = do
671+ responseContentType <- checkContentTypeHeader response
672+ unless (any (matches responseContentType) accept) $
673+ throwServantError $ UnsupportedContentType responseContentType response
674+ case mimeUnrender ct $ responseBody response of
675+ Left err -> throwServantError $ DecodeFailure (T.pack err) response
676+ Right val -> return val
677+ where
678+ accept = toList $ contentTypes ct
servant-client-core/src/Servant/Client/Core/Internal.hsnew file+12
@@ -0,0 +1,12 @@
1+module Servant.Client.Core.Internal where
2+
3+import Control.DeepSeq
4+ (rnf)
5+import Network.HTTP.Media
6+ (MediaType, mainType, parameters, subType)
7+
8+mediaTypeRnf :: MediaType -> ()
9+mediaTypeRnf mt =
10+ rnf (mainType mt) `seq`
11+ rnf (subType mt) `seq`
12+ rnf (parameters mt)
servant-client-core/src/Servant/Client/Core/Internal/ClientF.hsdeleted−12
@@ -1,12 +0,0 @@
1−{-# LANGUAGE DeriveFunctor #-}
2−module Servant.Client.Core.Internal.ClientF where
3−
4−import Servant.Client.Core.Internal.Request
5−import Servant.Client.Core.Internal.Response
6−import Servant.Client.Core.Internal.ClientError
7−
8−data ClientF a
9− = RunRequest Request (Response -> a)
10− | StreamingRequest Request (StreamingResponse -> a)
11− | Throw ServantError
12− deriving (Functor)
servant-client-core/src/Servant/Client/Core/Internal/Generic.hsdeleted−155
@@ -1,155 +0,0 @@
1−{-# LANGUAGE DataKinds #-}
2−{-# LANGUAGE DefaultSignatures #-}
3−{-# LANGUAGE FlexibleContexts #-}
4−{-# LANGUAGE FlexibleInstances #-}
5−{-# LANGUAGE MultiParamTypeClasses #-}
6−{-# LANGUAGE TypeFamilies #-}
7−{-# LANGUAGE TypeOperators #-}
8−{-# LANGUAGE UndecidableInstances #-}
9−
10−module Servant.Client.Core.Internal.Generic where
11−
12−import Generics.SOP
13− (Code, Generic, I (..), NP (..), NS (Z), SOP (..), to)
14−import Servant.API
15− ((:<|>) (..))
16−
17−-- | This class allows us to match client structure with client functions
18−-- produced with 'client' without explicit pattern-matching.
19−--
20−-- The client structure needs a 'Generics.SOP.Generic' instance.
21−--
22−-- Example:
23−--
24−-- > type API
25−-- > = "foo" :> Capture "x" Int :> Get '[JSON] Int
26−-- > :<|> "bar" :> QueryParam "a" Char :> QueryParam "b" String :> Post '[JSON] [Int]
27−-- > :<|> Capture "nested" Int :> NestedAPI
28−-- >
29−-- > type NestedAPI
30−-- > = Get '[JSON] String
31−-- > :<|> "baz" :> QueryParam "c" Char :> Post '[JSON] ()
32−-- >
33−-- > data APIClient = APIClient
34−-- > { getFoo :: Int -> ClientM Int
35−-- > , postBar :: Maybe Char -> Maybe String -> ClientM [Int]
36−-- > , mkNestedClient :: Int -> NestedClient
37−-- > } deriving GHC.Generic
38−-- >
39−-- > instance Generics.SOP.Generic APIClient
40−-- > instance (Client API ~ client) => ClientLike client APIClient
41−-- >
42−-- > data NestedClient = NestedClient
43−-- > { getString :: ClientM String
44−-- > , postBaz :: Maybe Char -> ClientM ()
45−-- > } deriving GHC.Generic
46−-- >
47−-- > instance Generics.SOP.Generic NestedClient
48−-- > instance (Client NestedAPI ~ client) => ClientLike client NestedClient
49−-- >
50−-- > mkAPIClient :: APIClient
51−-- > mkAPIClient = mkClient (client (Proxy :: Proxy API))
52−--
53−-- By default, left-nested alternatives are expanded:
54−--
55−-- > type API1
56−-- > = "foo" :> Capture "x" Int :> Get '[JSON] Int
57−-- > :<|> "bar" :> QueryParam "a" Char :> Post '[JSON] String
58−-- >
59−-- > type API2
60−-- > = "baz" :> QueryParam "c" Char :> Post '[JSON] ()
61−-- >
62−-- > type API = API1 :<|> API2
63−-- >
64−-- > data APIClient = APIClient
65−-- > { getFoo :: Int -> ClientM Int
66−-- > , postBar :: Maybe Char -> ClientM String
67−-- > , postBaz :: Maybe Char -> ClientM ()
68−-- > } deriving GHC.Generic
69−-- >
70−-- > instance Generics.SOP.Generic APIClient
71−-- > instance (Client API ~ client) => ClientLike client APIClient
72−-- >
73−-- > mkAPIClient :: APIClient
74−-- > mkAPIClient = mkClient (client (Proxy :: Proxy API))
75−--
76−-- If you want to define client for @API1@ as a separate data structure,
77−-- you can use 'genericMkClientP':
78−--
79−-- > data APIClient1 = APIClient1
80−-- > { getFoo :: Int -> ClientM Int
81−-- > , postBar :: Maybe Char -> ClientM String
82−-- > } deriving GHC.Generic
83−-- >
84−-- > instance Generics.SOP.Generic APIClient1
85−-- > instance (Client API1 ~ client) => ClientLike client APIClient1
86−-- >
87−-- > data APIClient = APIClient
88−-- > { mkAPIClient1 :: APIClient1
89−-- > , postBaz :: Maybe Char -> ClientM ()
90−-- > } deriving GHC.Generic
91−-- >
92−-- > instance Generics.SOP.Generic APIClient
93−-- > instance (Client API ~ client) => ClientLike client APIClient where
94−-- > mkClient = genericMkClientP
95−-- >
96−-- > mkAPIClient :: APIClient
97−-- > mkAPIClient = mkClient (client (Proxy :: Proxy API))
98−class ClientLike client custom where
99− mkClient :: client -> custom
100− default mkClient :: (Generic custom, Code custom ~ '[xs], GClientList client '[], GClientLikeL (ClientList client '[]) xs)
101− => client -> custom
102− mkClient = genericMkClientL
103−
104−instance ClientLike client custom
105− => ClientLike (a -> client) (a -> custom) where
106− mkClient c = mkClient . c
107−
108−-- | Match client structure with client functions, regarding left-nested API clients
109−-- as separate data structures.
110−class GClientLikeP client xs where
111− gMkClientP :: client -> NP I xs
112−
113−instance (GClientLikeP b (y ': xs), ClientLike a x)
114− => GClientLikeP (a :<|> b) (x ': y ': xs) where
115− gMkClientP (a :<|> b) = I (mkClient a) :* gMkClientP b
116−
117−instance ClientLike a x => GClientLikeP a '[x] where
118− gMkClientP a = I (mkClient a) :* Nil
119−
120−-- | Match client structure with client functions, expanding left-nested API clients
121−-- in the same structure.
122−class GClientLikeL (xs :: [*]) (ys :: [*]) where
123− gMkClientL :: NP I xs -> NP I ys
124−
125−instance GClientLikeL '[] '[] where
126− gMkClientL Nil = Nil
127−
128−instance (ClientLike x y, GClientLikeL xs ys) => GClientLikeL (x ': xs) (y ': ys) where
129− gMkClientL (I x :* xs) = I (mkClient x) :* gMkClientL xs
130−
131−type family ClientList (client :: *) (acc :: [*]) :: [*] where
132− ClientList (a :<|> b) acc = ClientList a (ClientList b acc)
133− ClientList a acc = a ': acc
134−
135−class GClientList client (acc :: [*]) where
136− gClientList :: client -> NP I acc -> NP I (ClientList client acc)
137−
138−instance (GClientList b acc, GClientList a (ClientList b acc))
139− => GClientList (a :<|> b) acc where
140− gClientList (a :<|> b) acc = gClientList a (gClientList b acc)
141−
142−instance {-# OVERLAPPABLE #-} (ClientList client acc ~ (client ': acc))
143− => GClientList client acc where
144− gClientList c acc = I c :* acc
145−
146−-- | Generate client structure from client type, expanding left-nested API (done by default).
147−genericMkClientL :: (Generic custom, Code custom ~ '[xs], GClientList client '[], GClientLikeL (ClientList client '[]) xs)
148− => client -> custom
149−genericMkClientL = to . SOP . Z . gMkClientL . flip gClientList Nil
150−
151−-- | Generate client structure from client type, regarding left-nested API clients as separate data structures.
152−genericMkClientP :: (Generic custom, Code custom ~ '[xs], GClientLikeP client xs)
153− => client -> custom
154−genericMkClientP = to . SOP . Z . gMkClientP
155−
servant-client-core/src/Servant/Client/Core/Internal/RunClient.hsdeleted−67
@@ -1,67 +0,0 @@
1−{-# LANGUAGE FlexibleContexts #-}
2−{-# LANGUAGE MultiParamTypeClasses #-}
3−{-# LANGUAGE OverloadedStrings #-}
4−{-# LANGUAGE ScopedTypeVariables #-}
5−{-# LANGUAGE TypeFamilies #-}
6−-- | Types for possible backends to run client-side `Request` queries
7−module Servant.Client.Core.Internal.RunClient where
8−
9−import Prelude ()
10−import Prelude.Compat
11−
12−import Control.Monad
13− (unless)
14−import Control.Monad.Free
15− (Free (..), liftF)
16−import Data.Foldable
17− (toList)
18−import Data.Proxy
19− (Proxy)
20−import qualified Data.Text as T
21−import Network.HTTP.Media
22− (MediaType, matches, parseAccept, (//))
23−import Servant.API
24− (MimeUnrender, contentTypes, mimeUnrender)
25−
26−import Servant.Client.Core.Internal.ClientF
27−import Servant.Client.Core.Internal.Request
28−import Servant.Client.Core.Internal.Response
29−import Servant.Client.Core.Internal.ClientError
30−
31−class Monad m => RunClient m where
32− -- | How to make a request.
33− runRequest :: Request -> m Response
34− throwServantError :: ServantError -> m a
35−
36−class RunClient m => RunStreamingClient m where
37− withStreamingRequest :: Request -> (StreamingResponse -> IO a) -> m a
38−
39−checkContentTypeHeader :: RunClient m => Response -> m MediaType
40−checkContentTypeHeader response =
41− case lookup "Content-Type" $ toList $ responseHeaders response of
42− Nothing -> return $ "application"//"octet-stream"
43− Just t -> case parseAccept t of
44− Nothing -> throwServantError $ InvalidContentTypeHeader response
45− Just t' -> return t'
46−
47−decodedAs :: forall ct a m. (MimeUnrender ct a, RunClient m)
48− => Response -> Proxy ct -> m a
49−decodedAs response contentType = do
50− responseContentType <- checkContentTypeHeader response
51− unless (any (matches responseContentType) accept) $
52− throwServantError $ UnsupportedContentType responseContentType response
53− case mimeUnrender contentType $ responseBody response of
54− Left err -> throwServantError $ DecodeFailure (T.pack err) response
55− Right val -> return val
56− where
57− accept = toList $ contentTypes contentType
58−
59−instance ClientF ~ f => RunClient (Free f) where
60− runRequest req = liftF (RunRequest req id)
61− throwServantError = liftF . Throw
62−
63−{-
64−Free and streaming?
65−instance ClientF ~ f => RunStreamingClient (Free f) where
66− streamingRequest req = liftF (StreamingRequest req id)
67−-}
servant-client-core/src/Servant/Client/Core/Reexport.hs+5−9
@@ -11,10 +11,7 @@ module Servant.Client.Core.Reexport
11 , StreamingResponse
11 , StreamingResponse
12 , ResponseF(..)
12 , ResponseF(..)
13
13
14− -- * Generic Client
14+ -- * Data types
15− , ClientLike(..)
16− , genericMkClientL
17− , genericMkClientP
18 , ServantError(..)
15 , ServantError(..)
19 , EmptyClient(..)
16 , EmptyClient(..)
20
17
@@ -27,8 +24,7 @@ module Servant.Client.Core.Reexport
27 ) where
24 ) where
28
25
29
26
30−import Servant.Client.Core.Internal.BaseUrl
27+import Servant.Client.Core.BaseUrl
31−import Servant.Client.Core.Internal.Generic
28+import Servant.Client.Core.HasClient
32−import Servant.Client.Core.Internal.HasClient
33−import Servant.Client.Core.Internal.Response
29+import Servant.Client.Core.Response
34−import Servant.Client.Core.Internal.ClientError
30+import Servant.Client.Core.ClientError
servant-client-core/src/Servant/Client/Core/Internal/Request.hs → servant-client-core/src/Servant/Client/Core/Request.hsrenamed+20−9
@@ -8,8 +8,18 @@
8{-# LANGUAGE RankNTypes #-}
8{-# LANGUAGE RankNTypes #-}
9{-# LANGUAGE ScopedTypeVariables #-}
9{-# LANGUAGE ScopedTypeVariables #-}
10{-# LANGUAGE TypeFamilies #-}
10{-# LANGUAGE TypeFamilies #-}
11−
12−module Servant.Client.Core.Internal.Request where
11+module Servant.Client.Core.Request (
12+ Request,
13+ RequestF (..),
14+ RequestBody (..),
15+ defaultRequest,
16+ -- ** Modifiers
17+ addHeader,
18+ appendToPath,
19+ appendToQueryString,
20+ setRequestBody,
21+ setRequestBodyLBS,
22+ ) where
13
23
14import Prelude ()
24import Prelude ()
15import Prelude.Compat
25import Prelude.Compat
@@ -37,18 +47,14 @@ import Data.Typeable
37import GHC.Generics
47import GHC.Generics
38 (Generic)
48 (Generic)
39import Network.HTTP.Media
49import Network.HTTP.Media
40− (MediaType, mainType, parameters, subType)
50+ (MediaType)
41import Network.HTTP.Types
51import Network.HTTP.Types
42 (Header, HeaderName, HttpVersion (..), Method, QueryItem,
52 (Header, HeaderName, HttpVersion (..), Method, QueryItem,
43 http11, methodGet)
53 http11, methodGet)
44import Servant.API
54import Servant.API
45 (ToHttpApiData, toEncodedUrlPiece, toHeader, SourceIO)
55 (ToHttpApiData, toEncodedUrlPiece, toHeader, SourceIO)
46
56
47−mediaTypeRnf :: MediaType -> ()
48−mediaTypeRnf mt =
57+import Servant.Client.Core.Internal (mediaTypeRnf)
49− rnf (mainType mt) `seq`
50− rnf (subType mt) `seq`
51− rnf (parameters mt)
52
58
53data RequestF body path = Request
59data RequestF body path = Request
54 { requestPath :: path
60 { requestPath :: path
@@ -84,7 +90,7 @@ instance (NFData path, NFData body) => NFData (RequestF body path) where
84
90
85type Request = RequestF RequestBody Builder.Builder
91type Request = RequestF RequestBody Builder.Builder
86
92
87−-- | The request body. A replica of the @http-client@ @RequestBody@.
93+-- | The request body. R replica of the @http-client@ @RequestBody@.
88data RequestBody
94data RequestBody
89 = RequestBodyLBS LBS.ByteString
95 = RequestBodyLBS LBS.ByteString
90 | RequestBodyBS BS.ByteString
96 | RequestBodyBS BS.ByteString
@@ -95,6 +101,11 @@ instance Show RequestBody where
95 showsPrec d (RequestBodyLBS lbs) = showParen (d > 10)
101 showsPrec d (RequestBodyLBS lbs) = showParen (d > 10)
96 $ showString "RequestBodyLBS "
102 $ showString "RequestBodyLBS "
97 . showsPrec 11 lbs
103 . showsPrec 11 lbs
104+ showsPrec d (RequestBodyBS bs) = showParen (d > 10)
105+ $ showString "RequestBodyBS "
106+ . showsPrec 11 bs
107+ showsPrec d (RequestBodySource _) = showParen (d > 10)
108+ $ showString "RequestBodySource <IO>"
98
109
99-- A GET request to the top-level path
110-- A GET request to the top-level path
100defaultRequest :: Request
111defaultRequest :: Request
servant-client-core/src/Servant/Client/Core/Internal/Response.hs → servant-client-core/src/Servant/Client/Core/Response.hsrenamed+5−1
@@ -8,7 +8,11 @@
8{-# LANGUAGE ScopedTypeVariables #-}
8{-# LANGUAGE ScopedTypeVariables #-}
9{-# LANGUAGE TypeFamilies #-}
9{-# LANGUAGE TypeFamilies #-}
10
10
11−module Servant.Client.Core.Internal.Response where
11+module Servant.Client.Core.Response (
12+ Response,
13+ StreamingResponse,
14+ ResponseF (..),
15+ ) where
12
16
13import Prelude ()
17import Prelude ()
14import Prelude.Compat
18import Prelude.Compat
servant-client-core/src/Servant/Client/Core/RunClient.hsnew file+46
@@ -0,0 +1,46 @@
1+{-# LANGUAGE DeriveFunctor #-}
2+{-# LANGUAGE FlexibleContexts #-}
3+{-# LANGUAGE MultiParamTypeClasses #-}
4+{-# LANGUAGE OverloadedStrings #-}
5+{-# LANGUAGE ScopedTypeVariables #-}
6+{-# LANGUAGE TypeFamilies #-}
7+-- | Types for possible backends to run client-side `Request` queries
8+module Servant.Client.Core.RunClient (
9+ RunClient (..),
10+ RunStreamingClient (..),
11+ ClientF (..),
12+ ) where
13+
14+import Prelude ()
15+import Prelude.Compat
16+
17+import Control.Monad.Free
18+ (Free (..), liftF)
19+
20+import Servant.Client.Core.ClientError
21+import Servant.Client.Core.Request
22+import Servant.Client.Core.Response
23+
24+class Monad m => RunClient m where
25+ -- | How to make a request.
26+ runRequest :: Request -> m Response
27+ throwServantError :: ServantError -> m a
28+
29+class RunClient m => RunStreamingClient m where
30+ withStreamingRequest :: Request -> (StreamingResponse -> IO a) -> m a
31+
32+-------------------------------------------------------------------------------
33+-- Free
34+-------------------------------------------------------------------------------
35+
36+-- | 'ClientF' cannot stream.
37+--
38+-- Compare to 'RunClient'.
39+data ClientF a
40+ = RunRequest Request (Response -> a)
41+ | Throw ServantError
42+ deriving (Functor)
43+
44+instance ClientF ~ f => RunClient (Free f) where
45+ runRequest req = liftF (RunRequest req id)
46+ throwServantError = liftF . Throw
servant-client-core/src/Servant/Client/Free.hs+1−1
@@ -11,8 +11,8 @@ import Control.Monad.Free
11import Data.Proxy
11import Data.Proxy
12 (Proxy (..))
12 (Proxy (..))
13import Servant.Client.Core
13import Servant.Client.Core
14−import Servant.Client.Core.Internal.ClientF
15import Servant.Client.Core.Reexport
14import Servant.Client.Core.Reexport
15+import Servant.Client.Core.RunClient
16
16
17client :: HasClient (Free ClientF) api => Proxy api -> Client (Free ClientF) api
17client :: HasClient (Free ClientF) api => Proxy api -> Client (Free ClientF) api
18client api = api `clientIn` (Proxy :: Proxy (Free ClientF))
18client api = api `clientIn` (Proxy :: Proxy (Free ClientF))
servant-client-core/test/Servant/Client/Core/Internal/BaseUrlSpec.hs+1−1
@@ -8,7 +8,7 @@ import Prelude.Compat
8import Test.Hspec
8import Test.Hspec
9import Test.QuickCheck
9import Test.QuickCheck
10
10
11−import Servant.Client.Core.Internal.BaseUrl
11+import Servant.Client.Core.BaseUrl
12
12
13spec :: Spec
13spec :: Spec
14spec = do
14spec = do
servant-client-ghcjs/servant-client-ghcjs.cabal+6−7
@@ -36,10 +36,10 @@ library
36 Servant.Client.Ghcjs
36 Servant.Client.Ghcjs
37 Servant.Client.Internal.XhrClient
37 Servant.Client.Internal.XhrClient
38 build-depends:
38 build-depends:
39− base >= 4.7 && < 4.12
39+ base >= 4.11 && < 4.12
40 , bytestring >= 0.10 && < 0.11
40 , bytestring >= 0.10 && < 0.11
41 , case-insensitive >= 1.2.0.0 && < 1.3.0.0
41 , case-insensitive >= 1.2.0.0 && < 1.3.0.0
42− , containers >= 0.5 && < 0.6
42+ , containers >= 0.5 && < 0.7
43 , exceptions >= 0.8 && < 0.11
43 , exceptions >= 0.8 && < 0.11
44 , ghcjs-base >= 0.2.0.0 && < 0.3.0.0
44 , ghcjs-base >= 0.2.0.0 && < 0.3.0.0
45 , ghcjs-prim >= 0.1.0.0 && < 0.2.0.0
45 , ghcjs-prim >= 0.1.0.0 && < 0.2.0.0
@@ -47,7 +47,7 @@ library
47 , http-types >= 0.12 && < 0.13
47 , http-types >= 0.12 && < 0.13
48 , monad-control >= 1.0.0.4 && < 1.1
48 , monad-control >= 1.0.0.4 && < 1.1
49 , mtl >= 2.2.2 && < 2.3
49 , mtl >= 2.2.2 && < 2.3
50− , semigroupoids >= 4.3 && < 5.3
50+ , semigroupoids >= 5.3 && < 5.4
51 , string-conversions >= 0.3 && < 0.5
51 , string-conversions >= 0.3 && < 0.5
52 , transformers >= 0.3 && < 0.6
52 , transformers >= 0.3 && < 0.6
53 , transformers-base >= 0.4.4 && < 0.5
53 , transformers-base >= 0.4.4 && < 0.5
@@ -55,10 +55,9 @@ library
55
55
56 -- strict, as we re-export stuff
56 -- strict, as we re-export stuff
57 build-depends:
57 build-depends:
58+ servant == 0.15.*,
58− servant-client-core == 0.15
59+ servant-client-core == 0.15.*
59
60
60 hs-source-dirs: src
61 hs-source-dirs: src
61 default-language: Haskell2010
62 default-language: Haskell2010
62− ghc-options: -Wall
63− if impl(ghc >= 8.0)
64− ghc-options: -Wno-redundant-constraints
63+ ghc-options: -Wall -Wno-redundant-constraints
servant-client-ghcjs/src/Servant/Client/Internal/XhrClient.hs+38−36
@@ -18,35 +18,48 @@ import Control.Arrow
18import Control.Concurrent
18import Control.Concurrent
19import Control.Exception
19import Control.Exception
20import Control.Monad
20import Control.Monad
21−import Control.Monad.Base (MonadBase (..))
21+import Control.Monad.Base
22+ (MonadBase (..))
22−import Control.Monad.Catch (MonadCatch, MonadThrow)
23+import Control.Monad.Catch
24+ (MonadCatch, MonadThrow)
23−import Control.Monad.Error.Class (MonadError (..))
25+import Control.Monad.Error.Class
26+ (MonadError (..))
24import Control.Monad.Reader
27import Control.Monad.Reader
25−import Control.Monad.Trans.Control (MonadBaseControl (..))
28+import Control.Monad.Trans.Control
29+ (MonadBaseControl (..))
26import Control.Monad.Trans.Except
30import Control.Monad.Trans.Except
31+import Data.Bifunctor
32+ (bimap)
33+import Data.ByteString.Builder
27−import Data.ByteString.Builder (toLazyByteString)
34+ (toLazyByteString)
28−import qualified Data.ByteString.Char8 as BS
35+import qualified Data.ByteString.Char8 as BS
29−import qualified Data.ByteString.Lazy as BL
36+import qualified Data.ByteString.Lazy as BL
30import Data.CaseInsensitive
37import Data.CaseInsensitive
31import Data.Char
38import Data.Char
32−import Data.Foldable (toList)
39+import Data.Foldable
40+ (toList)
33−import Data.Functor.Alt (Alt (..))
41+import Data.Functor.Alt
34−import Data.IORef (modifyIORef, newIORef, readIORef)
42+ (Alt (..))
43+import Data.Proxy
35−import Data.Proxy (Proxy (..))
44+ (Proxy (..))
36−import qualified Data.Sequence as Seq
45+import qualified Data.Sequence as Seq
37import Data.String.Conversions
46import Data.String.Conversions
38−import Data.Typeable (Typeable)
47+import Data.Typeable
48+ (Typeable)
39import Foreign.StablePtr
49import Foreign.StablePtr
40import GHC.Generics
50import GHC.Generics
41−import qualified GHCJS.Buffer as Buffer
51+import qualified GHCJS.Buffer as Buffer
42import GHCJS.Foreign.Callback
52import GHCJS.Foreign.Callback
43import GHCJS.Prim
53import GHCJS.Prim
44import GHCJS.Types
54import GHCJS.Types
45−import JavaScript.TypedArray.ArrayBuffer ( ArrayBuffer )
55+import JavaScript.TypedArray.ArrayBuffer
56+ (ArrayBuffer)
46import JavaScript.Web.Location
57import JavaScript.Web.Location
47−import Network.HTTP.Media (renderHeader)
58+import Network.HTTP.Media
59+ (renderHeader)
48import Network.HTTP.Types
60import Network.HTTP.Types
49import Servant.Client.Core
61import Servant.Client.Core
62+import qualified Servant.Types.SourceT as S
50
63
51newtype JSXMLHttpRequest = JSXMLHttpRequest JSVal
64newtype JSXMLHttpRequest = JSXMLHttpRequest JSVal
52
65
@@ -110,9 +123,6 @@ instance RunClient ClientM where
110 runRequest = performRequest
123 runRequest = performRequest
111 throwServantError = throwError
124 throwServantError = throwError
112
125
113−instance ClientLike (ClientM a) (ClientM a) where
114− mkClient = id
115−
116runClientMOrigin :: ClientM a -> ClientEnv -> IO (Either ServantError a)
126runClientMOrigin :: ClientM a -> ClientEnv -> IO (Either ServantError a)
117runClientMOrigin cm env = runExceptT $ flip runReaderT env $ runClientM' cm
127runClientMOrigin cm env = runExceptT $ flip runReaderT env $ runClientM' cm
118
128
@@ -150,8 +160,9 @@ performRequest req = do
150 resp <- toResponse xhr
160 resp <- toResponse xhr
151
161
152 let status = statusCode (responseStatusCode resp)
162 let status = statusCode (responseStatusCode resp)
153− unless (status >= 200 && status < 300) $
163+ unless (status >= 200 && status < 300) $ do
164+ let f b = (burl, BL.toStrict $ toLazyByteString b)
154− throwError $ FailureResponse resp
165+ throwError $ FailureResponse (bimap (const ()) f req) resp
155
166
156 pure resp
167 pure resp
157
168
@@ -270,26 +281,17 @@ toBody request = case requestBody request of
270 where
281 where
271 go :: RequestBody -> IO ArrayBuffer
282 go :: RequestBody -> IO ArrayBuffer
272 go x = case x of
283 go x = case x of
273− RequestBodyLBS x -> return $ mBody $ BL.toStrict x
284+ RequestBodyLBS x -> return $ mBody $ BL.toStrict x
274− RequestBodyBS x -> return $ mBody x
285+ RequestBodyBS x -> return $ mBody x
275− RequestBodyBuilder _ x -> return $ mBody $ BL.toStrict $ toLazyByteString x
286+ RequestBodySource xs -> runExceptT (S.runSourceT xs) >>= \e -> case e of
276− RequestBodyStream _ x -> mBody <$> readBody x
287+ Left err -> fail err
277− RequestBodyStreamChunked x -> mBody <$> readBody x
288+ Right bss -> return $ mBody $ BL.toStrict $ mconcat bss
278− RequestBodyIO x -> x >>= go
279
289
280 mBody :: BS.ByteString -> ArrayBuffer
290 mBody :: BS.ByteString -> ArrayBuffer
281 mBody bs = js_bufferSlice offset len $ Buffer.getArrayBuffer buffer
291 mBody bs = js_bufferSlice offset len $ Buffer.getArrayBuffer buffer
282 where
292 where
283 (buffer, offset, len) = Buffer.fromByteString bs
293 (buffer, offset, len) = Buffer.fromByteString bs
284
294
285− readBody :: ((IO BS.ByteString -> IO ()) -> IO a) -> IO BS.ByteString
286− readBody writer = do
287− m <- newIORef mempty
288− _ <- writer (\bsAct -> do
289− bs <- bsAct
290− modifyIORef m (<> bs))
291− readIORef m
292−
293foreign import javascript unsafe "$3.slice($1, $1 + $2)"
295foreign import javascript unsafe "$3.slice($1, $1 + $2)"
294 js_bufferSlice :: Int -> Int -> ArrayBuffer -> ArrayBuffer
296 js_bufferSlice :: Int -> Int -> ArrayBuffer -> ArrayBuffer
295
297
@@ -301,7 +303,7 @@ toResponse :: JSXMLHttpRequest -> ClientM Response
301toResponse xhr = do
303toResponse xhr = do
302 status <- liftIO $ getStatus xhr
304 status <- liftIO $ getStatus xhr
303 case status of
305 case status of
304− 0 -> throwError $ ConnectionError "connection error"
306+ 0 -> throwError $ ConnectionError (SomeException (userError "connection error"))
305 _ -> liftIO $ do
307 _ -> liftIO $ do
306 statusText <- cs <$> getStatusText xhr
308 statusText <- cs <$> getStatusText xhr
307 headers <- parseHeaders <$> getAllResponseHeaders xhr
309 headers <- parseHeaders <$> getAllResponseHeaders xhr
servant-client/servant-client.cabal−1
@@ -116,7 +116,6 @@ test-suite spec
116 -- Additonal dependencies
116 -- Additonal dependencies
117 build-depends:
117 build-depends:
118 entropy >= 0.4.1.3 && < 0.5
118 entropy >= 0.4.1.3 && < 0.5
119− , generics-sop >= 0.4.0.1 && < 0.5
120 , hspec >= 2.6.0 && < 2.7
119 , hspec >= 2.6.0 && < 2.7
121 , HUnit >= 1.6.0.0 && < 1.7
120 , HUnit >= 1.6.0.0 && < 1.7
122 , network >= 2.8.0.0 && < 3.1
121 , network >= 2.8.0.0 && < 3.1
servant-client/src/Servant/Client/Internal/HttpClient.hs−3
@@ -143,9 +143,6 @@ instance RunClient ClientM where
143 runRequest = performRequest
143 runRequest = performRequest
144 throwServantError = throwError
144 throwServantError = throwError
145
145
146−instance ClientLike (ClientM a) (ClientM a) where
147− mkClient = id
148−
149runClientM :: ClientM a -> ClientEnv -> IO (Either ServantError a)
146runClientM :: ClientM a -> ClientEnv -> IO (Either ServantError a)
150runClientM cm env = runExceptT $ flip runReaderT env $ unClientM cm
147runClientM cm env = runExceptT $ flip runReaderT env $ unClientM cm
151
148
servant-client/src/Servant/Client/Internal/HttpClient/Streaming.hs−3
@@ -118,9 +118,6 @@ instance RunClient ClientM where
118instance RunStreamingClient ClientM where
118instance RunStreamingClient ClientM where
119 withStreamingRequest = performWithStreamingRequest
119 withStreamingRequest = performWithStreamingRequest
120
120
121−instance ClientLike (ClientM a) (ClientM a) where
122− mkClient = id
123−
124withClientM :: ClientM a -> ClientEnv -> (Either ServantError a -> IO b) -> IO b
121withClientM :: ClientM a -> ClientEnv -> (Either ServantError a -> IO b) -> IO b
125withClientM cm env k =
122withClientM cm env k =
126 let Codensity f = runExceptT $ flip runReaderT env $ unClientM cm
123 let Codensity f = runExceptT $ flip runReaderT env $ unClientM cm
servant-client/test/Servant/ClientSpec.hs+2−67
@@ -48,7 +48,6 @@ import Data.Monoid ()
48import Data.Proxy
48import Data.Proxy
49import Data.Semigroup
49import Data.Semigroup
50 ((<>))
50 ((<>))
51−import qualified Generics.SOP as SOP
52import GHC.Generics
51import GHC.Generics
53 (Generic)
52 (Generic)
54import qualified Network.HTTP.Client as C
53import qualified Network.HTTP.Client as C
@@ -72,8 +71,8 @@ import Servant.API
72 Headers, JSON, NoContent (NoContent), Post, Put, QueryFlag,
71 Headers, JSON, NoContent (NoContent), Post, Put, QueryFlag,
73 QueryParam, QueryParams, Raw, ReqBody, addHeader, getHeaders)
72 QueryParam, QueryParams, Raw, ReqBody, addHeader, getHeaders)
74import Servant.Client
73import Servant.Client
75−import qualified Servant.Client.Core.Internal.Auth as Auth
74+import qualified Servant.Client.Core.Auth as Auth
76−import qualified Servant.Client.Core.Internal.Request as Req
75+import qualified Servant.Client.Core.Request as Req
77import Servant.Server
76import Servant.Server
78import Servant.Server.Experimental.Auth
77import Servant.Server.Experimental.Auth
79import Servant.Test.ComprehensiveAPI
78import Servant.Test.ComprehensiveAPI
@@ -88,7 +87,6 @@ spec = describe "Servant.Client" $ do
88 wrappedApiSpec
87 wrappedApiSpec
89 basicAuthSpec
88 basicAuthSpec
90 genAuthSpec
89 genAuthSpec
91− genericClientSpec
92 hoistClientSpec
90 hoistClientSpec
93 connectionErrorSpec
91 connectionErrorSpec
94
92
@@ -258,53 +256,6 @@ genAuthServerContext = genAuthHandler :. EmptyContext
258genAuthServer :: Application
256genAuthServer :: Application
259genAuthServer = serveWithContext genAuthAPI genAuthServerContext (const (return alice))
257genAuthServer = serveWithContext genAuthAPI genAuthServerContext (const (return alice))
260
258
261−-- * generic client stuff
262−
263−type GenericClientAPI
264− = QueryParam "sqr" Int :> Get '[JSON] Int
265− :<|> Capture "foo" String :> NestedAPI1
266−
267−data GenericClient = GenericClient
268− { getSqr :: Maybe Int -> ClientM Int
269− , mkNestedClient1 :: String -> NestedClient1
270− } deriving Generic
271−instance SOP.Generic GenericClient
272−instance (Client ClientM GenericClientAPI ~ client) => ClientLike client GenericClient
273−
274−type NestedAPI1
275− = QueryParam "int" Int :> NestedAPI2
276− :<|> QueryParam "id" Char :> Get '[JSON] Char
277−
278−data NestedClient1 = NestedClient1
279− { mkNestedClient2 :: Maybe Int -> NestedClient2
280− , idChar :: Maybe Char -> ClientM Char
281− } deriving Generic
282−instance SOP.Generic NestedClient1
283−instance (Client ClientM NestedAPI1 ~ client) => ClientLike client NestedClient1
284−
285−type NestedAPI2
286− = "sum" :> Capture "first" Int :> Capture "second" Int :> Get '[JSON] Int
287− :<|> "void" :> Post '[JSON] ()
288−
289−data NestedClient2 = NestedClient2
290− { getSum :: Int -> Int -> ClientM Int
291− , doNothing :: ClientM ()
292− } deriving Generic
293−instance SOP.Generic NestedClient2
294−instance (Client ClientM NestedAPI2 ~ client) => ClientLike client NestedClient2
295−
296−genericClientServer :: Application
297−genericClientServer = serve (Proxy :: Proxy GenericClientAPI) (
298− (\ mx -> case mx of
299− Just x -> return (x*x)
300− Nothing -> throwError $ ServantErr 400 "missing parameter" "" []
301− )
302− :<|> nestedServer1
303− )
304− where
305− nestedServer1 _str = nestedServer2 :<|> (maybe (throwError $ ServantErr 400 "missing parameter" "" []) return)
306− nestedServer2 _int = (\ x y -> return (x + y)) :<|> return ()
307−
308{-# NOINLINE manager' #-}
259{-# NOINLINE manager' #-}
309manager' :: C.Manager
260manager' :: C.Manager
310manager' = unsafePerformIO $ C.newManager C.defaultManagerSettings
261manager' = unsafePerformIO $ C.newManager C.defaultManagerSettings
@@ -495,22 +446,6 @@ genAuthSpec = beforeAll (startWaiApp genAuthServer) $ afterAll endWaiApp $ do
495 Left (FailureResponse _ r) <- runClient (getProtected authRequest) baseUrl
446 Left (FailureResponse _ r) <- runClient (getProtected authRequest) baseUrl
496 responseStatusCode r `shouldBe` (HTTP.Status 401 "Unauthorized")
447 responseStatusCode r `shouldBe` (HTTP.Status 401 "Unauthorized")
497
448
498−genericClientSpec :: Spec
499−genericClientSpec = beforeAll (startWaiApp genericClientServer) $ afterAll endWaiApp $ do
500− describe "Servant.Client.Generic" $ do
501−
502− let GenericClient{..} = mkClient (client (Proxy :: Proxy GenericClientAPI))
503− NestedClient1{..} = mkNestedClient1 "example"
504− NestedClient2{..} = mkNestedClient2 (Just 42)
505−
506− it "works for top-level client inClientM function" $ \(_, baseUrl) -> do
507− left show <$> runClient (getSqr (Just 5)) baseUrl `shouldReturn` Right 25
508−
509− it "works for nested clients" $ \(_, baseUrl) -> do
510− left show <$> runClient (idChar (Just 'c')) baseUrl `shouldReturn` Right 'c'
511− left show <$> runClient (getSum 3 4) baseUrl `shouldReturn` Right 7
512− left show <$> runClient doNothing baseUrl `shouldReturn` Right ()
513−
514-- * hoistClient
449-- * hoistClient
515
450
516type HoistClientAPI = Get '[JSON] Int :<|> Capture "n" Int :> Post '[JSON] Int
451type HoistClientAPI = Get '[JSON] Int :<|> Capture "n" Int :> Post '[JSON] Int
servant-http-streams/servant-http-streams.cabal+1−2
@@ -68,7 +68,7 @@ library
68 , case-insensitive
68 , case-insensitive
69 , http-streams >= 0.8.6.1 && < 0.9
69 , http-streams >= 0.8.6.1 && < 0.9
70 , http-media >= 0.7.1.3 && < 0.8
70 , http-media >= 0.7.1.3 && < 0.8
71− , io-streams >=1.5.0.1 && < 1.6
71+ , io-streams >= 1.5.0.1 && < 1.6
72 , http-types >= 0.12.2 && < 0.13
72 , http-types >= 0.12.2 && < 0.13
73 , http-common >= 0.8.2.0 && < 0.9
73 , http-common >= 0.8.2.0 && < 0.9
74 , exceptions >= 0.10.0 && < 0.11
74 , exceptions >= 0.10.0 && < 0.11
@@ -116,7 +116,6 @@ test-suite spec
116 -- Additonal dependencies
116 -- Additonal dependencies
117 build-depends:
117 build-depends:
118 entropy >= 0.4.1.3 && < 0.5
118 entropy >= 0.4.1.3 && < 0.5
119− , generics-sop >= 0.4.0.1 && < 0.5
120 , hspec >= 2.6.0 && < 2.7
119 , hspec >= 2.6.0 && < 2.7
121 , HUnit >= 1.6.0.0 && < 1.7
120 , HUnit >= 1.6.0.0 && < 1.7
122 , network >= 2.8.0.0 && < 3.1
121 , network >= 2.8.0.0 && < 3.1
servant-http-streams/src/Servant/HttpStreams/Internal.hs−3
@@ -141,9 +141,6 @@ instance RunClient ClientM where
141instance RunStreamingClient ClientM where
141instance RunStreamingClient ClientM where
142 withStreamingRequest = performWithStreamingRequest
142 withStreamingRequest = performWithStreamingRequest
143
143
144−instance ClientLike (ClientM a) (ClientM a) where
145− mkClient = id
146−
147runClientM :: NFData a => ClientM a -> ClientEnv -> IO (Either ServantError a)
144runClientM :: NFData a => ClientM a -> ClientEnv -> IO (Either ServantError a)
148runClientM cm env = withClientM cm env (evaluate . force)
145runClientM cm env = withClientM cm env (evaluate . force)
149
146
servant-http-streams/test/Servant/ClientSpec.hs+2−67
@@ -46,7 +46,6 @@ import Data.Monoid ()
46import Data.Proxy
46import Data.Proxy
47import Data.Semigroup
47import Data.Semigroup
48 ((<>))
48 ((<>))
49−import qualified Generics.SOP as SOP
50import GHC.Generics
49import GHC.Generics
51 (Generic)
50 (Generic)
52import qualified Network.HTTP.Types as HTTP
51import qualified Network.HTTP.Types as HTTP
@@ -66,8 +65,8 @@ import Servant.API
66 DeleteNoContent, EmptyAPI, FormUrlEncoded, Get, Header,
65 DeleteNoContent, EmptyAPI, FormUrlEncoded, Get, Header,
67 Headers, JSON, NoContent (NoContent), Post, Put, QueryFlag,
66 Headers, JSON, NoContent (NoContent), Post, Put, QueryFlag,
68 QueryParam, QueryParams, Raw, ReqBody, addHeader, getHeaders)
67 QueryParam, QueryParams, Raw, ReqBody, addHeader, getHeaders)
69−import qualified Servant.Client.Core.Internal.Auth as Auth
68+import qualified Servant.Client.Core.Auth as Auth
70−import qualified Servant.Client.Core.Internal.Request as Req
69+import qualified Servant.Client.Core.Request as Req
71import Servant.HttpStreams
70import Servant.HttpStreams
72import Servant.Server
71import Servant.Server
73import Servant.Server.Experimental.Auth
72import Servant.Server.Experimental.Auth
@@ -83,7 +82,6 @@ spec = describe "Servant.HttpStreams" $ do
83 wrappedApiSpec
82 wrappedApiSpec
84 basicAuthSpec
83 basicAuthSpec
85 genAuthSpec
84 genAuthSpec
86− genericClientSpec
87 hoistClientSpec
85 hoistClientSpec
88 connectionErrorSpec
86 connectionErrorSpec
89
87
@@ -256,53 +254,6 @@ genAuthServerContext = genAuthHandler :. EmptyContext
256genAuthServer :: Application
254genAuthServer :: Application
257genAuthServer = serveWithContext genAuthAPI genAuthServerContext (const (return alice))
255genAuthServer = serveWithContext genAuthAPI genAuthServerContext (const (return alice))
258
256
259−-- * generic client stuff
260−
261−type GenericClientAPI
262− = QueryParam "sqr" Int :> Get '[JSON] Int
263− :<|> Capture "foo" String :> NestedAPI1
264−
265−data GenericClient = GenericClient
266− { getSqr :: Maybe Int -> ClientM Int
267− , mkNestedClient1 :: String -> NestedClient1
268− } deriving Generic
269−instance SOP.Generic GenericClient
270−instance (Client ClientM GenericClientAPI ~ client) => ClientLike client GenericClient
271−
272−type NestedAPI1
273− = QueryParam "int" Int :> NestedAPI2
274− :<|> QueryParam "id" Char :> Get '[JSON] Char
275−
276−data NestedClient1 = NestedClient1
277− { mkNestedClient2 :: Maybe Int -> NestedClient2
278− , idChar :: Maybe Char -> ClientM Char
279− } deriving Generic
280−instance SOP.Generic NestedClient1
281−instance (Client ClientM NestedAPI1 ~ client) => ClientLike client NestedClient1
282−
283−type NestedAPI2
284− = "sum" :> Capture "first" Int :> Capture "second" Int :> Get '[JSON] Int
285− :<|> "void" :> Post '[JSON] ()
286−
287−data NestedClient2 = NestedClient2
288− { getSum :: Int -> Int -> ClientM Int
289− , doNothing :: ClientM ()
290− } deriving Generic
291−instance SOP.Generic NestedClient2
292−instance (Client ClientM NestedAPI2 ~ client) => ClientLike client NestedClient2
293−
294−genericClientServer :: Application
295−genericClientServer = serve (Proxy :: Proxy GenericClientAPI) (
296− (\ mx -> case mx of
297− Just x -> return (x*x)
298− Nothing -> throwError $ ServantErr 400 "missing parameter" "" []
299− )
300− :<|> nestedServer1
301− )
302− where
303− nestedServer1 _str = nestedServer2 :<|> (maybe (throwError $ ServantErr 400 "missing parameter" "" []) return)
304− nestedServer2 _int = (\ x y -> return (x + y)) :<|> return ()
305−
306runClient :: NFData a => ClientM a -> BaseUrl -> IO (Either ServantError a)
257runClient :: NFData a => ClientM a -> BaseUrl -> IO (Either ServantError a)
307runClient x burl = withClientEnvIO burl (runClientM x)
258runClient x burl = withClientEnvIO burl (runClientM x)
308
259
@@ -487,22 +438,6 @@ genAuthSpec = beforeAll (startWaiApp genAuthServer) $ afterAll endWaiApp $ do
487 Left (FailureResponse _ r) <- runClient (getProtected authRequest) baseUrl
438 Left (FailureResponse _ r) <- runClient (getProtected authRequest) baseUrl
488 responseStatusCode r `shouldBe` (HTTP.Status 401 "Unauthorized")
439 responseStatusCode r `shouldBe` (HTTP.Status 401 "Unauthorized")
489
440
490−genericClientSpec :: Spec
491−genericClientSpec = beforeAll (startWaiApp genericClientServer) $ afterAll endWaiApp $ do
492− describe "Servant.Client.Generic" $ do
493−
494− let GenericClient{..} = mkClient (client (Proxy :: Proxy GenericClientAPI))
495− NestedClient1{..} = mkNestedClient1 "example"
496− NestedClient2{..} = mkNestedClient2 (Just 42)
497−
498− it "works for top-level client inClientM function" $ \(_, baseUrl) -> do
499− left show <$> runClient (getSqr (Just 5)) baseUrl `shouldReturn` Right 25
500−
501− it "works for nested clients" $ \(_, baseUrl) -> do
502− left show <$> runClient (idChar (Just 'c')) baseUrl `shouldReturn` Right 'c'
503− left show <$> runClient (getSum 3 4) baseUrl `shouldReturn` Right 7
504− left show <$> runClient doNothing baseUrl `shouldReturn` Right ()
505−
506-- * hoistClient
441-- * hoistClient
507
442
508type HoistClientAPI = Get '[JSON] Int :<|> Capture "n" Int :> Post '[JSON] Int
443type HoistClientAPI = Get '[JSON] Int :<|> Capture "n" Int :> Post '[JSON] Int
stack.yaml−1
@@ -18,7 +18,6 @@ packages:
18extra-deps:
18extra-deps:
19- base-compat-0.10.5
19- base-compat-0.10.5
20- conduit-1.3.1
20- conduit-1.3.1
21−- generics-sop-0.4.0.1
22- hspec-2.6.0
21- hspec-2.6.0
23- hspec-core-2.6.0
22- hspec-core-2.6.0
24- hspec-discover-2.6.0
23- hspec-discover-2.6.0