@@ -1,19 +1,14 @@
11{-# LANGUAGE AllowAmbiguousTypes #-}
22{-# LANGUAGE CPP #-}
33{-# LANGUAGE DataKinds #-}
4−{-# LANGUAGE DefaultSignatures #-}
5−{-# LANGUAGE ExtendedDefaultRules #-}
64{-# LANGUAGE FlexibleContexts #-}
75{-# LANGUAGE FlexibleInstances #-}
8−{-# LANGUAGE FunctionalDependencies #-}
96{-# LANGUAGE GeneralizedNewtypeDeriving #-}
107{-# LANGUAGE InstanceSigs #-}
11−{-# LANGUAGE LambdaCase #-}
128{-# LANGUAGE MultiParamTypeClasses #-}
139{-# LANGUAGE OverloadedStrings #-}
1410{-# LANGUAGE PolyKinds #-}
1511{-# LANGUAGE Rank2Types #-}
16−{-# LANGUAGE RecordWildCards #-}
1712{-# LANGUAGE ScopedTypeVariables #-}
1813{-# LANGUAGE TupleSections #-}
1914{-# LANGUAGE TypeFamilies #-}
@@ -35,7 +30,6 @@ module Servant.Reflex
3530 , clientWithRoute
3631 , clientWithRouteAndResultHandler
3732 , BuildHeaderKeysTo(..)
38− , GHCJS'MimeRender(..)
3933 , toHeaders
4034 , HasClient
4135 , Client
@@ -45,101 +39,56 @@ module Servant.Reflex
4539
4640------------------------------------------------------------------------------
4741import Control.Applicative
48−import qualified Data.ByteString as BS
49−import qualified Data.ByteString.Lazy as BL
50−import Data.CaseInsensitive (mk)
42+import qualified Data.CaseInsensitive as CI
5143import Data.Functor.Identity
52−import Data.Kind (Type)
53−import qualified Data.Map as Map
54−import Data.Monoid ((<>))
55−import Data.Proxy (Proxy (..))
56−import qualified Data.Set as Set
57−import Data.Text (Text)
58−import qualified Data.Text as T
59−import qualified Data.Text.Encoding as E
60−import qualified Data.Text.Lazy as TL
61−import GHC.Exts (Constraint)
62−import GHC.TypeLits (KnownSymbol,
63− symbolVal)
64−import GHCJS.DOM.Types (Blob)
65−import Servant.API ((:<|>) (..),
66− (:>),
67− Accept (..),
68− BasicAuth,
69− BasicAuthData,
70− BuildHeadersTo (..),
71− Capture,
72− FormUrlEncoded,
73− Header,
74− Headers (..),
75− HttpVersion,
76− IsSecure,
77− JSON,
78− MimeRender (..),
79− NoContent,
80− OctetStream,
81− PlainText,
82− QueryFlag,
83− QueryParam,
84− QueryParams,
85− Raw,
86− ReflectMethod (..),
87− RemoteHost,
88− ReqBody,
89− ToHttpApiData (..),
90− Vault, Verb,
91− contentType)
92−import qualified Servant.Auth as Auth
93−
94−import Reflex.Dom.Core (Dynamic,
95− Event,
96− IsXhrPayload,
97− Reflex,
98− XhrRequest (..),
99− XhrResponse (..),
100− XhrResponseHeaders (..),
101− attachPromptlyDynWith,
102− constDyn,
103− ffor,
104− fmapMaybe,
105− leftmost,
106− performRequestsAsync)
44+import qualified Data.Map as Map
45+import Data.Monoid ((<>))
46+import Data.Proxy (Proxy (..))
47+import qualified Data.Set as Set
48+import Data.Text (Text)
49+import qualified Data.Text as T
50+import qualified Data.Text.Encoding as E
51+import GHC.Exts (Constraint)
52+import GHC.TypeLits (KnownSymbol, symbolVal)
53+import Servant.API ((:<|>) (..), (:>), BasicAuth,
54+ BasicAuthData, BuildHeadersTo (..),
55+ Capture, Header, Headers (..),
56+ HttpVersion, IsSecure,
57+ MimeRender (..), MimeUnrender,
58+ NoContent, QueryFlag, QueryParam,
59+ QueryParams, Raw, ReflectMethod (..),
60+ RemoteHost, ReqBody,
61+ ToHttpApiData (..), Vault, Verb,
62+ contentType)
63+import Servant.API.Description (Summary)
64+import qualified Servant.Auth as Auth
65+
66+import Reflex.Dom.Core (Dynamic, Event, Reflex,
67+ XhrRequest (..), XhrResponse (..),
68+ XhrResponseHeaders (..),
69+ attachPromptlyDynWith, constDyn, ffor,
70+ fmapMaybe, leftmost,
71+ performRequestsAsync)
10772------------------------------------------------------------------------------
108−import Servant.Checked.Exceptions.Internal (Envelope)
109−import Servant.Checked.Exceptions.Internal.Servant.API (NoThrow,
110− Throwing,
111− ThrowingNonterminal,
112− Throws)
113−import Servant.Common.BaseUrl (BaseUrl (..),
114− Scheme (..),
115− SupportsServantReflex,
116− baseUrlWidget,
117− showBaseUrl)
118−import Servant.Common.Req (ClientOptions (..),
119− MimeUnrender (..),
120− QParam (..),
121− QueryPart (..),
122− Req (..),
123− ReqResult (..),
124− addHeader,
125− authData,
126− defReq,
127− defaultClientOptions,
128− evalResponse,
129− performRequestsCT,
130− performRequestsNoBody,
131− performSomeRequestsAsync,
132− prependToPathParts,
133− qParamToQueryPart,
134− qParams,
135− reqBody,
136− reqFailure,
137− reqMethod,
138− reqSuccess,
139− reqTag,
140− respHeaders,
141− response,
142− withCredentials)
73+import Servant.Common.BaseUrl (BaseUrl(..), Scheme(..), baseUrlWidget,
74+ showBaseUrl,
75+ SupportsServantReflex)
76+import Servant.Common.Req (ClientOptions(..),
77+ defaultClientOptions,
78+ Req, ReqResult(..), QParam(..),
79+ QueryPart(..), addHeader, authData,
80+ defReq, evalResponse, prependToPathParts,
81+ -- performRequestCT,
82+ performRequestsCT,
83+ -- performRequestNoBody,
84+ performRequestsNoBody,
85+ performSomeRequestsAsync,
86+ qParamToQueryPart, reqBody,
87+ reqSuccess, reqFailure,
88+ reqMethod, respHeaders,
89+ response,
90+ reqTag,
91+ qParams, withCredentials)
14392
14493
14594-- * Accessing APIs as a Client
@@ -154,7 +103,7 @@ import Servant.Common.Req (ClientOptions
154103-- >
155104-- > getAllBooks :: Event t l -> m (Event t (l, ReqResult [Book]))
156105-- > postNewBook :: Dynamic t (Maybe Book) -> Event t l
157−-- -> m (Event t (l, ReqResult Book)))
106+-- > -> m (Event t (l, ReqResult Book)))
158107-- > (getAllBooks :<|> postNewBook) = client myApi host
159108-- > where host = constDyn $ BaseUrl Http "localhost" 8080
160109client
@@ -279,22 +228,26 @@ instance {-# OVERLAPPING #-}
279228
280229toHeaders :: BuildHeadersTo ls => ReqResult tag a -> ReqResult tag (Headers ls a)
281230toHeaders r =
282− let toBS = E.encodeUtf8
283− hdrs = maybe []
284− (\xhr -> fmap (\(h,v) -> (mk (toBS h), toBS v))
231+ let hdrs = maybe []
232+ (\xhr -> fmap (\(h,v) -> (CI.map E.encodeUtf8 h, E.encodeUtf8 v))
285233 (Map.toList $ _xhrResponse_headers xhr))
286234 (response r)
287235 in ffor r $ \a -> Headers {getResponse = a ,getHeadersHList = buildHeadersTo hdrs}
288236
237+
289238class BuildHeaderKeysTo hs where
290− buildHeaderKeysTo :: Proxy hs -> [T.Text]
239+ buildHeaderKeysTo :: Proxy hs -> [CI.CI T.Text]
291240
292241instance {-# OVERLAPPABLE #-} BuildHeaderKeysTo '[]
293242 where buildHeaderKeysTo _ = []
294243
295244instance {-# OVERLAPPABLE #-} (BuildHeaderKeysTo xs, KnownSymbol h)
296245 => BuildHeaderKeysTo ((Header h v) ': xs) where
297− buildHeaderKeysTo _ = T.pack (symbolVal (Proxy :: Proxy h)) : buildHeaderKeysTo (Proxy :: Proxy xs)
246+ buildHeaderKeysTo _ =
247+ let
248+ thisKey = CI.mk $ T.pack (symbolVal (Proxy :: Proxy h))
249+ in thisKey : buildHeaderKeysTo (Proxy :: Proxy xs)
250+
298251
299252-- HEADERS Verb (Content) --
300253-- Headers combinator not treated in fully general case,
@@ -376,6 +329,19 @@ instance HasClient t m sublayout tag
376329 clientWithRouteAndResultHandler Proxy =
377330 clientWithRouteAndResultHandler (Proxy :: Proxy sublayout)
378331
332+-- | Using a 'Summary' combinator in your API doesn't affect the client
333+-- functions.
334+instance (HasClient t m sublayout tag, KnownSymbol sym)
335+ => HasClient t m (Summary sym :> sublayout) tag where
336+
337+ type Client t m (Summary sym :> sublayout) tag =
338+ Client t m sublayout tag
339+
340+ clientWithRouteAndResultHandler Proxy =
341+ clientWithRouteAndResultHandler (Proxy :: Proxy sublayout)
342+
343+
344+
379345
380346-- | If you use a 'QueryParam' in one of your endpoints in your API,
381347-- the corresponding querying function will automatically take
@@ -547,65 +513,22 @@ instance SupportsServantReflex t m => HasClient t m Raw tag where
547513-- > where host = BaseUrl Http "localhost" 8080
548514-- > -- then you can just use "addBook" to query that endpoint
549515
550−instance (GHCJS'MimeRender ct a, IsXhrPayload (ToSend ct a), Show (ToSend ct a),
551− HasClient t m sublayout tag, Reflex t)
552− => HasClient t m (ReqBody (ct ': cts) (a :: Type) :> sublayout) tag where
516+instance (MimeRender ct a, HasClient t m sublayout tag, Reflex t)
517+ => HasClient t m (ReqBody (ct ': cts) a :> sublayout) tag where
553518
554519 type Client t m (ReqBody (ct ': cts) a :> sublayout) tag =
555− Dynamic t (Either Text (ToConvert ct a)) -> Client t m sublayout tag
520+ Dynamic t (Either Text a) -> Client t m sublayout tag
556521
557− clientWithRouteAndResultHandler Proxy q t Req{..} baseurl opts wrap body =
522+ clientWithRouteAndResultHandler Proxy q t req baseurl opts wrap body =
558523 clientWithRouteAndResultHandler (Proxy :: Proxy sublayout) q t req' baseurl opts wrap
559− where req' = Req { reqBody = Just $ (fmap . fmap)
560− (\b -> (ghcjsMimeRender ctProxy atProxy b, ctString)) body
561− , ..}
524+ where req' = req { reqBody = bodyBytesCT }
562525 ctProxy = Proxy :: Proxy ct
563− atProxy = Proxy :: Proxy a
564526 ctString = T.pack $ show $ contentType ctProxy
527+ bodyBytesCT = Just $ (fmap . fmap)
528+ (\b -> (mimeRender ctProxy b, ctString))
529+ body
565530
566−class Accept ctype => GHCJS'MimeRender (ctype :: Type) (a :: Type) where
567− type ToConvert ctype a :: Type
568− type ToConvert ctype a = a
569531
570− type ToSend ctype a :: Type
571− type ToSend ctype a = BS.ByteString
572−
573− ghcjsMimeRender
574− :: IsXhrPayload (ToSend ctype a)
575− => Proxy ctype -> Proxy a -> ToConvert ctype a -> ToSend ctype a
576− default ghcjsMimeRender
577− :: (MimeRender ctype a,
578− MimeRender ctype (ToConvert ctype a), ToSend ctype a ~ BS.ByteString)
579− => Proxy ctype -> Proxy a -> ToConvert ctype a -> ToSend ctype a
580− ghcjsMimeRender ctype _ = BL.toStrict . mimeRender ctype
581−
582−instance MimeRender JSON x => GHCJS'MimeRender JSON x
583−
584−instance MimeRender FormUrlEncoded x => GHCJS'MimeRender FormUrlEncoded x
585−
586−instance GHCJS'MimeRender OctetStream BL.ByteString where
587− type ToConvert OctetStream BL.ByteString = Either BL.ByteString Blob
588− type ToSend OctetStream BL.ByteString = Either BS.ByteString Blob
589− ghcjsMimeRender _ _ = \case Left bl -> Left $ BL.toStrict bl; Right x -> Right x
590−
591−instance GHCJS'MimeRender PlainText String where
592− type ToSend PlainText String = Text
593− ghcjsMimeRender _ _ = T.pack
594−
595−instance GHCJS'MimeRender PlainText Text where
596− type ToSend PlainText Text = Text
597− ghcjsMimeRender _ _ = id
598−
599−instance GHCJS'MimeRender PlainText TL.Text where
600− type ToSend PlainText TL.Text = Text
601− ghcjsMimeRender _ _ = TL.toStrict
602−
603−instance GHCJS'MimeRender PlainText BL.ByteString where
604− type ToSend PlainText BL.ByteString = BS.ByteString
605− ghcjsMimeRender _ _ = BL.toStrict
606−
607−instance GHCJS'MimeRender PlainText BS.ByteString where
608− ghcjsMimeRender _ _ = id
609532
610533-- | Make the querying function append @path@ to the request path.
611534instance (KnownSymbol path, HasClient t m sublayout tag, Reflex t) => HasClient t m (path :> sublayout) tag where
@@ -700,143 +623,3 @@ type family HasCookieAuth xs :: Constraint where
700623
701624class CookieAuthNotEnabled
702625
703−{- servant-checked-exceptions
704−~~~~~~~~~~~~~~~~~~~~~
705−-}
706−
707−-- | Change a 'Throws' into 'Throwing'.
708−instance (Monad m, HasClient t m (Throwing '[e] :> api) tag) => HasClient t m (Throws e :> api) tag where
709− type Client t m (Throws e :> api) tag = Client t m (Throwing '[e] :> api) tag
710−
711− clientWithRouteAndResultHandler
712− :: Proxy (Throws e :> api)
713− -> Proxy m
714− -> Proxy tag
715− -> Req t
716− -> Dynamic t BaseUrl
717− -> ClientOptions
718− -> (forall a. Event t (ReqResult tag a) -> m (Event t (ReqResult tag a)))
719− -> Client t m (Throwing '[e] :> api) tag
720− clientWithRouteAndResultHandler _ = clientWithRouteAndResultHandler (Proxy :: Proxy (Throwing '[e] :> api))
721−
722−-- | When @'Throwing' es@ comes before a 'Verb', change it into the same 'Verb'
723−-- but returning an @'Envelope' es@.
724−instance (HasClient t m (Verb method status ctypes (Envelope es a)) tag) =>
725− HasClient t m (Throwing es :> Verb method status ctypes a) tag where
726−
727− type Client t m (Throwing es :> Verb method status ctypes a) tag =
728− Client t m (Verb method status ctypes (Envelope es a)) tag
729−
730− clientWithRouteAndResultHandler
731− :: Proxy (Throwing es :> Verb method status ctypes a)
732− -> Proxy m
733− -> Proxy tag
734− -> Req t
735− -> Dynamic t BaseUrl
736− -> ClientOptions
737− -> (forall x. Event t (ReqResult tag x) -> m (Event t (ReqResult tag x)))
738− -> Client t m (Verb method status ctypes (Envelope es a)) tag
739− clientWithRouteAndResultHandler Proxy =
740− clientWithRouteAndResultHandler (Proxy :: Proxy (Verb method status ctypes (Envelope es a)))
741−
742−-- | When 'NoThrow' comes before a 'Verb', change it into the same 'Verb'
743−-- but returning an @'Envelope' \'[]@.
744−instance (Monad m, HasClient t m (Verb method status ctypes (Envelope '[] a)) tag) =>
745− HasClient t m (NoThrow :> Verb method status ctypes a) tag where
746−
747− type Client t m (NoThrow :> Verb method status ctypes a) tag =
748− Client t m (Verb method status ctypes (Envelope '[] a)) tag
749−
750− clientWithRouteAndResultHandler
751− :: Proxy (NoThrow :> Verb method status ctypes a)
752− -> Proxy m
753− -> Proxy tag
754− -> Req t
755− -> Dynamic t BaseUrl
756− -> ClientOptions
757− -> (forall x. Event t (ReqResult tag x) -> m (Event t (ReqResult tag x)))
758− -> Client t m (Verb method status ctypes (Envelope '[] a)) tag
759− clientWithRouteAndResultHandler Proxy =
760− clientWithRouteAndResultHandler (Proxy :: Proxy (Verb method status ctypes (Envelope '[] a)))
761−
762−-- | When @'Throwing' es@ comes before ':<|>', push @'Throwing' es@ into each
763−-- branch of the API.
764−instance (Monad m, HasClient t m ((Throwing es :> api1) :<|> (Throwing es :> api2)) tag) =>
765− HasClient t m (Throwing es :> (api1 :<|> api2)) tag where
766−
767− type Client t m (Throwing es :> (api1 :<|> api2)) tag =
768− Client t m ((Throwing es :> api1) :<|> (Throwing es :> api2)) tag
769−
770− clientWithRouteAndResultHandler
771− :: Proxy (Throwing es :> (api1 :<|> api2))
772− -> Proxy m
773− -> Proxy tag
774− -> Req t
775− -> Dynamic t BaseUrl
776− -> ClientOptions
777− -> (forall a. Event t (ReqResult tag a) -> m (Event t (ReqResult tag a)))
778− -> Client t m ((Throwing es :> api1) :<|> (Throwing es :> api2)) tag
779− clientWithRouteAndResultHandler _ =
780− clientWithRouteAndResultHandler (Proxy :: Proxy ((Throwing es :> api1) :<|> (Throwing es :> api2)))
781−
782−-- | When 'NoThrow' comes before ':<|>', push 'NoThrow' into each branch of the
783−-- API.
784−instance (Monad m, HasClient t m ((NoThrow :> api1) :<|> (NoThrow :> api2)) tag) =>
785− HasClient t m (NoThrow :> (api1 :<|> api2)) tag where
786−
787− type Client t m (NoThrow :> (api1 :<|> api2)) tag =
788− Client t m ((NoThrow :> api1) :<|> (NoThrow :> api2)) tag
789−
790− clientWithRouteAndResultHandler
791− :: Proxy (NoThrow :> (api1 :<|> api2))
792− -> Proxy m
793− -> Proxy tag
794− -> Req t
795− -> Dynamic t BaseUrl
796− -> ClientOptions
797− -> (forall a. Event t (ReqResult tag a) -> m (Event t (ReqResult tag a)))
798− -> Client t m ((NoThrow :> api1) :<|> (NoThrow :> api2)) tag
799− clientWithRouteAndResultHandler _ =
800− clientWithRouteAndResultHandler (Proxy :: Proxy ((NoThrow :> api1) :<|> (NoThrow :> api2)))
801−
802−-- | When a @'Throws' e@ comes immediately after a @'Throwing' es@, 'Snoc' the
803−-- @e@ onto the @es@. Otherwise, if @'Throws' e@ comes before any other
804−-- combinator, push it down so it is closer to the 'Verb'.
805−instance (Monad m, HasClient t m (ThrowingNonterminal (Throwing es :> api :> apis)) tag) =>
806− HasClient t m (Throwing es :> api :> apis) tag where
807−
808− type Client t m (Throwing es :> api :> apis) tag =
809− Client t m (ThrowingNonterminal (Throwing es :> api :> apis)) tag
810−
811− clientWithRouteAndResultHandler
812− :: Proxy (Throwing es :> api :> apis)
813− -> Proxy m
814− -> Proxy tag
815− -> Req t
816− -> Dynamic t BaseUrl
817− -> ClientOptions
818− -> (forall a. Event t (ReqResult tag a) -> m (Event t (ReqResult tag a)))
819− -> Client t m (ThrowingNonterminal (Throwing es :> api :> apis)) tag
820− clientWithRouteAndResultHandler _ =
821− clientWithRouteAndResultHandler (Proxy :: Proxy (ThrowingNonterminal (Throwing es :> api :> apis)))
822−
823−-- | When 'NoThrow' comes before any other combinator, push it down so it is
824−-- closer to the 'Verb'.
825−instance (Monad m, HasClient t m (api :> NoThrow :> apis) tag) =>
826− HasClient t m (NoThrow :> api :> apis) tag where
827−
828− type Client t m (NoThrow :> api :> apis) tag =
829− Client t m (api :> NoThrow :> apis) tag
830−
831− clientWithRouteAndResultHandler
832− :: Proxy (NoThrow :> api :> apis)
833− -> Proxy m
834− -> Proxy tag
835− -> Req t
836− -> Dynamic t BaseUrl
837− -> ClientOptions
838− -> (forall a. Event t (ReqResult tag a) -> m (Event t (ReqResult tag a)))
839− -> Client t m (api :> NoThrow :> apis) tag
840− clientWithRouteAndResultHandler _ =
841− clientWithRouteAndResultHandler (Proxy :: Proxy (api :> NoThrow :> apis))
842−