@@ -1,13 +1,17 @@
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 #-}
811{-# LANGUAGE MultiParamTypeClasses #-}
912{-# LANGUAGE OverloadedStrings #-}
1013{-# LANGUAGE PolyKinds #-}
14+{-# LANGUAGE RecordWildCards #-}
1115{-# LANGUAGE ScopedTypeVariables #-}
1216{-# LANGUAGE TupleSections #-}
1317{-# LANGUAGE TypeFamilies #-}
@@ -36,8 +40,11 @@ module Servant.Reflex
3640
3741------------------------------------------------------------------------------
3842import Control.Applicative
43+import qualified Data.ByteString as BS
44+import qualified Data.ByteString.Lazy as BL
3945import Data.CaseInsensitive (mk)
4046import Data.Functor.Identity
47+import Data.Kind (Type)
4148import qualified Data.Map as Map
4249import Data.Monoid ((<>))
4350import Data.Proxy (Proxy (..))
@@ -45,17 +52,21 @@ import qualified Data.Set as Set
4552import Data.Text (Text)
4653import qualified Data.Text as T
4754import qualified Data.Text.Encoding as E
55+import qualified Data.Text.Lazy as TL
4856import GHC.Exts (Constraint)
4957import GHC.TypeLits (KnownSymbol, symbolVal)
50−import Servant.API ((:<|>) (..), (:>), BasicAuth,
51− BasicAuthData, BuildHeadersTo (..),
52− Capture, Header, Headers (..),
53− HttpVersion, IsSecure, MimeRender (..),
54− NoContent, QueryFlag, QueryParam,
55− QueryParams, Raw, ReflectMethod (..),
56− RemoteHost, ReqBody,
57− ToHttpApiData (..), Vault, Verb,
58− contentType)
58+import GHCJS.DOM.Types (Blob, Document, FormData)
59+import Servant.API ((:<|>) (..), (:>), Accept (..),
60+ BasicAuth, BasicAuthData,
61+ BuildHeadersTo (..), Capture,
62+ FormUrlEncoded, Header, Headers (..),
63+ HttpVersion, IsSecure, JSON,
64+ MimeRender (..), NoContent,
65+ OctetStream, PlainText, QueryFlag,
66+ QueryParam, QueryParams, Raw,
67+ ReflectMethod (..), RemoteHost,
68+ ReqBody, ToHttpApiData (..), Vault,
69+ Verb, contentType)
5970import qualified Servant.Auth as Auth
6071
6172import Reflex.Dom.Core (Dynamic, Event, IsXhrPayload, Reflex,
@@ -69,7 +80,7 @@ import Servant.Common.BaseUrl (BaseUrl (..), Scheme (..),
6980 SupportsServantReflex, baseUrlWidget,
7081 showBaseUrl)
7182import Servant.Common.Req (ClientOptions (..), MimeUnrender (..),
72− QParam (..), QueryPart (..), Req,
83+ QParam (..), QueryPart (..), Req (..),
7384 ReqResult (..), addHeader, authData,
7485 defReq, defaultClientOptions,
7586 evalResponse, performRequestsCT,
@@ -119,9 +130,9 @@ clientWithOpts p q t baseurl = clientWithRoute p q t defReq baseurl
119130-- | This class lets us define how each API combinator
120131-- influences the creation of an HTTP request. It's mostly
121132-- an internal class, you can just use 'client'.
122−class HasClient t m layout (tag :: *) where
123− type Client t m layout tag :: *
124− clientWithRoute :: IsXhrPayload o => Proxy layout -> Proxy m -> Proxy tag -> Req t o -> Dynamic t BaseUrl -> ClientOptions -> Client t m layout tag
133+class HasClient t m layout (tag :: Type) where
134+ type Client t m layout tag :: Type
135+ clientWithRoute :: Proxy layout -> Proxy m -> Proxy tag -> Req t -> Dynamic t BaseUrl -> ClientOptions -> Client t m layout tag
125136
126137
127138instance (HasClient t m a tag, HasClient t m b tag) => HasClient t m (a :<|> b) tag where
@@ -456,22 +467,66 @@ instance SupportsServantReflex t m => HasClient t m Raw tag where
456467-- > where host = BaseUrl Http "localhost" 8080
457468-- > -- then you can just use "addBook" to query that endpoint
458469
459−instance (MimeRender ct a, HasClient t m sublayout tag, Reflex t)
460− => HasClient t m (ReqBody (ct ': cts) a :> sublayout) tag where
470+instance (GHCJS'MimeRender ct a, IsXhrPayload (ToSend ct a), Show (ToSend ct a), HasClient t m sublayout tag, Reflex t)
471+ => HasClient t m (ReqBody (ct ': cts) (a :: Type) :> sublayout) tag where
461472
462473 type Client t m (ReqBody (ct ': cts) a :> sublayout) tag =
463− Dynamic t (Either Text a) -> Client t m sublayout tag
474+ Dynamic t (Either Text (ToConvert ct a)) -> Client t m sublayout tag
464475
465− clientWithRoute Proxy q t req baseurl opts body =
476+ clientWithRoute Proxy q t Req{..} baseurl opts body =
466477 clientWithRoute (Proxy :: Proxy sublayout) q t req' baseurl opts
467− where req' = req { reqBody = bodyBytesCT }
478+ where req' = Req { reqBody = Just $ (fmap . fmap)
479+ (\b -> (ghcjsMimeRender ctProxy atProxy b, ctString)) body
480+ , ..}
468481 ctProxy = Proxy :: Proxy ct
482+ atProxy = Proxy :: Proxy a
469483 ctString = T.pack $ show $ contentType ctProxy
470− bodyBytesCT = Just $ (fmap . fmap)
471− (\b -> (mimeRender ctProxy b, ctString))
472− body
473484
485+class Accept ctype => GHCJS'MimeRender (ctype :: Type) (a :: Type) where
486+ type ToConvert ctype a :: Type
487+ type ToConvert ctype a = a
488+
489+ type ToSend ctype a :: Type
490+ type ToSend ctype a = BS.ByteString
491+
492+ ghcjsMimeRender
493+ :: IsXhrPayload (ToSend ctype a)
494+ => Proxy ctype -> Proxy a -> ToConvert ctype a -> ToSend ctype a
495+ default ghcjsMimeRender
496+ :: ( IsXhrPayload (ToSend ctype a)
497+ , MimeRender ctype a
498+ , MimeRender ctype (ToConvert ctype a)
499+ , ToSend ctype a ~ BS.ByteString)
500+ => Proxy ctype -> Proxy a -> ToConvert ctype a -> ToSend ctype a
501+ ghcjsMimeRender ctype _ = BL.toStrict . mimeRender ctype
502+
503+instance MimeRender JSON x => GHCJS'MimeRender JSON x
504+
505+instance MimeRender FormUrlEncoded x => GHCJS'MimeRender FormUrlEncoded x
506+
507+instance GHCJS'MimeRender OctetStream BL.ByteString where
508+ type ToConvert OctetStream BL.ByteString = Blob
509+ type ToSend OctetStream BL.ByteString = Blob
510+ ghcjsMimeRender _ _ = id
511+
512+instance GHCJS'MimeRender PlainText String where
513+ type ToSend PlainText String = Text
514+ ghcjsMimeRender _ _ = T.pack
515+
516+instance GHCJS'MimeRender PlainText Text where
517+ type ToSend PlainText Text = Text
518+ ghcjsMimeRender _ _ = id
519+
520+instance GHCJS'MimeRender PlainText TL.Text where
521+ type ToSend PlainText TL.Text = Text
522+ ghcjsMimeRender _ _ = TL.toStrict
523+
524+instance GHCJS'MimeRender PlainText BL.ByteString where
525+ type ToSend PlainText BL.ByteString = BS.ByteString
526+ ghcjsMimeRender _ _ = BL.toStrict
474527
528+instance GHCJS'MimeRender PlainText BS.ByteString where
529+ ghcjsMimeRender _ _ = id
475530
476531-- | Make the querying function append @path@ to the request path.
477532instance (KnownSymbol path, HasClient t m sublayout tag, Reflex t) => HasClient t m (path :> sublayout) tag where