@@ -1,4 +1,5 @@
11{-# LANGUAGE AllowAmbiguousTypes #-}
2+{-# LANGUAGE LambdaCase #-}
23{-# LANGUAGE CPP #-}
34{-# LANGUAGE DataKinds #-}
45{-# LANGUAGE FlexibleContexts #-}
@@ -65,6 +66,7 @@ import qualified Servant.Auth as Auth
6566
6667import Reflex.Dom.Core (Dynamic, Event, Reflex,
6768 XhrRequest (..), XhrResponse (..),
69+ XhrResponseBody(..),
6870 XhrResponseHeaders (..),
6971 attachPromptlyDynWith, constDyn, ffor,
7072 fmapMaybe, leftmost,
@@ -80,6 +82,7 @@ import Servant.Common.Req (ClientOptions(..),
8082 defReq, evalResponse, prependToPathParts,
8183 -- performRequestCT,
8284 performRequestsCT,
85+ performRequests,
8386 -- performRequestNoBody,
8487 performRequestsNoBody,
8588 performSomeRequestsAsync,
@@ -90,6 +93,17 @@ import Servant.Common.Req (ClientOptions(..),
9093 reqTag,
9194 qParams, withCredentials)
9295
96+#if MIN_VERSION_servant(0, 18, 1)
97+import Control.Arrow
98+import Data.Either
99+import Data.SOP
100+import Data.SOP.NP
101+import Servant.API.ContentTypes (AllMimeUnrender(..))
102+import Servant.API.UVerb
103+import qualified Data.ByteString.Lazy as BL
104+import qualified Network.HTTP.Media as M
105+import Network.HTTP.Types.Status (Status(..))
106+#endif
93107
94108-- * Accessing APIs as a Client
95109
@@ -225,7 +239,6 @@ instance {-# OVERLAPPING #-}
225239 wrap =<< fmap runIdentity <$> performRequestsNoBody method (constDyn $ Identity req) baseurl opts trigs
226240 where method = E.decodeUtf8 $ reflectMethod (Proxy :: Proxy method)
227241
228−
229242toHeaders :: BuildHeadersTo ls => ReqResult tag a -> ReqResult tag (Headers ls a)
230243toHeaders r =
231244 let hdrs = maybe []
@@ -286,6 +299,75 @@ instance {-# OVERLAPPABLE #-}
286299 OnlyHeaders (Set.fromList (buildHeaderKeysTo (Proxy :: Proxy ls)))
287300 }
288301
302+#if MIN_VERSION_servant(0, 18, 1)
303+instance
304+ ( ReflectMethod method, cts' ~ (ct ': cts)
305+ , as' ~ (a ': as)
306+ , All (AllMimeUnrender cts') as'
307+ , All HasStatus as'
308+ , SupportsServantReflex t m
309+ ) =>
310+ HasClient t m (UVerb method cts' as') tag where
311+ type Client t m (UVerb method cts' as') tag
312+ = Event t tag -> m (Event t (ReqResult tag (Union as')))
313+ clientWithRouteAndResultHandler Proxy _ _ req baseurl opts wrap' trigs =
314+ wrap' =<< fmap runIdentity <$> perform
315+ where
316+ method = E.decodeUtf8 $ reflectMethod (Proxy :: Proxy method)
317+ perform = do
318+ resp <- performRequests method (constDyn $ Identity req)
319+ baseurl opts trigs
320+ return $ fmap
321+ (\(t,rs) -> ffor rs $ \case
322+ Left e -> RequestFailure t e
323+ Right g -> evalResponse' t g
324+ )
325+ resp
326+ -- Try to decode the content. If decoding fails, we declare
327+ -- response failure. Note that HTTP status 500 response is not
328+ -- necessary a failure.
329+ evalResponse' t g = case decodeResp g of
330+ Left err -> ResponseFailure t err g
331+ Right v -> ResponseSuccess t v g
332+ decodeResp r =
333+ let
334+ status = _xhrResponse_status r
335+ -- We go through all possible response types and find types with
336+ -- the HTTP status we got. Try to parse these response types
337+ -- and use the first one that succeeds.
338+ parse
339+ :: forall xs. All HasStatus xs
340+ => NP ([] :.: Either (M.MediaType, String)) xs
341+ -> Either Text (Union xs)
342+ parse Nil =
343+ -- No more response types to try
344+ Left "Unknown response"
345+ parse (Comp x :* xs)
346+ | status == (fromIntegral . statusCode $ statusOf (Comp x)) =
347+ -- Found response type for the response status we got
348+ case partitionEithers x of
349+ -- can't parse the type, go to the next candidate
350+ (_, []) -> S <$> parse xs
351+ -- parse succeeded, return the result
352+ (_, (res : _)) -> Right . inject . I $ res
353+ -- Status doesn't match, go to the next candidate
354+ | otherwise = S <$> parse xs
355+ in case _xhrResponse_response r of
356+ Just (XhrResponseBody_ArrayBuffer x) ->
357+ parse (mimeUnrenders (Proxy :: Proxy cts') (BL.fromStrict x))
358+ _ -> Left "No Body"
359+
360+mimeUnrenders ::
361+ forall cts xs.
362+ All (AllMimeUnrender cts) xs =>
363+ Proxy cts ->
364+ BL.ByteString ->
365+ NP ([] :.: Either (M.MediaType, String)) xs
366+mimeUnrenders ctp body = cpure_NP
367+ (Proxy :: Proxy (AllMimeUnrender cts))
368+ (Comp . map (\(mediaType, parser) -> left ((,) mediaType) (parser body))
369+ . allMimeUnrender $ ctp)
370+#endif
289371
290372
291373-- HEADER
@@ -369,23 +451,24 @@ instance (HasClient t m sublayout tag, KnownSymbol sym)
369451-- > -- then you can just use "getBooksBy" to query that endpoint.
370452-- > -- 'getBooksBy Nothing' for all books
371453-- > -- 'getBooksBy (Just "Isaac Asimov")' to get all books by Isaac Asimov
372−instance (KnownSymbol sym, ToHttpApiData a, HasClient t m sublayout tag, Reflex t)
373− => HasClient t m (QueryParam' mods sym a :> sublayout) tag where
454+instance
455+ ( KnownSymbol sym
456+ , ToHttpApiData a
457+ , HasClient t m sublayout tag
458+ , Reflex t
459+ ) => HasClient t m (QueryParam' mods sym a :> sublayout) tag where
374460
375461 type Client t m (QueryParam' mods sym a :> sublayout) tag =
376462 Dynamic t (QParam a) -> Client t m sublayout tag
377463
378464 -- if mparam = Nothing, we don't add it to the query string
379− clientWithRouteAndResultHandler Proxy q t req baseurl opts wrap mparam =
465+ clientWithRouteAndResultHandler Proxy q t req baseurl opts wrp mparam =
380466 clientWithRouteAndResultHandler (Proxy :: Proxy sublayout) q t
381− (req {qParams = paramPair : qParams req}) baseurl opts wrap
382−
383− where pname = symbolVal (Proxy :: Proxy sym)
384− --p prm = QueryPartParam $ (fmap . fmap) (toQueryParam) prm
385− --paramPair = (T.pack pname, p mparam)
386− p prm = QueryPartParam $ fmap qParamToQueryPart prm -- (fmap . fmap) (unpack . toQueryParam) prm
387− paramPair = (T.pack pname, p mparam)
388−
467+ (req {qParams = paramPair : qParams req}) baseurl opts wrp
468+ where
469+ pname = symbolVal (Proxy :: Proxy sym)
470+ p prm = QueryPartParam $ fmap qParamToQueryPart prm
471+ paramPair = (T.pack pname, p mparam)
389472
390473
391474-- | If you use a 'QueryParams' in one of your endpoints in your API,
@@ -431,7 +514,6 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient t m sublayout tag, Reflex
431514 paramlist
432515
433516
434−
435517-- | If you use a 'QueryFlag' in one of your endpoints in your API,
436518-- the corresponding querying function will automatically take
437519-- an additional 'Bool' argument.