Skip to content

Commit d10fc87

Browse files
theophile-scrivetheophile-scrive
committed
WIP
1 parent 9e0d8d2 commit d10fc87

File tree

10 files changed

+388
-247
lines changed

10 files changed

+388
-247
lines changed

‎servant-client-core/servant-client-core.cabal

+1
Original file line numberDiff line numberDiff line change
@@ -91,6 +91,7 @@ library
9191
Servant.Client.Core.Reexport
9292
Servant.Client.Core.Request
9393
Servant.Client.Core.Response
94+
Servant.Client.Core.ResponseUnrender
9495
Servant.Client.Core.RunClient
9596
Servant.Client.Free
9697
Servant.Client.Generic

‎servant-client-core/src/Servant/Client/Core/HasClient.hs

+32-40
Original file line numberDiff line numberDiff line change
@@ -1,6 +1,6 @@
11
{-# LANGUAGE CPP #-}
2+
{-# LANGUAGE ApplicativeDo #-}
23
{-# OPTIONS_GHC -Wno-missing-methods #-}
3-
{-# LANGUAGE EmptyCase #-}
44
module Servant.Client.Core.HasClient (
55
clientIn,
66
HasClient (..),
@@ -9,17 +9,19 @@ module Servant.Client.Core.HasClient (
99
(//),
1010
(/:),
1111
foldMapUnion,
12-
matchUnion
12+
matchUnion,
13+
fromSomeClientResponse
1314
) where
1415

1516
import Prelude ()
1617
import Prelude.Compat
1718

1819
import Control.Arrow
1920
(left, (+++))
21+
import qualified Data.Text as Text
2022
import Control.Monad
2123
(unless)
22-
import qualified Data.ByteString.Lazy as BL
24+
import qualified Data.ByteString.Lazy as BSL
2325
import Data.Either
2426
(partitionEithers)
2527
import Data.Constraint (Dict(..))
@@ -43,13 +45,11 @@ import Data.SOP.Constraint
4345
import Data.SOP.NP
4446
(NP (..), cpure_NP)
4547
import Data.SOP.NS
46-
(NS (S))
48+
(NS (..))
4749
import Data.String
4850
(fromString)
4951
import Data.Text
5052
(Text, pack)
51-
import Data.Proxy
52-
(Proxy (Proxy))
5353
import GHC.TypeLits
5454
(KnownNat, KnownSymbol, TypeError, symbolVal)
5555
import Network.HTTP.Types
@@ -71,7 +71,7 @@ import Servant.API.Generic
7171
(GenericMode(..), ToServant, ToServantApi
7272
, GenericServant, toServant, fromServant)
7373
import Servant.API.ContentTypes
74-
(contentTypes, AllMime (allMime), AllMimeUnrender (allMimeUnrender), AcceptHeader)
74+
(contentTypes, AllMime (allMime), AllMimeUnrender (allMimeUnrender))
7575
import Servant.API.QueryString (ToDeepQuery(..), generateDeepParam)
7676
import Servant.API.Status
7777
(statusFromNat)
@@ -87,9 +87,12 @@ import Servant.Client.Core.BasicAuth
8787
import Servant.Client.Core.ClientError
8888
import Servant.Client.Core.Request
8989
import Servant.Client.Core.Response
90+
import Servant.Client.Core.ResponseUnrender
91+
import qualified Servant.Client.Core.Response as Response
9092
import Servant.Client.Core.RunClient
91-
import Servant.API.MultiVerb
93+
import Servant.API.MultiVerb
9294
import qualified Network.HTTP.Media as M
95+
import Data.Typeable
9396

9497
-- * Accessing APIs as a Client
9598

@@ -325,7 +328,7 @@ data ClientParseError = ClientParseError MediaType String | ClientStatusMismatch
325328
deriving (Eq, Show)
326329

327330
class UnrenderResponse (cts :: [Type]) (a :: Type) where
328-
unrenderResponse :: Seq.Seq H.Header -> BL.ByteString -> Proxy cts
331+
unrenderResponse :: Seq.Seq H.Header -> BSL.ByteString -> Proxy cts
329332
-> [Either (MediaType, String) a]
330333

331334
instance {-# OVERLAPPABLE #-} AllMimeUnrender cts a => UnrenderResponse cts a where
@@ -367,15 +370,13 @@ instance {-# OVERLAPPING #-}
367370

368371
method = reflectMethod $ Proxy @method
369372
acceptStatus = statuses (Proxy @as)
370-
response <- runRequestAcceptStatus (Just acceptStatus) request {requestMethod = method, requestAccept = accept}
373+
response@Response{responseBody=body, responseStatusCode=status, responseHeaders=headers}
374+
<- runRequestAcceptStatus (Just acceptStatus) (request {requestMethod = method, requestAccept = accept})
371375
responseContentType <- checkContentTypeHeader response
372376
unless (any (matches responseContentType) accept) $ do
373377
throwClientError $ UnsupportedContentType responseContentType response
374378

375-
let status = responseStatusCode response
376-
body = responseBody response
377-
headers = responseHeaders response
378-
res = tryParsers status $ mimeUnrenders (Proxy @contentTypes) headers body
379+
let res = tryParsers status $ mimeUnrenders (Proxy @contentTypes) headers body
379380
case res of
380381
Left errors -> throwClientError $ DecodeFailure (T.pack (show errors)) response
381382
Right x -> return x
@@ -399,7 +400,7 @@ instance {-# OVERLAPPING #-}
399400
All (UnrenderResponse cts) xs =>
400401
Proxy cts ->
401402
Seq.Seq H.Header ->
402-
BL.ByteString ->
403+
BSL.ByteString ->
403404
NP ([] :.: Either (MediaType, String)) xs
404405
mimeUnrenders ctp headers body = cpure_NP
405406
(Proxy @(UnrenderResponse cts))
@@ -416,10 +417,10 @@ instance {-# OVERLAPPABLE #-}
416417

417418
hoistClientMonad _ _ f ma = f ma
418419

419-
clientWithRoute _pm Proxy req = withStreamingRequest req' $ \gres -> do
420-
let mimeUnrender' = mimeUnrender (Proxy :: Proxy ct) :: BL.ByteString -> Either String chunk
420+
clientWithRoute _pm Proxy req = withStreamingRequest req' $ \Response{responseBody=body} -> do
421+
let mimeUnrender' = mimeUnrender (Proxy :: Proxy ct) :: BSL.ByteString -> Either String chunk
421422
framingUnrender' = framingUnrender (Proxy :: Proxy framing) mimeUnrender'
422-
fromSourceIO $ framingUnrender' $ responseBody gres
423+
fromSourceIO $ framingUnrender' body
423424
where
424425
req' = req
425426
{ requestAccept = fromList [contentType (Proxy :: Proxy ct)]
@@ -436,13 +437,14 @@ instance {-# OVERLAPPING #-}
436437

437438
hoistClientMonad _ _ f ma = f ma
438439

439-
clientWithRoute _pm Proxy req = withStreamingRequest req' $ \gres -> do
440-
let mimeUnrender' = mimeUnrender (Proxy :: Proxy ct) :: BL.ByteString -> Either String chunk
440+
clientWithRoute _pm Proxy req = withStreamingRequest req' $
441+
\Response{responseBody=body, responseHeaders=headers} -> do
442+
let mimeUnrender' = mimeUnrender (Proxy :: Proxy ct) :: BSL.ByteString -> Either String chunk
441443
framingUnrender' = framingUnrender (Proxy :: Proxy framing) mimeUnrender'
442-
val <- fromSourceIO $ framingUnrender' $ responseBody gres
444+
val <- fromSourceIO $ framingUnrender' body
443445
return $ Headers
444446
{ getResponse = val
445-
, getHeadersHList = buildHeadersTo . toList $ responseHeaders gres
447+
, getHeadersHList = buildHeadersTo $ toList headers
446448
}
447449

448450
where
@@ -760,7 +762,7 @@ instance
760762

761763
sourceIO = framingRender
762764
framingP
763-
(mimeRender ctypeP :: chunk -> BL.ByteString)
765+
(mimeRender ctypeP :: chunk -> BSL.ByteString)
764766
(toSourceIO body)
765767

766768
-- | Make the querying function append @path@ to the request path.
@@ -975,19 +977,9 @@ x // f = f x
975977
(/:) :: (a -> b -> c) -> b -> a -> c
976978
(/:) = flip
977979

978-
class IsResponseList cs as where
979-
responseListRender :: AcceptHeader -> Union (ResponseTypes as) -> Maybe InternalResponse
980-
responseListUnrender :: M.MediaType -> InternalResponse -> UnrenderResult (Union (ResponseTypes as))
981-
982-
responseListStatuses :: [Status]
983-
984-
instance IsResponseList cs '[] where
985-
responseListRender _ x = case x of {}
986-
responseListUnrender _ _ = empty
987-
responseListStatuses = []
988980

989981
instance
990-
( IsResponseList cs as,
982+
( ResponseListUnrender cs as,
991983
AllMime cs,
992984
ReflectMethod method,
993985
AsUnion as r,
@@ -998,7 +990,7 @@ instance
998990
type Client m (MultiVerb method cs as r) = m r
999991

1000992
clientWithRoute _ _ req = do
1001-
response <-
993+
response@Response{responseBody=body} <-
1002994
runRequestAcceptStatus
1003995
(Just (responseListStatuses @cs @as))
1004996
req
@@ -1012,9 +1004,9 @@ instance
10121004

10131005
-- FUTUREWORK: support streaming
10141006
let sresp =
1015-
if LBS.null (responseBody response)
1016-
then SomeResponse response {responseBody = ()}
1017-
else SomeResponse response
1007+
if BSL.null body
1008+
then SomeClientResponse $ response {Response.responseBody = ()}
1009+
else SomeClientResponse response
10181010
case responseListUnrender @cs @as c sresp of
10191011
StatusMismatch -> throwClientError (DecodeFailure "Status mismatch" response)
10201012
UnrenderError e -> throwClientError (DecodeFailure (Text.pack e) response)
@@ -1064,11 +1056,11 @@ checkContentTypeHeader response =
10641056

10651057
decodedAs :: forall ct a m. (MimeUnrender ct a, RunClient m)
10661058
=> Response -> Proxy ct -> m a
1067-
decodedAs response ct = do
1059+
decodedAs response@Response{responseBody=body} ct = do
10681060
responseContentType <- checkContentTypeHeader response
10691061
unless (any (matches responseContentType) accept) $
10701062
throwClientError $ UnsupportedContentType responseContentType response
1071-
case mimeUnrender ct $ responseBody response of
1063+
case mimeUnrender ct body of
10721064
Left err -> throwClientError $ DecodeFailure (T.pack err) response
10731065
Right val -> return val
10741066
where

‎servant-client-core/src/Servant/Client/Core/Response.hs

+7-2
Original file line numberDiff line numberDiff line change
@@ -1,17 +1,17 @@
11
{-# LANGUAGE DeriveDataTypeable #-}
2-
{-# LANGUAGE DeriveFoldable #-}
3-
{-# LANGUAGE DeriveFunctor #-}
42
{-# LANGUAGE DeriveGeneric #-}
53
{-# LANGUAGE DeriveTraversable #-}
64
{-# LANGUAGE MultiParamTypeClasses #-}
75
{-# LANGUAGE RankNTypes #-}
86
{-# LANGUAGE ScopedTypeVariables #-}
97
{-# LANGUAGE TypeFamilies #-}
8+
{-# LANGUAGE NamedFieldPuns #-}
109

1110
module Servant.Client.Core.Response (
1211
Response,
1312
StreamingResponse,
1413
ResponseF (..),
14+
responseToInternalResponse,
1515
) where
1616

1717
import Prelude ()
@@ -31,6 +31,7 @@ import Network.HTTP.Types
3131

3232
import Servant.API.Stream
3333
(SourceIO)
34+
import Servant.Types.ResponseList
3435

3536
data ResponseF a = Response
3637
{ responseStatusCode :: Status
@@ -51,3 +52,7 @@ instance NFData a => NFData (ResponseF a) where
5152

5253
type Response = ResponseF LBS.ByteString
5354
type StreamingResponse = ResponseF (SourceIO BS.ByteString)
55+
56+
responseToInternalResponse :: ResponseF a -> InternalResponse a
57+
responseToInternalResponse Response{responseStatusCode, responseHeaders,responseBody} =
58+
InternalResponse responseStatusCode responseHeaders responseBody

‎servant-client-core/src/Servant/Client/Core/ResponseUnrender.hs

+134
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,134 @@
1+
{-# LANGUAGE ApplicativeDo #-}
2+
module Servant.Client.Core.ResponseUnrender where
3+
4+
import Control.Applicative
5+
import Control.Monad
6+
import Data.Kind (Type)
7+
import Data.SOP
8+
import Data.Typeable
9+
import GHC.TypeLits
10+
import Network.HTTP.Types.Status (Status)
11+
import qualified Data.ByteString.Lazy as BSL
12+
import qualified Network.HTTP.Media as M
13+
14+
import Servant.API.ContentTypes
15+
import Servant.API.MultiVerb
16+
import Servant.API.Status
17+
import Servant.API.UVerb.Union (Union)
18+
import Servant.Client.Core.Response (ResponseF(..))
19+
import qualified Servant.Client.Core.Response as Response
20+
import Servant.API.Stream (SourceIO)
21+
import Data.ByteString (ByteString)
22+
23+
data SomeClientResponse = forall a. Typeable a => SomeClientResponse (ResponseF a)
24+
25+
fromSomeClientResponse
26+
:: forall a m. (Alternative m, Typeable a)
27+
=> SomeClientResponse
28+
-> m (ResponseF a)
29+
fromSomeClientResponse (SomeClientResponse Response {..}) = do
30+
body <- maybe empty pure $ cast @_ @a responseBody
31+
pure $
32+
Response
33+
{ responseBody = body,
34+
..
35+
}
36+
37+
38+
class ResponseUnrender cs a where
39+
type ResponseBody a :: Type
40+
type ResponseStatus a :: Nat
41+
responseUnrender
42+
:: M.MediaType
43+
-> ResponseF (ResponseBody a)
44+
-> UnrenderResult (ResponseType a)
45+
46+
--
47+
-- FIXME: Move this to the client in its own module
48+
class (Typeable as) => ResponseListUnrender cs as where
49+
responseListUnrender
50+
:: M.MediaType
51+
-> SomeClientResponse
52+
-> UnrenderResult (Union (ResponseTypes as))
53+
54+
responseListStatuses :: [Status]
55+
56+
instance ResponseListUnrender cs '[] where
57+
responseListUnrender _ _ = StatusMismatch
58+
responseListStatuses = []
59+
60+
instance
61+
( Typeable a,
62+
Typeable (ResponseBody a),
63+
ResponseUnrender cs a,
64+
ResponseListUnrender cs as,
65+
KnownStatus (ResponseStatus a)
66+
) =>
67+
ResponseListUnrender cs (a ': as)
68+
where
69+
responseListUnrender c output =
70+
Z . I <$> (responseUnrender @cs @a c =<< fromSomeClientResponse output)
71+
<|> S <$> responseListUnrender @cs @as c output
72+
73+
responseListStatuses = statusVal (Proxy @(ResponseStatus a)) : responseListStatuses @cs @as
74+
75+
instance
76+
( KnownStatus s,
77+
MimeUnrender ct a
78+
) =>
79+
ResponseUnrender cs (RespondAs (ct :: Type) s desc a)
80+
where
81+
type ResponseStatus (RespondAs ct s desc a) = s
82+
type ResponseBody (RespondAs ct s desc a) = BSL.ByteString
83+
84+
responseUnrender _ output = do
85+
guard (responseStatusCode output == statusVal (Proxy @s))
86+
either UnrenderError UnrenderSuccess $
87+
mimeUnrender (Proxy @ct) (Response.responseBody output)
88+
89+
instance (KnownStatus s) => ResponseUnrender cs (RespondAs '() s desc ()) where
90+
type ResponseStatus (RespondAs '() s desc ()) = s
91+
type ResponseBody (RespondAs '() s desc ()) = ()
92+
93+
responseUnrender _ output =
94+
guard (responseStatusCode output == statusVal (Proxy @s))
95+
96+
instance
97+
(KnownStatus s)
98+
=> ResponseUnrender cs (RespondStreaming s desc framing ct)
99+
where
100+
type ResponseStatus (RespondStreaming s desc framing ct) = s
101+
type ResponseBody (RespondStreaming s desc framing ct) = SourceIO ByteString
102+
103+
responseUnrender _ resp = do
104+
guard (Response.responseStatusCode resp == statusVal (Proxy @s))
105+
pure $ Response.responseBody resp
106+
107+
instance
108+
(AllMimeUnrender cs a, KnownStatus s)
109+
=> ResponseUnrender cs (Respond s desc a) where
110+
type ResponseStatus (Respond s desc a) = s
111+
type ResponseBody (Respond s desc a) = BSL.ByteString
112+
113+
responseUnrender c output = do
114+
guard (responseStatusCode output == statusVal (Proxy @s))
115+
let results = allMimeUnrender (Proxy @cs)
116+
case lookup c results of
117+
Nothing -> empty
118+
Just f -> either UnrenderError UnrenderSuccess (f (responseBody output))
119+
120+
instance
121+
( AsHeaders xs (ResponseType r) a,
122+
ServantHeaders hs xs,
123+
ResponseUnrender cs r
124+
) =>
125+
ResponseUnrender cs (WithHeaders hs a r)
126+
where
127+
type ResponseStatus (WithHeaders hs a r) = ResponseStatus r
128+
type ResponseBody (WithHeaders hs a r) = ResponseBody r
129+
130+
responseUnrender c output = do
131+
x <- responseUnrender @cs @r c output
132+
case extractHeaders @hs (responseHeaders output) of
133+
Nothing -> UnrenderError "Failed to parse headers"
134+
Just hs -> pure $ fromHeaders @xs (hs, x)

‎servant-server/servant-server.cabal

+2-1
Original file line numberDiff line numberDiff line change
@@ -103,8 +103,9 @@ library
103103
Servant.Server.Internal.DelayedIO
104104
Servant.Server.Internal.ErrorFormatter
105105
Servant.Server.Internal.Handler
106-
Servant.Server.Internal.Router
106+
Servant.Server.Internal.ResponseRender
107107
Servant.Server.Internal.RouteResult
108+
Servant.Server.Internal.Router
108109
Servant.Server.Internal.RoutingApplication
109110
Servant.Server.Internal.ServerError
110111
Servant.Server.StaticFiles

0 commit comments

Comments
 (0)