mirror of
https://github.com/ilyakooo0/servant-reflex.git
synced 2024-09-11 07:15:29 +03:00
Split tuple API into single and multi, bump deps
This commit is contained in:
Greg Hale
parent
bf11dea868
commit
5e6ba54179
@ -1,5 +1,5 @@
|
||||
{ mkDerivation, aeson, base, bytestring, case-insensitive
|
||||
, containers, data-default, exceptions, ghcjs-dom, http-api-data
|
||||
, containers, data-default, exceptions, generic-lens, ghcjs-dom, http-api-data
|
||||
, http-media, jsaddle, mtl, network-uri, reflex, reflex-dom-core
|
||||
, safe, scientific, servant, servant-auth, stdenv
|
||||
, string-conversions, text, transformers
|
||||
@ -11,13 +11,15 @@ mkDerivation {
|
||||
(path: type:
|
||||
baseNameOf path != "result"
|
||||
&& baseNameOf path != "nix"
|
||||
&& baseNameOf path != "testdriver"
|
||||
&& baseNameOf path != "testserver"
|
||||
) ./.;
|
||||
configureFlags = [ "-fexample" ];
|
||||
isLibrary = true;
|
||||
isExecutable = true;
|
||||
libraryHaskellDepends = [
|
||||
base bytestring case-insensitive containers data-default exceptions
|
||||
ghcjs-dom http-api-data http-media jsaddle mtl network-uri reflex
|
||||
generic-lens ghcjs-dom http-api-data http-media jsaddle mtl network-uri reflex
|
||||
reflex-dom-core safe servant servant-auth string-conversions text
|
||||
transformers
|
||||
];
|
||||
|
||||
@ -1,7 +1,7 @@
|
||||
let
|
||||
rev = "a15d3a2411e7ca7d4ee4853b57c72fe83faee272";
|
||||
rev = "2df9a830193f551ff222ac6b0c739c622578ddc0";
|
||||
in import (builtins.fetchTarball
|
||||
{
|
||||
url = "https://github.com/reflex-frp/reflex-platform/archive/${rev}.tar.gz";
|
||||
sha256 = "1dsvw0lah7761vndip1hqal4fjpjv84ravinnfhy83jgfav5ivna";
|
||||
sha256 = "17084xqhixk79av0gnjgwkhdigf9zwkd4axb6qp89dyyffy5s3hi";
|
||||
}) {}
|
||||
|
||||
@ -2,19 +2,19 @@
|
||||
|
||||
let
|
||||
|
||||
generic-lens-src = pkgs.fetchFromGitHub {
|
||||
owner = "kcsongor";
|
||||
repo = "generic-lens";
|
||||
rev = "6787a4e85d09ad9fcfe5baae53fea2cccbae5976";
|
||||
sha256 = "1bvjwxm4ik2zcx9s57ibi376y255vm5mawx12s1sjcn09mv1vvdh";
|
||||
};
|
||||
# generic-lens-src = pkgs.fetchFromGitHub {
|
||||
# owner = "kcsongor";
|
||||
# repo = "generic-lens";
|
||||
# rev = "6787a4e85d09ad9fcfe5baae53fea2cccbae5976";
|
||||
# sha256 = "1bvjwxm4ik2zcx9s57ibi376y255vm5mawx12s1sjcn09mv1vvdh";
|
||||
# };
|
||||
|
||||
ghcjsPackages = reflexPlatform.${compiler}.override {
|
||||
overrides = self: super: {
|
||||
servant = super.servant;
|
||||
generic-lens = pkgs.haskell.lib.dontCheck (self.callCabal2nix "generic-lens" generic-lens-src {
|
||||
inspection-testing = null;
|
||||
});
|
||||
# generic-lens = pkgs.haskell.lib.dontCheck (self.callCabal2nix "generic-lens" generic-lens-src {
|
||||
# inspection-testing = null;
|
||||
# });
|
||||
wai = super.wai;
|
||||
servant-reflex = pkgs.haskell.lib.appendConfigureFlag
|
||||
(self.callPackage ../. {}) "-fExample";
|
||||
|
||||
@ -18,7 +18,11 @@ Flag Example
|
||||
library
|
||||
exposed-modules:
|
||||
Servant.Reflex
|
||||
Servant.Reflex.Examples
|
||||
Servant.Reflex.Multi
|
||||
Servant.Reflex.Internal.TupleRequest
|
||||
Servant.Reflex.TupleRequest
|
||||
Servant.Reflex.TupleRequestMulti
|
||||
|
||||
other-modules:
|
||||
Servant.Common.BaseUrl
|
||||
|
||||
60
src/Servant/Reflex/Examples.hs
Normal file
60
src/Servant/Reflex/Examples.hs
Normal file
@ -0,0 +1,60 @@
|
||||
-- |
|
||||
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE KindSignatures #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
|
||||
|
||||
module Servant.Reflex.Examples where
|
||||
|
||||
import Control.Monad.Identity (Identity(..)) -- Temporary
|
||||
import Data.Proxy (Proxy (..))
|
||||
import Reflex (Event, MonadHold, PostBuild,
|
||||
holdDyn, leftmost)
|
||||
import Reflex.Dom.Core (DomBuilder, display)
|
||||
import Reflex.Dom.Widget (button)
|
||||
import Servant.API ((:<|>) (..), (:>) (..))
|
||||
import qualified Servant.API as API
|
||||
import Servant.Common.BaseUrl (SupportsServantReflex)
|
||||
|
||||
import qualified Servant.Reflex.TupleRequest as TupleRequest
|
||||
import qualified Servant.Reflex.TupleRequestMulti as TupleRequestMulti
|
||||
import qualified Servant.Test.ComprehensiveAPI as Servant
|
||||
|
||||
|
||||
type MyAPI =
|
||||
|
||||
API.Header "hi" Int
|
||||
:> API.Capture "hello" Int
|
||||
:> API.Capture "hello2" Bool
|
||||
:> API.Get '[API.JSON] (API.Headers '[API.Header "hi" Int] Int)
|
||||
|
||||
:<|> API.Get '[API.JSON] Bool
|
||||
|
||||
type MyAPI2 = API.Raw
|
||||
|
||||
|
||||
m :: forall t m.(SupportsServantReflex t m, MonadHold t m, PostBuild t m, DomBuilder t m) => m ()
|
||||
m = do
|
||||
let (a :<|> b) = TupleRequest.clientR (Proxy @MyAPI) (Proxy :: Proxy m) (Proxy :: Proxy t) undefined
|
||||
btn <- button "Hello"
|
||||
resA <- a ((2, 5, True) <$ btn)
|
||||
resB <- b (() <$ btn)
|
||||
display =<< holdDyn "waiting" (leftmost [show <$> resB ])
|
||||
|
||||
let rawR = TupleRequest.clientR (Proxy @MyAPI2) (Proxy @m) (Proxy @t) undefined
|
||||
|
||||
let (aMulti1 :<|> bMulti1) =
|
||||
TupleRequestMulti.clientR
|
||||
(Proxy @MyAPI)
|
||||
(Proxy :: Proxy m)
|
||||
(Proxy :: Proxy t)
|
||||
(Proxy :: Proxy ((,) Int))
|
||||
undefined
|
||||
return ()
|
||||
|
||||
@ -9,7 +9,7 @@
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE PolyKinds #-}
|
||||
{-# LANGUAGE RankNTypes #-} -- Temporary
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TupleSections #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
@ -17,87 +17,37 @@
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
|
||||
module Servant.Reflex.RequestAPI where
|
||||
module Servant.Reflex.Internal.TupleRequest where
|
||||
|
||||
import Control.Arrow (first, second)
|
||||
import Control.Lens
|
||||
import Data.Generics.Product
|
||||
import Data.Proxy
|
||||
import Data.CaseInsensitive (mk)
|
||||
import qualified Data.List as L
|
||||
import qualified Data.Map as M
|
||||
import Data.Maybe (catMaybes)
|
||||
import Data.Semigroup ((<>))
|
||||
import Control.Arrow (first, second)
|
||||
import Data.CaseInsensitive (mk)
|
||||
import Control.Lens (over,set)
|
||||
import qualified Data.ByteString.Lazy as BL
|
||||
import qualified Data.Default as Default
|
||||
import qualified Data.List as L
|
||||
import qualified Data.Map as M
|
||||
import qualified Data.Set as Set
|
||||
import qualified Data.Text.Encoding as E
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.ByteString.Lazy as BL
|
||||
import GHC.Generics
|
||||
import GHC.TypeLits (KnownSymbol, symbolVal)
|
||||
import Reflex hiding (HList(..))
|
||||
import Language.Javascript.JSaddle (MonadJSM)
|
||||
import Data.Generics.Product
|
||||
import Data.Proxy (Proxy(..))
|
||||
import GHC.TypeLits (KnownSymbol, symbolVal)
|
||||
import Data.Maybe (catMaybes)
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Text.Encoding as E
|
||||
import GHC.Generics (Generic)
|
||||
import Reflex.Dom.Xhr (XhrRequest (..), XhrRequestConfig (..),
|
||||
XhrResponseHeaders (..),
|
||||
XhrResponseBody(..),
|
||||
XhrResponseType (..), XhrResponse(..))
|
||||
import Servant.API hiding (HList(..))
|
||||
import Servant.Common.Req hiding (QueryPart(..))
|
||||
import Servant.Common.BaseUrl
|
||||
import Servant.API ((:<|>), BasicAuthData, Raw,
|
||||
basicAuthPassword, basicAuthUsername)
|
||||
|
||||
import Reflex.Dom hiding (HList(..))
|
||||
import Servant.Reflex (BuildHeaderKeysTo (..),
|
||||
toHeaders)
|
||||
import Servant.Common.BaseUrl (SupportsServantReflex, BaseUrl (..), showBaseUrl)
|
||||
import Servant.Common.Req (escape)
|
||||
|
||||
import Servant.Reflex (BuildHeaderKeysTo (..), toHeaders)
|
||||
|
||||
{-
|
||||
TODO:
|
||||
- [x] :<|>
|
||||
- [x] Verb content
|
||||
- [x] Verb nocontent
|
||||
- [x] Verb (Headers content)
|
||||
- [x] Verb (Headers nocontent)
|
||||
- [ ] Stream
|
||||
- [X] Capture :> ...
|
||||
- [ ] Capture' :> ...
|
||||
- [x] CaptureAll :> ...
|
||||
- [x] QueryParam :> ...
|
||||
- [x] QueryParams :> ...
|
||||
- [x] QueryFlag :> ...
|
||||
- [x] ReqBody :> ...
|
||||
- [ ] Header' :> ...
|
||||
- [x] Header :> ...
|
||||
- [x] Summary :> ...
|
||||
- [x] Description :> ...
|
||||
- [x] path :> ...
|
||||
- [ ] RemoteHost :> ...
|
||||
- [x] IsSecure :> ...
|
||||
- [x] Vault :> ...
|
||||
- [ ] WithNamedContext :> ...
|
||||
- [ ] AuthenticatedRequest :> ...
|
||||
- [x] BasicAuth :> ...
|
||||
- [ ] EmptyClient :> ...
|
||||
- [ ] EmptyClient
|
||||
- [ ] HttpVersion :> ...
|
||||
-}
|
||||
data HList xs where
|
||||
HNil :: HList '[]
|
||||
HCons :: x -> HList xs -> HList (x ': xs)
|
||||
|
||||
clientR :: forall t m layout f . (HasClientR t m (Seal layout) f, Applicative f, Reflex t)
|
||||
=> Proxy layout -> Proxy (m :: * -> *) -> Proxy t -> Proxy f
|
||||
-> Dynamic t BaseUrl -> ClientR t m (Seal layout) f
|
||||
clientR _ mP tP fP url =
|
||||
clientRWithRoute (Proxy :: Proxy (Seal layout)) mP fP undefined url undefined
|
||||
|
||||
-- | A class for generating top-level the API client function
|
||||
class HasClientR t (m :: * -> *) api (f :: * -> *) where
|
||||
type ClientR t m api f :: *
|
||||
clientRWithRoute :: Proxy api -> Proxy m -> Proxy f
|
||||
-> Dynamic t (f (Req t)) -> Dynamic t BaseUrl
|
||||
-> ClientOptions -> ClientR t m api f
|
||||
|
||||
-- instance EndpointR t m Raw f where
|
||||
-- type EInputs t m Raw f = '[XhrRequest T.Text]
|
||||
-- type EOutput t m Raw f = XhrResponse
|
||||
|
||||
-- mkReq (HCons (XhrRequest method url conf) NHil) =
|
||||
-- ReqR method
|
||||
|
||||
|
||||
-- | A class for generating endpoint-level API client functions
|
||||
@ -118,26 +68,9 @@ class EndpointR t m api f where
|
||||
mkReq :: HList (EInputs t m api f) -> ReqR
|
||||
getResp :: XhrResponse -> EOutput t m api f
|
||||
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | :<|> APIs
|
||||
instance {-# OVERLAPPING #-}
|
||||
(HasClientR t m (layoutLeft) f,
|
||||
HasClientR t m (layoutRight) f
|
||||
) => HasClientR t m (layoutLeft :<|> layoutRight) f where
|
||||
type ClientR t m (layoutLeft :<|> layoutRight) f =
|
||||
ClientR t m layoutLeft f :<|> ClientR t m layoutRight f
|
||||
clientRWithRoute _ tP mP _ url opts =
|
||||
clientRWithRoute (Proxy @layoutLeft) tP mP undefined url opts
|
||||
:<|>
|
||||
clientRWithRoute (Proxy @layoutRight) tP mP undefined url opts
|
||||
|
||||
#if MIN_VERSION_servant (0,13,0)
|
||||
-- TODO: Untested
|
||||
instance HasClientR t m EmptyClient f where
|
||||
type ClientR t m api f = EmptyClient
|
||||
clientRWithRoute _ _ _ _ _ _ = EmptyClient
|
||||
#endif
|
||||
data HList xs where
|
||||
HNil :: HList '[]
|
||||
HCons :: x -> HList xs -> HList (x ': xs)
|
||||
|
||||
|
||||
class ToTuple xs where
|
||||
@ -153,298 +86,6 @@ type family Seal a where
|
||||
Seal Raw = SealedRaw
|
||||
Seal a = Sealed a
|
||||
|
||||
|
||||
-- | Turn a single Endpoint into a client, by turning the input HList
|
||||
-- into a tuple
|
||||
instance {-# OVERLAPPING #-} forall t m layout f .(EndpointR t m layout f,
|
||||
ToTuple (HList (EInputs t m layout f)),
|
||||
Monad m
|
||||
, Traversable f
|
||||
, SupportsServantReflex t m
|
||||
) => HasClientR t (m :: * -> *) (Sealed layout) (f :: * -> *) where
|
||||
type ClientR t m (Sealed layout) f =
|
||||
Event t (f (Tuple (HList (EInputs t m layout f))))
|
||||
-> m (Event t (f (EOutput t m layout f)))
|
||||
clientRWithRoute _ mP fP dReq url opts (reqs :: Event t (f (Tuple (HList (EInputs t m layout f ))))) = do
|
||||
let reqTuples = fmap (fromTuple @(HList (EInputs t m layout f ))) <$> reqs
|
||||
|
||||
-- TODO: replace these 2 lines w/ the next 2. The trace is for library debugging
|
||||
reqRs = traceEventWith (concat . fmap ((<> "\n") . show)) $ fmap (mkReq @t @m @layout @f) <$> reqTuples
|
||||
reqs' = ffor (attachPromptlyDyn url reqRs) $ \(bUrl, rs) -> mkXhrRequest bUrl <$> rs
|
||||
-- reqs' = ffor (attachPromptlyDyn url reqTuples) $ \(bUrl, inputs) ->
|
||||
-- mkXhrRequest bUrl . mkReq @t @m @layout @f <$> inputs
|
||||
resps <- performRequestsAsync $ reqs'
|
||||
return (fmap (getResp @t @m @layout @f) <$> resps)
|
||||
|
||||
|
||||
instance (SupportsServantReflex t m, Traversable f) => HasClientR t m SealedRaw f where
|
||||
type ClientR t m SealedRaw f = Event t (f (XhrRequest T.Text)) -> m (Event t (f XhrResponse))
|
||||
clientRWithRoute _ mP fP dReq url opts reqs = performRequestsAsync reqs
|
||||
|
||||
|
||||
instance {-# OVERLAPPING #-}(MimeUnrender ct a, ReflectMethod method, cts' ~ (ct ': cts), SupportsServantReflex t m, Applicative f
|
||||
) => EndpointR t m (Verb method status cts' a) f where
|
||||
type EInputs t m (Verb method status cts' a) f = '[]
|
||||
type EOutput t m (Verb method status cts' a) f = Either String a
|
||||
|
||||
mkReq _ = emptyReqR . E.decodeUtf8 $ reflectMethod (Proxy @method)
|
||||
getResp resp = case _xhrResponse_response resp of
|
||||
Just (XhrResponseBody_ArrayBuffer x) -> mimeUnrender (Proxy @ct) (BL.fromStrict x)
|
||||
|
||||
instance {-# OVERLAPPING #-}(ReflectMethod method, SupportsServantReflex t m, Applicative f
|
||||
) => EndpointR t m (Verb method status cts' NoContent) f where
|
||||
type EInputs t m (Verb method status cts' NoContent) f = '[]
|
||||
type EOutput t m (Verb method status cts' NoContent) f = Either String NoContent
|
||||
|
||||
mkReq _ = emptyReqR . E.decodeUtf8 $ reflectMethod (Proxy @method)
|
||||
getResp resp = Right NoContent -- TODO: Should EOutput be `NoContent` rather than Either... ?
|
||||
|
||||
|
||||
instance {-# OVERLAPPING #-}
|
||||
(MimeUnrender ct a,
|
||||
BuildHeadersTo hs,
|
||||
ReflectMethod method, cts' ~ (ct ': cts),
|
||||
SupportsServantReflex t m,
|
||||
Applicative f,
|
||||
BuildHeaderKeysTo hs
|
||||
) => EndpointR t m (Verb method status cts' (Headers hs a)) f where
|
||||
type EInputs t m (Verb method status cts' (Headers hs a)) f = '[]
|
||||
type EOutput t m (Verb method status cts' (Headers hs a)) f = Either String (Headers hs a)
|
||||
|
||||
mkReq _ = set (field @"reqRRespHeaders") (OnlyHeaders (Set.fromList (buildHeaderKeysTo (Proxy @hs)))) $ emptyReqR $ E.decodeUtf8 $ reflectMethod (Proxy @method)
|
||||
getResp resp = case _xhrResponse_response resp of
|
||||
Just (XhrResponseBody_ArrayBuffer x) ->
|
||||
let hs = buildHeadersTo
|
||||
. fmap (first (mk . E.encodeUtf8) . second E.encodeUtf8)
|
||||
. M.toList
|
||||
$ _xhrResponse_headers resp
|
||||
in fmap (flip Headers (hs)) $ mimeUnrender (Proxy @ct) (BL.fromStrict x)
|
||||
|
||||
|
||||
instance {-# OVERLAPPING #-}(MimeUnrender ct a,
|
||||
BuildHeadersTo hs,
|
||||
BuildHeaderKeysTo hs,
|
||||
ReflectMethod method,
|
||||
SupportsServantReflex t m,
|
||||
Applicative f
|
||||
) => EndpointR t m (Verb method status cts' (Headers hs NoContent)) f where
|
||||
type EInputs t m (Verb method status cts' (Headers hs NoContent)) f = '[]
|
||||
type EOutput t m (Verb method status cts' (Headers hs NoContent)) f = Either String (Headers hs NoContent)
|
||||
|
||||
mkReq _ = set (field @"reqRRespHeaders") (OnlyHeaders (Set.fromList (buildHeaderKeysTo (Proxy @hs)))) $ emptyReqR . E.decodeUtf8 $ reflectMethod (Proxy @method)
|
||||
getResp resp = case _xhrResponse_response resp of
|
||||
Just (XhrResponseBody_ArrayBuffer x) ->
|
||||
let hs = buildHeadersTo
|
||||
. fmap (first (mk . E.encodeUtf8) . second E.encodeUtf8)
|
||||
. M.toList
|
||||
$ _xhrResponse_headers resp
|
||||
in Right (Headers NoContent hs)
|
||||
|
||||
|
||||
instance (SupportsServantReflex t m,
|
||||
ToHttpApiData a,
|
||||
EndpointR t m sublayout f,
|
||||
Applicative f
|
||||
) => EndpointR t m (Capture capture a :> sublayout) f where
|
||||
|
||||
type EInputs t m (Capture capture a :> sublayout) f = a ': EInputs t m sublayout f
|
||||
type EOutput t m (Capture capture a :> sublayout) f = EOutput t m sublayout f
|
||||
|
||||
mkReq (HCons x xs) = (\a -> over (field @"reqRPathParts") (toUrlPiece a:)) x $
|
||||
mkReq @t @m @sublayout @f xs
|
||||
|
||||
getResp = getResp @t @m @sublayout @f
|
||||
|
||||
instance (SupportsServantReflex t m,
|
||||
ToHttpApiData a,
|
||||
EndpointR t m sublayout f,
|
||||
Applicative f
|
||||
) => EndpointR t m (CaptureAll capture a :> sublayout) f where
|
||||
|
||||
type EInputs t m (CaptureAll capture a :> sublayout) f = [a] ': EInputs t m sublayout f
|
||||
type EOutput t m (CaptureAll capture a :> sublayout) f = EOutput t m sublayout f
|
||||
|
||||
mkReq (HCons x xs) = (\a -> over (field @"reqRPathParts") (fmap toUrlPiece a <>)) x $
|
||||
mkReq @t @m @sublayout @f xs
|
||||
|
||||
getResp = getResp @t @m @sublayout @f
|
||||
|
||||
|
||||
instance (SupportsServantReflex t m,
|
||||
KnownSymbol sym,
|
||||
EndpointR t m sublayout f,
|
||||
Applicative f
|
||||
) => EndpointR t m (sym :> sublayout) f where
|
||||
|
||||
type EInputs t m (sym :> sublayout) f = EInputs t m sublayout f
|
||||
type EOutput t m (sym :> sublayout) f = EOutput t m sublayout f
|
||||
|
||||
mkReq r = over (field @"reqRPathParts") (T.pack (symbolVal (Proxy @sym)) :) $ mkReq @t @m @sublayout @f r
|
||||
|
||||
getResp = getResp @t @m @sublayout @f
|
||||
|
||||
instance (SupportsServantReflex t m,
|
||||
ToHttpApiData a,
|
||||
EndpointR t m sublayout f,
|
||||
KnownSymbol sym,
|
||||
Applicative f
|
||||
) => EndpointR t m (QueryParam sym a :> sublayout) f where
|
||||
|
||||
type EInputs t m (QueryParam sym a :> sublayout) f = Maybe a ': EInputs t m sublayout f
|
||||
type EOutput t m (QueryParam sym a :> sublayout) f = EOutput t m sublayout f
|
||||
|
||||
mkReq (HCons x xs) = over (field @"reqRParams") ((T.pack $ symbolVal (Proxy @sym),
|
||||
QueryPartParam $ fmap (toQueryParam) x) : ) $
|
||||
mkReq @t @m @sublayout @f xs
|
||||
|
||||
|
||||
getResp = getResp @t @m @sublayout @f
|
||||
|
||||
instance (SupportsServantReflex t m,
|
||||
ToHttpApiData a,
|
||||
EndpointR t m sublayout f,
|
||||
KnownSymbol sym,
|
||||
Applicative f
|
||||
) => EndpointR t m (QueryParams sym a :> sublayout) f where
|
||||
|
||||
type EInputs t m (QueryParams sym a :> sublayout) f = [a] ': EInputs t m sublayout f
|
||||
type EOutput t m (QueryParams sym a :> sublayout) f = EOutput t m sublayout f
|
||||
|
||||
mkReq (HCons x xs) =
|
||||
let newParams = (T.pack (symbolVal (Proxy @sym)), QueryPartParams (toQueryParam <$> x))
|
||||
in over (field @"reqRParams") (newParams :) $ mkReq @t @m @sublayout @f xs
|
||||
|
||||
getResp = getResp @t @m @sublayout @f
|
||||
|
||||
instance (SupportsServantReflex t m,
|
||||
EndpointR t m sublayout f,
|
||||
KnownSymbol sym,
|
||||
Applicative f
|
||||
) => EndpointR t m (QueryFlag sym :> sublayout) f where
|
||||
|
||||
type EInputs t m (QueryFlag sym :> sublayout) f = Bool ': EInputs t m sublayout f
|
||||
type EOutput t m (QueryFlag sym :> sublayout) f = EOutput t m sublayout f
|
||||
|
||||
mkReq (HCons x xs) =
|
||||
let newParam = (T.pack (symbolVal (Proxy @sym)), QueryPartFlag x)
|
||||
in over (field @"reqRParams") (newParam :) $ mkReq @t @m @sublayout @f xs
|
||||
|
||||
getResp = getResp @t @m @sublayout @f
|
||||
|
||||
instance (SupportsServantReflex t m,
|
||||
EndpointR t m sublayout f,
|
||||
MimeRender ct a,
|
||||
Applicative f
|
||||
) => EndpointR t m (ReqBody (ct ': cts) a :> sublayout) f where
|
||||
|
||||
|
||||
type EInputs t m (ReqBody (ct ': cts) a :> sublayout) f = a ': EInputs t m sublayout f
|
||||
type EOutput t m (ReqBody (ct ': cts) a :> sublayout) f = EOutput t m sublayout f
|
||||
|
||||
mkReq (HCons x xs) =
|
||||
set (field @"reqRBody") (Just (mimeRender (Proxy @ct) x, T.pack (show (contentType (Proxy @ct))))) $ mkReq @t @m @sublayout @f xs
|
||||
|
||||
getResp = getResp @t @m @sublayout @f
|
||||
|
||||
|
||||
instance (SupportsServantReflex t m,
|
||||
EndpointR t m sublayout f,
|
||||
KnownSymbol sym,
|
||||
ToHttpApiData a,
|
||||
Applicative f
|
||||
) => EndpointR t m (Header sym a :> sublayout) f where
|
||||
|
||||
|
||||
type EInputs t m (Header sym a :> sublayout) f = a ': EInputs t m sublayout f
|
||||
type EOutput t m (Header sym a :> sublayout) f = EOutput t m sublayout f
|
||||
|
||||
mkReq (HCons x xs) =
|
||||
over (field @"reqRHeaders")
|
||||
-- ((symbolVal (Proxy @sym), (mimeRender (Proxy @a) x)) :)
|
||||
((T.pack $ symbolVal (Proxy @sym), E.decodeUtf8 $ toHeader x) :)
|
||||
$ mkReq @t @m @sublayout @f xs
|
||||
|
||||
getResp = getResp @t @m @sublayout @f
|
||||
|
||||
#if MIN_VERSION_servant(0,13,0)
|
||||
-- TODO: Untested
|
||||
instance (SupportsServantReflex t m,
|
||||
EndpointR t m sublayout f,
|
||||
KnownSymbol sym,
|
||||
ToHttpApiData a,
|
||||
Applicative f
|
||||
) => EndpointR t m (Summary desc :> sublayout) f where
|
||||
|
||||
type EInputs t m (Summary desc :> sublayout) f = EInputs t m sublayout f
|
||||
type EOutput t m (Summary desc :> sublayout) f = EOutput t m sublayout f
|
||||
|
||||
mkReq = mkReq @t @m @sublayout @f
|
||||
|
||||
getResp = getResp @t @m @sublayout @f
|
||||
#endif
|
||||
|
||||
|
||||
#if MIN_VERSION_servant(0,13,0)
|
||||
-- TODO: Untested
|
||||
instance (SupportsServantReflex t m,
|
||||
EndpointR t m sublayout f,
|
||||
KnownSymbol sym,
|
||||
ToHttpApiData a,
|
||||
Applicative f
|
||||
) => EndpointR t m (Description desc :> sublayout) f where
|
||||
|
||||
type EInputs t m (Descriptiok desc :> sublayout) f = EInputs t m sublayout f
|
||||
type EOutput t m (Description desc :> sublayout) f = EOutput t m sublayout f
|
||||
|
||||
mkReq = mkReq @t @m @sublayout @f
|
||||
|
||||
getResp = getResp @t @m @sublayout @f
|
||||
#endif
|
||||
|
||||
instance (SupportsServantReflex t m,
|
||||
EndpointR t m sublayout f,
|
||||
KnownSymbol sym,
|
||||
ToHttpApiData a,
|
||||
Applicative f
|
||||
) => EndpointR t m (IsSecure :> sublayout) f where
|
||||
|
||||
|
||||
type EInputs t m (IsSecure :> sublayout) f = EInputs t m sublayout f
|
||||
type EOutput t m (IsSecure :> sublayout) f = EOutput t m sublayout f
|
||||
|
||||
mkReq = mkReq @t @m @sublayout @f
|
||||
|
||||
getResp = getResp @t @m @sublayout @f
|
||||
|
||||
instance (SupportsServantReflex t m,
|
||||
EndpointR t m sublayout f,
|
||||
KnownSymbol sym,
|
||||
ToHttpApiData a,
|
||||
Applicative f
|
||||
) => EndpointR t m (Vault :> sublayout) f where
|
||||
|
||||
|
||||
type EInputs t m (Vault :> sublayout) f = EInputs t m sublayout f
|
||||
type EOutput t m (Vault :> sublayout) f = EOutput t m sublayout f
|
||||
|
||||
mkReq = mkReq @t @m @sublayout @f
|
||||
|
||||
getResp = getResp @t @m @sublayout @f
|
||||
|
||||
instance (SupportsServantReflex t m,
|
||||
EndpointR t m sublayout f,
|
||||
Applicative f
|
||||
) => EndpointR t m (BasicAuth realm usr :> sublayout) f where
|
||||
|
||||
type EInputs t m (BasicAuth realm usr :> sublayout) f = BasicAuthData ': EInputs t m sublayout f
|
||||
type EOutput t m (BasicAuth realm usr :> sublayout) f = EOutput t m sublayout f
|
||||
|
||||
mkReq (HCons x xs) =
|
||||
set (field @"reqRAuthData") (Just x) $ mkReq @t @m @sublayout @f xs
|
||||
|
||||
getResp = getResp @t @m @sublayout @f
|
||||
|
||||
|
||||
instance ToTuple (HList '[]) where
|
||||
type Tuple (HList '[]) = ()
|
||||
toTuple _ = ()
|
||||
@ -465,26 +106,6 @@ instance ToTuple (HList '[a,b,c]) where
|
||||
toTuple (HCons a (HCons b (HCons c HNil))) = (a,b,c)
|
||||
fromTuple (a,b,c) = HCons a (HCons b (HCons c HNil))
|
||||
|
||||
type MyAPI = Header "hi" Int :> Capture "hello" Int :> Capture "hello2" Bool :> Get '[JSON] (Headers '[Header "hi" Int] Int)
|
||||
:<|> Get '[JSON] Bool
|
||||
|
||||
type MyAPI2 = Raw
|
||||
|
||||
|
||||
m :: forall t m.MonadWidget t m => m ()
|
||||
m = do
|
||||
let (a :<|> b) = clientR (Proxy @MyAPI) (Proxy :: Proxy m) (Proxy :: Proxy t)
|
||||
(Proxy @[]) undefined
|
||||
btn <- button "Hello"
|
||||
resA <- a (fmap (:[]) ((2, 5,True) <$ btn))
|
||||
resB <- b (fmap (:[]) (() <$ btn))
|
||||
display =<< holdDyn "waiting" (leftmost [show <$> resB ])
|
||||
-- [show <$> resA
|
||||
-- , show <$> resB
|
||||
-- ])
|
||||
|
||||
let rawR = clientR (Proxy @MyAPI2) (Proxy @m) (Proxy @t) (Proxy @[]) undefined
|
||||
return ()
|
||||
|
||||
data ReqR = ReqR
|
||||
{ reqRMethod :: T.Text
|
||||
@ -547,7 +168,7 @@ mkXhrRequest reqHost req =
|
||||
Just (rb,ct) -> (M.insert "Content-Type" ct headers0,
|
||||
E.decodeUtf8 $ BL.toStrict rb)
|
||||
|
||||
xhrReqConfig = def
|
||||
xhrReqConfig = Default.def
|
||||
{ _xhrRequestConfig_headers = headers
|
||||
, _xhrRequestConfig_user = E.decodeUtf8 . basicAuthUsername <$> reqRAuthData req
|
||||
, _xhrRequestConfig_password = E.decodeUtf8 . basicAuthPassword <$> reqRAuthData req
|
||||
@ -559,9 +180,294 @@ mkXhrRequest reqHost req =
|
||||
xhrReq = XhrRequest (reqRMethod req) url xhrReqConfig
|
||||
in xhrReq
|
||||
|
||||
transformExample :: MonadWidget t m => ((Int, Char) -> Performable m Bool) -> Event t (Int, Char) -> m (Event t Bool)
|
||||
transformExample f = \triggers -> performEvent (f <$> triggers)
|
||||
-- transformExample = undefined -- let x = performEvent :: _ in undefined
|
||||
|
||||
transform :: MonadWidget t m => forall a. (inp -> IO outp) -> (Event t inp -> m (Event t outp))
|
||||
transform = undefined
|
||||
instance {-# OVERLAPPING #-}
|
||||
( MimeUnrender ct a
|
||||
, ReflectMethod method
|
||||
, cts' ~ (ct ': cts)
|
||||
, SupportsServantReflex t m
|
||||
-- , Applicative f
|
||||
)
|
||||
=> EndpointR t m (Verb method status cts' a) f where
|
||||
type EInputs t m (Verb method status cts' a) f = '[]
|
||||
type EOutput t m (Verb method status cts' a) f = Either String a
|
||||
|
||||
mkReq _ = emptyReqR . E.decodeUtf8 $ reflectMethod (Proxy @method)
|
||||
getResp resp = case _xhrResponse_response resp of
|
||||
Just (XhrResponseBody_ArrayBuffer x) -> mimeUnrender (Proxy @ct) (BL.fromStrict x)
|
||||
|
||||
instance {-# OVERLAPPING #-}
|
||||
( ReflectMethod method
|
||||
, SupportsServantReflex t m
|
||||
-- , Applicative f
|
||||
)
|
||||
=> EndpointR t m (Verb method status cts' NoContent) f where
|
||||
type EInputs t m (Verb method status cts' NoContent) f = '[]
|
||||
type EOutput t m (Verb method status cts' NoContent) f = Either String NoContent
|
||||
|
||||
mkReq _ = emptyReqR . E.decodeUtf8 $ reflectMethod (Proxy @method)
|
||||
getResp resp = Right NoContent -- TODO: Should EOutput be `NoContent` rather than Either... ?
|
||||
|
||||
|
||||
instance {-# OVERLAPPING #-}
|
||||
( MimeUnrender ct a
|
||||
, BuildHeadersTo hs
|
||||
, ReflectMethod method, cts' ~ (ct ': cts)
|
||||
, SupportsServantReflex t m
|
||||
-- , Applicative f
|
||||
, BuildHeaderKeysTo hs
|
||||
)
|
||||
=> EndpointR t m (Verb method status cts' (Headers hs a)) f where
|
||||
type EInputs t m (Verb method status cts' (Headers hs a)) f = '[]
|
||||
type EOutput t m (Verb method status cts' (Headers hs a)) f = Either String (Headers hs a)
|
||||
|
||||
mkReq _ = set (field @"reqRRespHeaders") (OnlyHeaders (Set.fromList (buildHeaderKeysTo (Proxy @hs)))) $ emptyReqR $ E.decodeUtf8 $ reflectMethod (Proxy @method)
|
||||
getResp resp = case _xhrResponse_response resp of
|
||||
Just (XhrResponseBody_ArrayBuffer x) ->
|
||||
let hs = buildHeadersTo
|
||||
. fmap (first (mk . E.encodeUtf8) . second E.encodeUtf8)
|
||||
. M.toList
|
||||
$ _xhrResponse_headers resp
|
||||
in fmap (flip Headers (hs)) $ mimeUnrender (Proxy @ct) (BL.fromStrict x)
|
||||
|
||||
|
||||
instance {-# OVERLAPPING #-}
|
||||
(MimeUnrender ct a
|
||||
, BuildHeadersTo hs
|
||||
, BuildHeaderKeysTo hs
|
||||
, ReflectMethod method
|
||||
, SupportsServantReflex t m
|
||||
-- , Applicative f
|
||||
)
|
||||
=> EndpointR t m (Verb method status cts' (Headers hs NoContent)) f where
|
||||
type EInputs t m (Verb method status cts' (Headers hs NoContent)) f = '[]
|
||||
type EOutput t m (Verb method status cts' (Headers hs NoContent)) f = Either String (Headers hs NoContent)
|
||||
|
||||
mkReq _ = set (field @"reqRRespHeaders") (OnlyHeaders (Set.fromList (buildHeaderKeysTo (Proxy @hs)))) $ emptyReqR . E.decodeUtf8 $ reflectMethod (Proxy @method)
|
||||
getResp resp = case _xhrResponse_response resp of
|
||||
Just (XhrResponseBody_ArrayBuffer x) ->
|
||||
let hs = buildHeadersTo
|
||||
. fmap (first (mk . E.encodeUtf8) . second E.encodeUtf8)
|
||||
. M.toList
|
||||
$ _xhrResponse_headers resp
|
||||
in Right (Headers NoContent hs)
|
||||
|
||||
|
||||
instance
|
||||
( SupportsServantReflex t m
|
||||
, ToHttpApiData a
|
||||
, EndpointR t m sublayout f
|
||||
-- , Applicative f
|
||||
)
|
||||
=> EndpointR t m (Capture capture a :> sublayout) f where
|
||||
|
||||
type EInputs t m (Capture capture a :> sublayout) f = a ': EInputs t m sublayout f
|
||||
type EOutput t m (Capture capture a :> sublayout) f = EOutput t m sublayout f
|
||||
|
||||
mkReq (HCons x xs) = (\a -> over (field @"reqRPathParts") (toUrlPiece a:)) x $
|
||||
mkReq @t @m @sublayout @f xs
|
||||
|
||||
getResp = getResp @t @m @sublayout @f
|
||||
|
||||
instance
|
||||
( SupportsServantReflex t m
|
||||
, ToHttpApiData a
|
||||
, EndpointR t m sublayout f
|
||||
, Applicative f
|
||||
)
|
||||
=> EndpointR t m (CaptureAll capture a :> sublayout) f where
|
||||
|
||||
type EInputs t m (CaptureAll capture a :> sublayout) f = [a] ': EInputs t m sublayout f
|
||||
type EOutput t m (CaptureAll capture a :> sublayout) f = EOutput t m sublayout f
|
||||
|
||||
mkReq (HCons x xs) = (\a -> over (field @"reqRPathParts") (fmap toUrlPiece a <>)) x $
|
||||
mkReq @t @m @sublayout @f xs
|
||||
|
||||
getResp = getResp @t @m @sublayout @f
|
||||
|
||||
|
||||
instance
|
||||
(SupportsServantReflex t m
|
||||
, KnownSymbol sym
|
||||
, EndpointR t m sublayout f
|
||||
-- , Applicative f
|
||||
)
|
||||
=> EndpointR t m (sym :> sublayout) f where
|
||||
|
||||
type EInputs t m (sym :> sublayout) f = EInputs t m sublayout f
|
||||
type EOutput t m (sym :> sublayout) f = EOutput t m sublayout f
|
||||
|
||||
mkReq r = over (field @"reqRPathParts") (T.pack (symbolVal (Proxy @sym)) :) $ mkReq @t @m @sublayout @f r
|
||||
|
||||
getResp = getResp @t @m @sublayout @f
|
||||
|
||||
instance
|
||||
( SupportsServantReflex t m
|
||||
, ToHttpApiData a
|
||||
, EndpointR t m sublayout f
|
||||
, KnownSymbol sym
|
||||
-- , Applicative f
|
||||
)
|
||||
=> EndpointR t m (QueryParam sym a :> sublayout) f where
|
||||
|
||||
type EInputs t m (QueryParam sym a :> sublayout) f = Maybe a ': EInputs t m sublayout f
|
||||
type EOutput t m (QueryParam sym a :> sublayout) f = EOutput t m sublayout f
|
||||
|
||||
mkReq (HCons x xs) = over (field @"reqRParams") ((T.pack $ symbolVal (Proxy @sym),
|
||||
QueryPartParam $ fmap (toQueryParam) x) : ) $
|
||||
mkReq @t @m @sublayout @f xs
|
||||
|
||||
|
||||
getResp = getResp @t @m @sublayout @f
|
||||
|
||||
instance
|
||||
( SupportsServantReflex t m
|
||||
, ToHttpApiData a
|
||||
, EndpointR t m sublayout f
|
||||
, KnownSymbol sym
|
||||
-- , Applicative f
|
||||
)
|
||||
=> EndpointR t m (QueryParams sym a :> sublayout) f where
|
||||
|
||||
type EInputs t m (QueryParams sym a :> sublayout) f = [a] ': EInputs t m sublayout f
|
||||
type EOutput t m (QueryParams sym a :> sublayout) f = EOutput t m sublayout f
|
||||
|
||||
mkReq (HCons x xs) =
|
||||
let newParams = (T.pack (symbolVal (Proxy @sym)), QueryPartParams (toQueryParam <$> x))
|
||||
in over (field @"reqRParams") (newParams :) $ mkReq @t @m @sublayout @f xs
|
||||
|
||||
getResp = getResp @t @m @sublayout @f
|
||||
|
||||
instance
|
||||
( SupportsServantReflex t m
|
||||
, EndpointR t m sublayout f
|
||||
, KnownSymbol sym
|
||||
-- , Applicative f
|
||||
)
|
||||
=> EndpointR t m (QueryFlag sym :> sublayout) f where
|
||||
|
||||
type EInputs t m (QueryFlag sym :> sublayout) f = Bool ': EInputs t m sublayout f
|
||||
type EOutput t m (QueryFlag sym :> sublayout) f = EOutput t m sublayout f
|
||||
|
||||
mkReq (HCons x xs) =
|
||||
let newParam = (T.pack (symbolVal (Proxy @sym)), QueryPartFlag x)
|
||||
in over (field @"reqRParams") (newParam :) $ mkReq @t @m @sublayout @f xs
|
||||
|
||||
getResp = getResp @t @m @sublayout @f
|
||||
|
||||
instance
|
||||
( SupportsServantReflex t m
|
||||
, EndpointR t m sublayout f
|
||||
, MimeRender ct a
|
||||
-- , Applicative f
|
||||
)
|
||||
=> EndpointR t m (ReqBody (ct ': cts) a :> sublayout) f where
|
||||
|
||||
|
||||
type EInputs t m (ReqBody (ct ': cts) a :> sublayout) f = a ': EInputs t m sublayout f
|
||||
type EOutput t m (ReqBody (ct ': cts) a :> sublayout) f = EOutput t m sublayout f
|
||||
|
||||
mkReq (HCons x xs) =
|
||||
set (field @"reqRBody") (Just (mimeRender (Proxy @ct) x, T.pack (show (contentType (Proxy @ct))))) $ mkReq @t @m @sublayout @f xs
|
||||
|
||||
getResp = getResp @t @m @sublayout @f
|
||||
|
||||
|
||||
instance
|
||||
( SupportsServantReflex t m
|
||||
, EndpointR t m sublayout f
|
||||
, KnownSymbol sym
|
||||
, ToHttpApiData a
|
||||
-- , Applicative f
|
||||
)
|
||||
=> EndpointR t m (Header sym a :> sublayout) f where
|
||||
|
||||
|
||||
type EInputs t m (Header sym a :> sublayout) f = a ': EInputs t m sublayout f
|
||||
type EOutput t m (Header sym a :> sublayout) f = EOutput t m sublayout f
|
||||
|
||||
mkReq (HCons x xs) =
|
||||
over (field @"reqRHeaders")
|
||||
-- ((symbolVal (Proxy @sym), (mimeRender (Proxy @a) x)) :)
|
||||
((T.pack $ symbolVal (Proxy @sym), E.decodeUtf8 $ toHeader x) :)
|
||||
$ mkReq @t @m @sublayout @f xs
|
||||
|
||||
getResp = getResp @t @m @sublayout @f
|
||||
|
||||
#if MIN_VERSION_servant(0,13,0)
|
||||
-- TODO: Untested
|
||||
instance (SupportsServantReflex t m,
|
||||
EndpointR t m sublayout f,
|
||||
KnownSymbol sym,
|
||||
ToHttpApiData a,
|
||||
Applicative f
|
||||
) => EndpointR t m (Summary desc :> sublayout) f where
|
||||
|
||||
type EInputs t m (Summary desc :> sublayout) f = EInputs t m sublayout f
|
||||
type EOutput t m (Summary desc :> sublayout) f = EOutput t m sublayout f
|
||||
|
||||
mkReq = mkReq @t @m @sublayout @f
|
||||
|
||||
getResp = getResp @t @m @sublayout @f
|
||||
#endif
|
||||
|
||||
|
||||
#if MIN_VERSION_servant(0,13,0)
|
||||
-- TODO: Untested
|
||||
instance (SupportsServantReflex t m,
|
||||
EndpointR t m sublayout f,
|
||||
KnownSymbol sym,
|
||||
ToHttpApiData a,
|
||||
Applicative f
|
||||
) => EndpointR t m (Description desc :> sublayout) f where
|
||||
|
||||
type EInputs t m (Description desc :> sublayout) f = EInputs t m sublayout f
|
||||
type EOutput t m (Description desc :> sublayout) f = EOutput t m sublayout f
|
||||
|
||||
mkReq = mkReq @t @m @sublayout @f
|
||||
|
||||
getResp = getResp @t @m @sublayout @f
|
||||
#endif
|
||||
|
||||
instance (SupportsServantReflex t m,
|
||||
EndpointR t m sublayout f,
|
||||
KnownSymbol sym,
|
||||
ToHttpApiData a,
|
||||
Applicative f
|
||||
) => EndpointR t m (IsSecure :> sublayout) f where
|
||||
|
||||
|
||||
type EInputs t m (IsSecure :> sublayout) f = EInputs t m sublayout f
|
||||
type EOutput t m (IsSecure :> sublayout) f = EOutput t m sublayout f
|
||||
|
||||
mkReq = mkReq @t @m @sublayout @f
|
||||
|
||||
getResp = getResp @t @m @sublayout @f
|
||||
|
||||
instance (SupportsServantReflex t m,
|
||||
EndpointR t m sublayout f,
|
||||
KnownSymbol sym,
|
||||
ToHttpApiData a,
|
||||
Applicative f
|
||||
) => EndpointR t m (Vault :> sublayout) f where
|
||||
|
||||
|
||||
type EInputs t m (Vault :> sublayout) f = EInputs t m sublayout f
|
||||
type EOutput t m (Vault :> sublayout) f = EOutput t m sublayout f
|
||||
|
||||
mkReq = mkReq @t @m @sublayout @f
|
||||
|
||||
getResp = getResp @t @m @sublayout @f
|
||||
|
||||
instance (SupportsServantReflex t m,
|
||||
EndpointR t m sublayout f,
|
||||
Applicative f
|
||||
) => EndpointR t m (BasicAuth realm usr :> sublayout) f where
|
||||
|
||||
type EInputs t m (BasicAuth realm usr :> sublayout) f = BasicAuthData ': EInputs t m sublayout f
|
||||
type EOutput t m (BasicAuth realm usr :> sublayout) f = EOutput t m sublayout f
|
||||
|
||||
mkReq (HCons x xs) =
|
||||
set (field @"reqRAuthData") (Just x) $ mkReq @t @m @sublayout @f xs
|
||||
|
||||
getResp = getResp @t @m @sublayout @f
|
||||
568
src/Servant/Reflex/TupleRequest.hs
Normal file
568
src/Servant/Reflex/TupleRequest.hs
Normal file
@ -0,0 +1,568 @@
|
||||
{-# LANGUAGE AllowAmbiguousTypes #-}
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE GADTs #-}
|
||||
{-# LANGUAGE InstanceSigs #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE PolyKinds #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TupleSections #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
|
||||
module Servant.Reflex.TupleRequest where
|
||||
|
||||
import Control.Arrow (first, second)
|
||||
import Control.Lens
|
||||
import qualified Data.ByteString.Lazy as BL
|
||||
import Data.CaseInsensitive (mk)
|
||||
import qualified Data.Default as Default
|
||||
import Data.Generics.Product
|
||||
import qualified Data.List as L
|
||||
import qualified Data.Map as M
|
||||
import Data.Maybe (catMaybes)
|
||||
import Data.Proxy
|
||||
import Data.Semigroup ((<>))
|
||||
import qualified Data.Set as Set
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Text.Encoding as E
|
||||
import GHC.Generics
|
||||
import GHC.TypeLits (KnownSymbol, symbolVal)
|
||||
import Language.Javascript.JSaddle (MonadJSM)
|
||||
import Reflex hiding (HList (..))
|
||||
import Servant.API hiding (HList (..))
|
||||
import Servant.Common.BaseUrl
|
||||
import Servant.Common.Req hiding (QueryPart (..))
|
||||
|
||||
import Reflex.Dom.Xhr hiding (HList (..))
|
||||
|
||||
import Servant.Reflex (BuildHeaderKeysTo (..),
|
||||
toHeaders)
|
||||
import Servant.Reflex.Internal.TupleRequest
|
||||
|
||||
{-
|
||||
TODO:
|
||||
- [x] :<|>
|
||||
- [x] Verb content
|
||||
- [x] Verb nocontent
|
||||
- [x] Verb (Headers content)
|
||||
- [x] Verb (Headers nocontent)
|
||||
- [ ] Stream
|
||||
- [X] Capture :> ...
|
||||
- [ ] Capture' :> ...
|
||||
- [x] CaptureAll :> ...
|
||||
- [x] QueryParam :> ...
|
||||
- [x] QueryParams :> ...
|
||||
- [x] QueryFlag :> ...
|
||||
- [x] ReqBody :> ...
|
||||
- [ ] Header' :> ...
|
||||
- [x] Header :> ...
|
||||
- [x] Summary :> ...
|
||||
- [x] Description :> ...
|
||||
- [x] path :> ...
|
||||
- [ ] RemoteHost :> ...
|
||||
- [x] IsSecure :> ...
|
||||
- [x] Vault :> ...
|
||||
- [ ] WithNamedContext :> ...
|
||||
- [ ] AuthenticatedRequest :> ...
|
||||
- [x] BasicAuth :> ...
|
||||
- [ ] EmptyClient :> ...
|
||||
- [ ] EmptyClient
|
||||
- [ ] HttpVersion :> ...
|
||||
-}
|
||||
|
||||
clientR
|
||||
:: forall t m layout
|
||||
.( HasClientR t m (Seal layout)
|
||||
, Reflex t
|
||||
)
|
||||
=> Proxy layout
|
||||
-> Proxy (m :: * -> *)
|
||||
-> Proxy t
|
||||
-> Dynamic t BaseUrl
|
||||
-> ClientR t m (Seal layout)
|
||||
clientR _ mP tP url =
|
||||
clientRWithRoute (Proxy :: Proxy (Seal layout)) mP undefined url undefined
|
||||
-- empty -^ dynOpts -^
|
||||
|
||||
-- | A class for generating top-level the API client function
|
||||
class HasClientR t (m :: * -> *) api where
|
||||
type ClientR t m api :: *
|
||||
clientRWithRoute
|
||||
:: Proxy api
|
||||
-> Proxy m
|
||||
-> Dynamic t (Req t)
|
||||
-> Dynamic t BaseUrl
|
||||
-> ClientOptions
|
||||
-> ClientR t m api
|
||||
|
||||
|
||||
|
||||
-- -- | A class for generating endpoint-level API client functions
|
||||
-- -- We need two separate type classes because the needs of endpoints
|
||||
-- -- and top-level clients are incompatible
|
||||
-- --
|
||||
-- -- Endpoints need to accumulate a list of their input types from
|
||||
-- -- the API definition (the @EInputs@ associated type) when building
|
||||
-- -- up a function from a sequence of @:>@ combinators. But for
|
||||
-- -- sequences of @:<|>@ combinators, such a listing doesn't make
|
||||
-- -- sense. So, we use one class for endpoint-level recursion and
|
||||
-- -- another for collecting endpoints into the top-level API
|
||||
-- class EndpointR t m api where
|
||||
|
||||
-- type EInputs t m api :: [*]
|
||||
-- type EOutput t m api :: *
|
||||
|
||||
-- mkReq :: HList (EInputs t m api) -> ReqR
|
||||
-- getResp :: XhrResponse -> EOutput t m api
|
||||
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | :<|> APIs
|
||||
instance {-# OVERLAPPING #-}
|
||||
(HasClientR t m (layoutLeft),
|
||||
HasClientR t m (layoutRight)
|
||||
) => HasClientR t m (layoutLeft :<|> layoutRight) where
|
||||
type ClientR t m (layoutLeft :<|> layoutRight) =
|
||||
ClientR t m layoutLeft :<|> ClientR t m layoutRight
|
||||
clientRWithRoute _ mP _ url opts =
|
||||
clientRWithRoute (Proxy @layoutLeft) mP undefined url opts
|
||||
:<|>
|
||||
clientRWithRoute (Proxy @layoutRight) mP undefined url opts
|
||||
|
||||
#if MIN_VERSION_servant (0,13,0)
|
||||
-- TODO: Untested
|
||||
instance HasClientR t m EmptyAPI where
|
||||
type ClientR t m EmptyAPI = EmptyAPI
|
||||
clientRWithRoute _ _ _ _ _ = EmptyAPI
|
||||
#endif
|
||||
|
||||
|
||||
|
||||
-- | Turn a single Endpoint into a client, by turning the input HList
|
||||
-- into a tuple
|
||||
instance {-# OVERLAPPING #-}
|
||||
forall t m layout
|
||||
.( EndpointR t m layout Identity
|
||||
, ToTuple (HList (EInputs t m layout Identity))
|
||||
, Monad m
|
||||
, SupportsServantReflex t m
|
||||
)
|
||||
=> HasClientR t (m :: * -> *) (Sealed layout) where
|
||||
type ClientR t m (Sealed layout) =
|
||||
Event t (Tuple (HList (EInputs t m layout Identity)))
|
||||
-> m (Event t (EOutput t m layout Identity))
|
||||
clientRWithRoute _ mP dReq url opts (reqs :: Event t (Tuple (HList (EInputs t m layout Identity)))) = do
|
||||
let
|
||||
reqTuples :: Event t (HList (EInputs t m layout Identity))
|
||||
reqTuples = (fromTuple @(HList (EInputs t m layout Identity))) <$> reqs
|
||||
|
||||
-- TODO: replace these 2 lines w/ the next 2. The trace is for library debugging
|
||||
reqRs :: Event t (ReqR)
|
||||
reqRs = (mkReq @t @m @layout @Identity) <$> reqTuples
|
||||
|
||||
reqs' :: Event t (XhrRequest T.Text)
|
||||
reqs' = ffor (attachPromptlyDyn url reqRs) $ \(bUrl, rs) -> mkXhrRequest bUrl $ rs
|
||||
-- reqs' = ffor (attachPromptlyDyn url reqTuples) $ \(bUrl, inputs) ->
|
||||
-- mkXhrRequest bUrl . mkReq @t @m @layout @f <$> inputs
|
||||
resps <- performRequestAsync $ reqs'
|
||||
-- return $ _ resps
|
||||
return ((getResp @t @m @layout @Identity) <$> resps)
|
||||
|
||||
|
||||
instance (SupportsServantReflex t m) => HasClientR t m SealedRaw where
|
||||
type ClientR t m SealedRaw = Event t (XhrRequest T.Text) -> m (Event t XhrResponse)
|
||||
clientRWithRoute _ mP dReq url opts reqs = performRequestAsync reqs
|
||||
|
||||
|
||||
-- instance {-# OVERLAPPING #-}(MimeUnrender ct a, ReflectMethod method, cts' ~ (ct ': cts), SupportsServantReflex t m
|
||||
-- ) => EndpointR t m (Verb method status cts' a) where
|
||||
-- type EInputs t m (Verb method status cts' a) = '[]
|
||||
-- type EOutput t m (Verb method status cts' a) = Either String a
|
||||
|
||||
-- mkReq _ = emptyReqR . E.decodeUtf8 $ reflectMethod (Proxy @method)
|
||||
-- getResp resp = case _xhrResponse_response resp of
|
||||
-- Just (XhrResponseBody_ArrayBuffer x) -> mimeUnrender (Proxy @ct) (BL.fromStrict x)
|
||||
|
||||
-- instance {-# OVERLAPPING #-}(ReflectMethod method, SupportsServantReflex t m
|
||||
-- ) => EndpointR t m (Verb method status cts' NoContent) where
|
||||
-- type EInputs t m (Verb method status cts' NoContent) = '[]
|
||||
-- type EOutput t m (Verb method status cts' NoContent) = Either String NoContent
|
||||
|
||||
-- mkReq _ = emptyReqR . E.decodeUtf8 $ reflectMethod (Proxy @method)
|
||||
-- getResp resp = Right NoContent -- TODO: Should EOutput be `NoContent` rather than Either... ?
|
||||
|
||||
|
||||
-- instance {-# OVERLAPPING #-}
|
||||
-- (MimeUnrender ct a,
|
||||
-- BuildHeadersTo hs,
|
||||
-- ReflectMethod method, cts' ~ (ct ': cts),
|
||||
-- SupportsServantReflex t m,
|
||||
-- Applicative f,
|
||||
-- BuildHeaderKeysTo hs
|
||||
-- ) => EndpointR t m (Verb method status cts' (Headers hs a)) f where
|
||||
-- type EInputs t m (Verb method status cts' (Headers hs a)) f = '[]
|
||||
-- type EOutput t m (Verb method status cts' (Headers hs a)) f = Either String (Headers hs a)
|
||||
|
||||
-- mkReq _ = set (field @"reqRRespHeaders") (OnlyHeaders (Set.fromList (buildHeaderKeysTo (Proxy @hs)))) $ emptyReqR $ E.decodeUtf8 $ reflectMethod (Proxy @method)
|
||||
-- getResp resp = case _xhrResponse_response resp of
|
||||
-- Just (XhrResponseBody_ArrayBuffer x) ->
|
||||
-- let hs = buildHeadersTo
|
||||
-- . fmap (first (mk . E.encodeUtf8) . second E.encodeUtf8)
|
||||
-- . M.toList
|
||||
-- $ _xhrResponse_headers resp
|
||||
-- in fmap (flip Headers (hs)) $ mimeUnrender (Proxy @ct) (BL.fromStrict x)
|
||||
|
||||
|
||||
-- instance {-# OVERLAPPING #-}(MimeUnrender ct a,
|
||||
-- BuildHeadersTo hs,
|
||||
-- BuildHeaderKeysTo hs,
|
||||
-- ReflectMethod method,
|
||||
-- SupportsServantReflex t m,
|
||||
-- Applicative f
|
||||
-- ) => EndpointR t m (Verb method status cts' (Headers hs NoContent)) f where
|
||||
-- type EInputs t m (Verb method status cts' (Headers hs NoContent)) f = '[]
|
||||
-- type EOutput t m (Verb method status cts' (Headers hs NoContent)) f = Either String (Headers hs NoContent)
|
||||
|
||||
-- mkReq _ = set (field @"reqRRespHeaders") (OnlyHeaders (Set.fromList (buildHeaderKeysTo (Proxy @hs)))) $ emptyReqR . E.decodeUtf8 $ reflectMethod (Proxy @method)
|
||||
-- getResp resp = case _xhrResponse_response resp of
|
||||
-- Just (XhrResponseBody_ArrayBuffer x) ->
|
||||
-- let hs = buildHeadersTo
|
||||
-- . fmap (first (mk . E.encodeUtf8) . second E.encodeUtf8)
|
||||
-- . M.toList
|
||||
-- $ _xhrResponse_headers resp
|
||||
-- in Right (Headers NoContent hs)
|
||||
|
||||
|
||||
-- instance (SupportsServantReflex t m,
|
||||
-- ToHttpApiData a,
|
||||
-- EndpointR t m sublayout f,
|
||||
-- Applicative f
|
||||
-- ) => EndpointR t m (Capture capture a :> sublayout) f where
|
||||
|
||||
-- type EInputs t m (Capture capture a :> sublayout) f = a ': EInputs t m sublayout f
|
||||
-- type EOutput t m (Capture capture a :> sublayout) f = EOutput t m sublayout f
|
||||
|
||||
-- mkReq (HCons x xs) = (\a -> over (field @"reqRPathParts") (toUrlPiece a:)) x $
|
||||
-- mkReq @t @m @sublayout @f xs
|
||||
|
||||
-- getResp = getResp @t @m @sublayout @f
|
||||
|
||||
-- instance (SupportsServantReflex t m,
|
||||
-- ToHttpApiData a,
|
||||
-- EndpointR t m sublayout f,
|
||||
-- Applicative f
|
||||
-- ) => EndpointR t m (CaptureAll capture a :> sublayout) f where
|
||||
|
||||
-- type EInputs t m (CaptureAll capture a :> sublayout) f = [a] ': EInputs t m sublayout f
|
||||
-- type EOutput t m (CaptureAll capture a :> sublayout) f = EOutput t m sublayout f
|
||||
|
||||
-- mkReq (HCons x xs) = (\a -> over (field @"reqRPathParts") (fmap toUrlPiece a <>)) x $
|
||||
-- mkReq @t @m @sublayout @f xs
|
||||
|
||||
-- getResp = getResp @t @m @sublayout @f
|
||||
|
||||
|
||||
-- instance (SupportsServantReflex t m,
|
||||
-- KnownSymbol sym,
|
||||
-- EndpointR t m sublayout f,
|
||||
-- Applicative f
|
||||
-- ) => EndpointR t m (sym :> sublayout) f where
|
||||
|
||||
-- type EInputs t m (sym :> sublayout) f = EInputs t m sublayout f
|
||||
-- type EOutput t m (sym :> sublayout) f = EOutput t m sublayout f
|
||||
|
||||
-- mkReq r = over (field @"reqRPathParts") (T.pack (symbolVal (Proxy @sym)) :) $ mkReq @t @m @sublayout @f r
|
||||
|
||||
-- getResp = getResp @t @m @sublayout @f
|
||||
|
||||
-- instance (SupportsServantReflex t m,
|
||||
-- ToHttpApiData a,
|
||||
-- EndpointR t m sublayout f,
|
||||
-- KnownSymbol sym,
|
||||
-- Applicative f
|
||||
-- ) => EndpointR t m (QueryParam sym a :> sublayout) f where
|
||||
|
||||
-- type EInputs t m (QueryParam sym a :> sublayout) f = Maybe a ': EInputs t m sublayout f
|
||||
-- type EOutput t m (QueryParam sym a :> sublayout) f = EOutput t m sublayout f
|
||||
|
||||
-- mkReq (HCons x xs) = over (field @"reqRParams") ((T.pack $ symbolVal (Proxy @sym),
|
||||
-- QueryPartParam $ fmap (toQueryParam) x) : ) $
|
||||
-- mkReq @t @m @sublayout @f xs
|
||||
|
||||
|
||||
-- getResp = getResp @t @m @sublayout @f
|
||||
|
||||
-- instance (SupportsServantReflex t m,
|
||||
-- ToHttpApiData a,
|
||||
-- EndpointR t m sublayout f,
|
||||
-- KnownSymbol sym,
|
||||
-- Applicative f
|
||||
-- ) => EndpointR t m (QueryParams sym a :> sublayout) f where
|
||||
|
||||
-- type EInputs t m (QueryParams sym a :> sublayout) f = [a] ': EInputs t m sublayout f
|
||||
-- type EOutput t m (QueryParams sym a :> sublayout) f = EOutput t m sublayout f
|
||||
|
||||
-- mkReq (HCons x xs) =
|
||||
-- let newParams = (T.pack (symbolVal (Proxy @sym)), QueryPartParams (toQueryParam <$> x))
|
||||
-- in over (field @"reqRParams") (newParams :) $ mkReq @t @m @sublayout @f xs
|
||||
|
||||
-- getResp = getResp @t @m @sublayout @f
|
||||
|
||||
-- instance (SupportsServantReflex t m,
|
||||
-- EndpointR t m sublayout f,
|
||||
-- KnownSymbol sym,
|
||||
-- Applicative f
|
||||
-- ) => EndpointR t m (QueryFlag sym :> sublayout) f where
|
||||
|
||||
-- type EInputs t m (QueryFlag sym :> sublayout) f = Bool ': EInputs t m sublayout f
|
||||
-- type EOutput t m (QueryFlag sym :> sublayout) f = EOutput t m sublayout f
|
||||
|
||||
-- mkReq (HCons x xs) =
|
||||
-- let newParam = (T.pack (symbolVal (Proxy @sym)), QueryPartFlag x)
|
||||
-- in over (field @"reqRParams") (newParam :) $ mkReq @t @m @sublayout @f xs
|
||||
|
||||
-- getResp = getResp @t @m @sublayout @f
|
||||
|
||||
-- instance (SupportsServantReflex t m,
|
||||
-- EndpointR t m sublayout f,
|
||||
-- MimeRender ct a,
|
||||
-- Applicative f
|
||||
-- ) => EndpointR t m (ReqBody (ct ': cts) a :> sublayout) f where
|
||||
|
||||
|
||||
-- type EInputs t m (ReqBody (ct ': cts) a :> sublayout) f = a ': EInputs t m sublayout f
|
||||
-- type EOutput t m (ReqBody (ct ': cts) a :> sublayout) f = EOutput t m sublayout f
|
||||
|
||||
-- mkReq (HCons x xs) =
|
||||
-- set (field @"reqRBody") (Just (mimeRender (Proxy @ct) x, T.pack (show (contentType (Proxy @ct))))) $ mkReq @t @m @sublayout @f xs
|
||||
|
||||
-- getResp = getResp @t @m @sublayout @f
|
||||
|
||||
|
||||
-- instance (SupportsServantReflex t m,
|
||||
-- EndpointR t m sublayout f,
|
||||
-- KnownSymbol sym,
|
||||
-- ToHttpApiData a,
|
||||
-- Applicative f
|
||||
-- ) => EndpointR t m (Header sym a :> sublayout) f where
|
||||
|
||||
|
||||
-- type EInputs t m (Header sym a :> sublayout) f = a ': EInputs t m sublayout f
|
||||
-- type EOutput t m (Header sym a :> sublayout) f = EOutput t m sublayout f
|
||||
|
||||
-- mkReq (HCons x xs) =
|
||||
-- over (field @"reqRHeaders")
|
||||
-- -- ((symbolVal (Proxy @sym), (mimeRender (Proxy @a) x)) :)
|
||||
-- ((T.pack $ symbolVal (Proxy @sym), E.decodeUtf8 $ toHeader x) :)
|
||||
-- $ mkReq @t @m @sublayout @f xs
|
||||
|
||||
-- getResp = getResp @t @m @sublayout @f
|
||||
|
||||
-- #if MIN_VERSION_servant(0,13,0)
|
||||
-- -- TODO: Untested
|
||||
-- instance (SupportsServantReflex t m,
|
||||
-- EndpointR t m sublayout f,
|
||||
-- KnownSymbol sym,
|
||||
-- ToHttpApiData a,
|
||||
-- Applicative f
|
||||
-- ) => EndpointR t m (Summary desc :> sublayout) f where
|
||||
|
||||
-- type EInputs t m (Summary desc :> sublayout) f = EInputs t m sublayout f
|
||||
-- type EOutput t m (Summary desc :> sublayout) f = EOutput t m sublayout f
|
||||
|
||||
-- mkReq = mkReq @t @m @sublayout @f
|
||||
|
||||
-- getResp = getResp @t @m @sublayout @f
|
||||
-- #endif
|
||||
|
||||
|
||||
-- #if MIN_VERSION_servant(0,13,0)
|
||||
-- -- TODO: Untested
|
||||
-- instance (SupportsServantReflex t m,
|
||||
-- EndpointR t m sublayout f,
|
||||
-- KnownSymbol sym,
|
||||
-- ToHttpApiData a,
|
||||
-- Applicative f
|
||||
-- ) => EndpointR t m (Description desc :> sublayout) f where
|
||||
|
||||
-- type EInputs t m (Description desc :> sublayout) f = EInputs t m sublayout f
|
||||
-- type EOutput t m (Description desc :> sublayout) f = EOutput t m sublayout f
|
||||
|
||||
-- mkReq = mkReq @t @m @sublayout @f
|
||||
|
||||
-- getResp = getResp @t @m @sublayout @f
|
||||
-- #endif
|
||||
|
||||
-- instance (SupportsServantReflex t m,
|
||||
-- EndpointR t m sublayout f,
|
||||
-- KnownSymbol sym,
|
||||
-- ToHttpApiData a,
|
||||
-- Applicative f
|
||||
-- ) => EndpointR t m (IsSecure :> sublayout) f where
|
||||
|
||||
|
||||
-- type EInputs t m (IsSecure :> sublayout) f = EInputs t m sublayout f
|
||||
-- type EOutput t m (IsSecure :> sublayout) f = EOutput t m sublayout f
|
||||
|
||||
-- mkReq = mkReq @t @m @sublayout @f
|
||||
|
||||
-- getResp = getResp @t @m @sublayout @f
|
||||
|
||||
-- instance (SupportsServantReflex t m,
|
||||
-- EndpointR t m sublayout f,
|
||||
-- KnownSymbol sym,
|
||||
-- ToHttpApiData a,
|
||||
-- Applicative f
|
||||
-- ) => EndpointR t m (Vault :> sublayout) f where
|
||||
|
||||
|
||||
-- type EInputs t m (Vault :> sublayout) f = EInputs t m sublayout f
|
||||
-- type EOutput t m (Vault :> sublayout) f = EOutput t m sublayout f
|
||||
|
||||
-- mkReq = mkReq @t @m @sublayout @f
|
||||
|
||||
-- getResp = getResp @t @m @sublayout @f
|
||||
|
||||
-- instance (SupportsServantReflex t m,
|
||||
-- EndpointR t m sublayout f,
|
||||
-- Applicative f
|
||||
-- ) => EndpointR t m (BasicAuth realm usr :> sublayout) f where
|
||||
|
||||
-- type EInputs t m (BasicAuth realm usr :> sublayout) f = BasicAuthData ': EInputs t m sublayout f
|
||||
-- type EOutput t m (BasicAuth realm usr :> sublayout) f = EOutput t m sublayout f
|
||||
|
||||
-- mkReq (HCons x xs) =
|
||||
-- set (field @"reqRAuthData") (Just x) $ mkReq @t @m @sublayout @f xs
|
||||
|
||||
-- getResp = getResp @t @m @sublayout @f
|
||||
|
||||
|
||||
-- instance ToTuple (HList '[]) where
|
||||
-- type Tuple (HList '[]) = ()
|
||||
-- toTuple _ = ()
|
||||
-- fromTuple _ = HNil
|
||||
|
||||
-- instance ToTuple (HList '[a]) where
|
||||
-- type Tuple (HList '[a]) = a
|
||||
-- toTuple (HCons a HNil) = a
|
||||
-- fromTuple a = HCons a HNil
|
||||
|
||||
-- instance ToTuple (HList '[a,b]) where
|
||||
-- type Tuple (HList '[a,b]) = (a,b)
|
||||
-- toTuple (HCons a (HCons b HNil)) = (a,b)
|
||||
-- fromTuple (a,b) = HCons a (HCons b HNil)
|
||||
|
||||
-- instance ToTuple (HList '[a,b,c]) where
|
||||
-- type Tuple (HList '[a,b,c]) = (a,b,c)
|
||||
-- toTuple (HCons a (HCons b (HCons c HNil))) = (a,b,c)
|
||||
-- fromTuple (a,b,c) = HCons a (HCons b (HCons c HNil))
|
||||
|
||||
-- type MyAPI = Header "hi" Int :> Capture "hello" Int :> Capture "hello2" Bool :> Get '[JSON] (Headers '[Header "hi" Int] Int)
|
||||
-- :<|> Get '[JSON] Bool
|
||||
|
||||
-- type MyAPI2 = Raw
|
||||
|
||||
|
||||
-- m :: forall t m.MonadWidget t m => m ()
|
||||
-- m = do
|
||||
-- let (a :<|> b) = clientR (Proxy @MyAPI) (Proxy :: Proxy m) (Proxy :: Proxy t)
|
||||
-- (Proxy @[]) undefined
|
||||
-- btn <- button "Hello"
|
||||
-- resA <- a (fmap (:[]) ((2, 5,True) <$ btn))
|
||||
-- resB <- b (fmap (:[]) (() <$ btn))
|
||||
-- display =<< holdDyn "waiting" (leftmost [show <$> resB ])
|
||||
-- -- [show <$> resA
|
||||
-- -- , show <$> resB
|
||||
-- -- ])
|
||||
|
||||
-- let rawR = clientR (Proxy @MyAPI2) (Proxy @m) (Proxy @t) (Proxy @[]) undefined
|
||||
-- return ()
|
||||
|
||||
-- data ReqR = ReqR
|
||||
-- { reqRMethod :: T.Text
|
||||
-- , reqRPathParts :: [T.Text]
|
||||
-- , reqRParams :: [(T.Text, QueryPart)]
|
||||
-- , reqRBody :: Maybe (BL.ByteString, T.Text)
|
||||
-- , reqRHeaders :: [(T.Text, T.Text)]
|
||||
-- , reqRRespHeaders :: XhrResponseHeaders
|
||||
-- , reqRAuthData :: Maybe BasicAuthData
|
||||
-- } deriving (Generic)
|
||||
|
||||
-- instance Show ReqR where
|
||||
-- show (ReqR m pp ps b hs hs' a) = concat $ L.intersperse "\n" [
|
||||
-- "ReqR {"
|
||||
-- , ("reqRMethod = " <> show m)
|
||||
-- , ("reqRPathParts = " <> show pp)
|
||||
-- , ("reqRParams = " <> show ps)
|
||||
-- , ("reqRBody = " <> show b)
|
||||
-- , ("reqRHeaders = " <> show hs)
|
||||
-- , ("reqRRespHeaders = " <> show hs')
|
||||
-- , ("reqRAuthData = " <> maybe "Nothing" (const "Just <<redacted>>") a)
|
||||
-- ]
|
||||
|
||||
-- emptyReqR :: T.Text -> ReqR
|
||||
-- emptyReqR method = ReqR method [] [] Nothing [] (OnlyHeaders mempty) Nothing
|
||||
|
||||
-- data QueryPart = QueryPartParam (Maybe Text)
|
||||
-- | QueryPartParams [Text]
|
||||
-- | QueryPartFlag Bool
|
||||
-- deriving (Show)
|
||||
|
||||
-- mkXhrRequest :: BaseUrl -> ReqR -> XhrRequest T.Text
|
||||
-- mkXhrRequest reqHost req =
|
||||
-- let path = T.intercalate "/" $ reqRPathParts req
|
||||
|
||||
-- queryPartString :: (Text, QueryPart) -> Maybe Text
|
||||
-- queryPartString (pName, qp) = case qp of
|
||||
|
||||
-- QueryPartParam Nothing -> Nothing
|
||||
-- QueryPartParam (Just a) -> Just (pName <> "=" <> escape a)
|
||||
|
||||
-- QueryPartParams ps -> Just . T.intercalate "&"
|
||||
-- $ fmap (\p -> pName <> "=" <> escape p)
|
||||
-- ps
|
||||
|
||||
-- QueryPartFlag True -> Just pName
|
||||
-- QueryPartFlag False -> Nothing
|
||||
|
||||
-- (</>) :: Text -> Text -> Text
|
||||
-- x </> y | ("/" `T.isSuffixOf` x) || ("/" `T.isPrefixOf` y) = x <> y
|
||||
-- | otherwise = x <> "/" <> y
|
||||
|
||||
-- queryString = T.intercalate "&" . catMaybes . map queryPartString $ reqRParams req
|
||||
-- url = showBaseUrl reqHost </> path <> if T.null queryString then "" else (T.cons '?' queryString)
|
||||
|
||||
-- (headers, body) =
|
||||
-- let headers0 = M.fromList $ reqRHeaders req
|
||||
-- in case reqRBody req of
|
||||
-- Nothing -> (headers0, "")
|
||||
-- Just (rb,ct) -> (M.insert "Content-Type" ct headers0,
|
||||
-- E.decodeUtf8 $ BL.toStrict rb)
|
||||
|
||||
-- xhrReqConfig = def
|
||||
-- { _xhrRequestConfig_headers = headers
|
||||
-- , _xhrRequestConfig_user = E.decodeUtf8 . basicAuthUsername <$> reqRAuthData req
|
||||
-- , _xhrRequestConfig_password = E.decodeUtf8 . basicAuthPassword <$> reqRAuthData req
|
||||
-- , _xhrRequestConfig_responseType = Just XhrResponseType_ArrayBuffer
|
||||
-- , _xhrRequestConfig_sendData = body
|
||||
-- , _xhrRequestConfig_responseHeaders = reqRRespHeaders req
|
||||
-- , _xhrRequestConfig_withCredentials = False
|
||||
-- }
|
||||
-- xhrReq = XhrRequest (reqRMethod req) url xhrReqConfig
|
||||
-- in xhrReq
|
||||
|
||||
-- transformExample :: MonadWidget t m => ((Int, Char) -> Performable m Bool) -> Event t (Int, Char) -> m (Event t Bool)
|
||||
-- transformExample f = \triggers -> performEvent (f <$> triggers) 1
|
||||
-- -- transformExample = undefined -- let x = performEvent :: _ in undefined
|
||||
|
||||
-- transform :: MonadWidget t m => forall a. (inp -> IO outp) -> (Event t inp -> m (Event t outp))
|
||||
-- transform = undefined
|
||||
153
src/Servant/Reflex/TupleRequestMulti.hs
Normal file
153
src/Servant/Reflex/TupleRequestMulti.hs
Normal file
@ -0,0 +1,153 @@
|
||||
{-# LANGUAGE AllowAmbiguousTypes #-}
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE GADTs #-}
|
||||
{-# LANGUAGE InstanceSigs #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE PolyKinds #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TupleSections #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
|
||||
module Servant.Reflex.TupleRequestMulti where
|
||||
|
||||
import Control.Arrow (first, second)
|
||||
import Control.Lens
|
||||
import qualified Data.ByteString.Lazy as BL
|
||||
import Data.CaseInsensitive (mk)
|
||||
import qualified Data.Default as Default
|
||||
import Data.Generics.Product
|
||||
import qualified Data.List as L
|
||||
import qualified Data.Map as M
|
||||
import Data.Maybe (catMaybes)
|
||||
import Data.Proxy
|
||||
import Data.Semigroup ((<>))
|
||||
import qualified Data.Set as Set
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Text.Encoding as E
|
||||
import GHC.Generics
|
||||
import GHC.TypeLits (KnownSymbol, symbolVal)
|
||||
import Language.Javascript.JSaddle (MonadJSM)
|
||||
import Reflex hiding (HList (..))
|
||||
import Servant.API hiding (HList (..))
|
||||
import Servant.Common.BaseUrl
|
||||
import Servant.Common.Req hiding (QueryPart (..))
|
||||
|
||||
import Reflex.Dom.Xhr hiding (HList (..))
|
||||
|
||||
import Servant.Reflex (BuildHeaderKeysTo (..), toHeaders)
|
||||
import Servant.Reflex.Internal.TupleRequest
|
||||
|
||||
{-
|
||||
TODO:
|
||||
- [x] :<|>
|
||||
- [x] Verb content
|
||||
- [x] Verb nocontent
|
||||
- [x] Verb (Headers content)
|
||||
- [x] Verb (Headers nocontent)
|
||||
- [ ] Stream
|
||||
- [X] Capture :> ...
|
||||
- [ ] Capture' :> ...
|
||||
- [x] CaptureAll :> ...
|
||||
- [x] QueryParam :> ...
|
||||
- [x] QueryParams :> ...
|
||||
- [x] QueryFlag :> ...
|
||||
- [x] ReqBody :> ...
|
||||
- [ ] Header' :> ...
|
||||
- [x] Header :> ...
|
||||
- [x] Summary :> ...
|
||||
- [x] Description :> ...
|
||||
- [x] path :> ...
|
||||
- [ ] RemoteHost :> ...
|
||||
- [x] IsSecure :> ...
|
||||
- [x] Vault :> ...
|
||||
- [ ] WithNamedContext :> ...
|
||||
- [ ] AuthenticatedRequest :> ...
|
||||
- [x] BasicAuth :> ...
|
||||
- [ ] EmptyClient :> ...
|
||||
- [ ] EmptyClient
|
||||
- [ ] HttpVersion :> ...
|
||||
-}
|
||||
|
||||
clientR
|
||||
:: forall t m layout f
|
||||
. ( HasClientR t m (Seal layout) f
|
||||
-- , Applicative f
|
||||
, Reflex t
|
||||
)
|
||||
=> Proxy layout
|
||||
-> Proxy (m :: * -> *)
|
||||
-> Proxy t
|
||||
-> Proxy f
|
||||
-> Dynamic t BaseUrl
|
||||
-> ClientR t m (Seal layout) f
|
||||
clientR _ mP tP fP url =
|
||||
clientRWithRoute (Proxy :: Proxy (Seal layout)) mP fP undefined url undefined
|
||||
|
||||
-- | A class for generating top-level the API client function
|
||||
class HasClientR t (m :: * -> *) api (f :: * -> *) where
|
||||
type ClientR t m api f :: *
|
||||
clientRWithRoute :: Proxy api -> Proxy m -> Proxy f
|
||||
-> Dynamic t (f (Req t)) -> Dynamic t BaseUrl
|
||||
-> ClientOptions -> ClientR t m api f
|
||||
|
||||
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | :<|> APIs
|
||||
instance {-# OVERLAPPING #-}
|
||||
(HasClientR t m (layoutLeft) f,
|
||||
HasClientR t m (layoutRight) f
|
||||
) => HasClientR t m (layoutLeft :<|> layoutRight) f where
|
||||
type ClientR t m (layoutLeft :<|> layoutRight) f =
|
||||
ClientR t m layoutLeft f :<|> ClientR t m layoutRight f
|
||||
clientRWithRoute _ tP mP _ url opts =
|
||||
clientRWithRoute (Proxy @layoutLeft) tP mP undefined url opts
|
||||
:<|>
|
||||
clientRWithRoute (Proxy @layoutRight) tP mP undefined url opts
|
||||
|
||||
#if MIN_VERSION_servant (0,13,0)
|
||||
-- TODO: Untested
|
||||
instance HasClientR t m EmptyAPI f where
|
||||
type ClientR t m EmptyAPI f = EmptyAPI
|
||||
clientRWithRoute _ _ _ _ _ _ = EmptyAPI
|
||||
#endif
|
||||
|
||||
|
||||
-- | Turn a single Endpoint into a client, by turning the input HList
|
||||
-- into a tuple
|
||||
instance {-# OVERLAPPING #-} forall t m layout f .(EndpointR t m layout f,
|
||||
ToTuple (HList (EInputs t m layout f)),
|
||||
Monad m
|
||||
, Traversable f
|
||||
, SupportsServantReflex t m
|
||||
) => HasClientR t (m :: * -> *) (Sealed layout) (f :: * -> *) where
|
||||
type ClientR t m (Sealed layout) f =
|
||||
Event t (f (Tuple (HList (EInputs t m layout f))))
|
||||
-> m (Event t (f (EOutput t m layout f)))
|
||||
clientRWithRoute _ mP fP dReq url opts (reqs :: Event t (f (Tuple (HList (EInputs t m layout f ))))) = do
|
||||
let reqTuples = fmap (fromTuple @(HList (EInputs t m layout f ))) <$> reqs
|
||||
|
||||
-- TODO: replace these 2 lines w/ the next 2. The trace is for library debugging
|
||||
reqRs = traceEventWith (concat . fmap ((<> "\n") . show)) $ fmap (mkReq @t @m @layout @f) <$> reqTuples
|
||||
reqs' = ffor (attachPromptlyDyn url reqRs) $ \(bUrl, rs) -> mkXhrRequest bUrl <$> rs
|
||||
-- reqs' = ffor (attachPromptlyDyn url reqTuples) $ \(bUrl, inputs) ->
|
||||
-- mkXhrRequest bUrl . mkReq @t @m @layout @f <$> inputs
|
||||
resps <- performRequestsAsync $ reqs'
|
||||
return (fmap (getResp @t @m @layout @f) <$> resps)
|
||||
|
||||
|
||||
instance (SupportsServantReflex t m, Traversable f) => HasClientR t m SealedRaw f where
|
||||
type ClientR t m SealedRaw f = Event t (f (XhrRequest T.Text)) -> m (Event t (f XhrResponse))
|
||||
clientRWithRoute _ mP fP dReq url opts reqs = performRequestsAsync reqs
|
||||
|
||||
|
||||
@ -19,13 +19,13 @@ executable back
|
||||
main-is: Main.hs
|
||||
-- other-modules:
|
||||
-- other-extensions:
|
||||
build-depends: aeson >= 0.9 && < 1.4
|
||||
build-depends: aeson >= 0.9 && < 1.5
|
||||
, base >=4.8 && <4.14
|
||||
, mtl
|
||||
, snap >= 1.0 && < 1.2
|
||||
, snap-server >= 1.0 && < 1.2
|
||||
, snap-core >= 1.0 && < 1.1
|
||||
, servant >= 0.8 && < 0.15
|
||||
, servant >= 0.8 && < 0.18
|
||||
, servant-snap >= 0.8 && < 0.9
|
||||
, text >= 1.0 && < 1.3
|
||||
-- hs-source-dirs:
|
||||
|
||||
Loading…
Reference in New Issue
Block a user