@@ -1,14 +1,19 @@
11{-# LANGUAGE AllowAmbiguousTypes #-}
22{-# LANGUAGE CPP #-}
33{-# LANGUAGE DataKinds #-}
4+{-# LANGUAGE DefaultSignatures #-}
5+{-# LANGUAGE ExtendedDefaultRules #-}
46{-# LANGUAGE FlexibleContexts #-}
57{-# LANGUAGE FlexibleInstances #-}
8+{-# LANGUAGE FunctionalDependencies #-}
69{-# LANGUAGE GeneralizedNewtypeDeriving #-}
710{-# LANGUAGE InstanceSigs #-}
11+{-# LANGUAGE LambdaCase #-}
812{-# LANGUAGE MultiParamTypeClasses #-}
913{-# LANGUAGE OverloadedStrings #-}
1014{-# LANGUAGE PolyKinds #-}
1115{-# LANGUAGE Rank2Types #-}
16+{-# LANGUAGE RecordWildCards #-}
1217{-# LANGUAGE ScopedTypeVariables #-}
1318{-# LANGUAGE TupleSections #-}
1419{-# LANGUAGE TypeFamilies #-}
@@ -30,6 +35,7 @@ module Servant.Reflex
3035 , clientWithRoute
3136 , clientWithRouteAndResultHandler
3237 , BuildHeaderKeysTo(..)
38+ , GHCJS'MimeRender(..)
3339 , toHeaders
3440 , HasClient
3541 , Client
@@ -39,56 +45,101 @@ module Servant.Reflex
3945
4046------------------------------------------------------------------------------
4147import Control.Applicative
42−import qualified Data.CaseInsensitive as CI
48+import qualified Data.ByteString as BS
49+import qualified Data.ByteString.Lazy as BL
50+import Data.CaseInsensitive (mk)
4351import Data.Functor.Identity
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)
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)
72107------------------------------------------------------------------------------
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)
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)
92143
93144
94145-- * Accessing APIs as a Client
@@ -103,7 +154,7 @@ import Servant.Common.Req (ClientOptions(..),
103154-- >
104155-- > getAllBooks :: Event t l -> m (Event t (l, ReqResult [Book]))
105156-- > postNewBook :: Dynamic t (Maybe Book) -> Event t l
106−-- > -> m (Event t (l, ReqResult Book)))
157+-- -> m (Event t (l, ReqResult Book)))
107158-- > (getAllBooks :<|> postNewBook) = client myApi host
108159-- > where host = constDyn $ BaseUrl Http "localhost" 8080
109160client
@@ -228,26 +279,22 @@ instance {-# OVERLAPPING #-}
228279
229280toHeaders :: BuildHeadersTo ls => ReqResult tag a -> ReqResult tag (Headers ls a)
230281toHeaders r =
231− let hdrs = maybe []
232− (\xhr -> fmap (\(h,v) -> (CI.map E.encodeUtf8 h, E.encodeUtf8 v))
282+ let toBS = E.encodeUtf8
283+ hdrs = maybe []
284+ (\xhr -> fmap (\(h,v) -> (mk (toBS h), toBS v))
233285 (Map.toList $ _xhrResponse_headers xhr))
234286 (response r)
235287 in ffor r $ \a -> Headers {getResponse = a ,getHeadersHList = buildHeadersTo hdrs}
236288
237−
238289class BuildHeaderKeysTo hs where
239− buildHeaderKeysTo :: Proxy hs -> [CI.CI T.Text]
290+ buildHeaderKeysTo :: Proxy hs -> [T.Text]
240291
241292instance {-# OVERLAPPABLE #-} BuildHeaderKeysTo '[]
242293 where buildHeaderKeysTo _ = []
243294
244295instance {-# OVERLAPPABLE #-} (BuildHeaderKeysTo xs, KnownSymbol h)
245296 => BuildHeaderKeysTo ((Header h v) ': xs) where
246− buildHeaderKeysTo _ =
247− let
248− thisKey = CI.mk $ T.pack (symbolVal (Proxy :: Proxy h))
249− in thisKey : buildHeaderKeysTo (Proxy :: Proxy xs)
250−
297+ buildHeaderKeysTo _ = T.pack (symbolVal (Proxy :: Proxy h)) : buildHeaderKeysTo (Proxy :: Proxy xs)
251298
252299-- HEADERS Verb (Content) --
253300-- Headers combinator not treated in fully general case,
@@ -329,19 +376,6 @@ instance HasClient t m sublayout tag
329376 clientWithRouteAndResultHandler Proxy =
330377 clientWithRouteAndResultHandler (Proxy :: Proxy sublayout)
331378
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−
345379
346380-- | If you use a 'QueryParam' in one of your endpoints in your API,
347381-- the corresponding querying function will automatically take
@@ -513,22 +547,65 @@ instance SupportsServantReflex t m => HasClient t m Raw tag where
513547-- > where host = BaseUrl Http "localhost" 8080
514548-- > -- then you can just use "addBook" to query that endpoint
515549
516−instance (MimeRender ct a, HasClient t m sublayout tag, Reflex t)
517− => HasClient t m (ReqBody (ct ': cts) a :> sublayout) tag where
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
518553
519554 type Client t m (ReqBody (ct ': cts) a :> sublayout) tag =
520− Dynamic t (Either Text a) -> Client t m sublayout tag
555+ Dynamic t (Either Text (ToConvert ct a)) -> Client t m sublayout tag
521556
522− clientWithRouteAndResultHandler Proxy q t req baseurl opts wrap body =
557+ clientWithRouteAndResultHandler Proxy q t Req{..} baseurl opts wrap body =
523558 clientWithRouteAndResultHandler (Proxy :: Proxy sublayout) q t req' baseurl opts wrap
524− where req' = req { reqBody = bodyBytesCT }
559+ where req' = Req { reqBody = Just $ (fmap . fmap)
560+ (\b -> (ghcjsMimeRender ctProxy atProxy b, ctString)) body
561+ , ..}
525562 ctProxy = Proxy :: Proxy ct
563+ atProxy = Proxy :: Proxy a
526564 ctString = T.pack $ show $ contentType ctProxy
527− bodyBytesCT = Just $ (fmap . fmap)
528− (\b -> (mimeRender ctProxy b, ctString))
529− body
530565
566+class Accept ctype => GHCJS'MimeRender (ctype :: Type) (a :: Type) where
567+ type ToConvert ctype a :: Type
568+ type ToConvert ctype a = a
531569
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
532609
533610-- | Make the querying function append @path@ to the request path.
534611instance (KnownSymbol path, HasClient t m sublayout tag, Reflex t) => HasClient t m (path :> sublayout) tag where
@@ -623,3 +700,143 @@ type family HasCookieAuth xs :: Constraint where
623700
624701class CookieAuthNotEnabled
625702
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+