@@ -1,567 +0,0 @@
1−{-# LANGUAGE AllowAmbiguousTypes #-}
3−{-# LANGUAGE DataKinds #-}
4−{-# LANGUAGE DeriveGeneric #-}
5−{-# LANGUAGE FlexibleContexts #-}
6−{-# LANGUAGE FlexibleInstances #-}
8−{-# LANGUAGE InstanceSigs #-}
9−{-# LANGUAGE MultiParamTypeClasses #-}
10−{-# LANGUAGE OverloadedStrings #-}
11−{-# LANGUAGE PolyKinds #-}
12−{-# LANGUAGE RankNTypes #-} -- Temporary
13−{-# LANGUAGE ScopedTypeVariables #-}
14−{-# LANGUAGE TupleSections #-}
15−{-# LANGUAGE TypeApplications #-}
16−{-# LANGUAGE TypeFamilies #-}
17−{-# LANGUAGE TypeOperators #-}
18−{-# LANGUAGE UndecidableInstances #-}
20−module Servant.Reflex.RequestAPI where
22−import Control.Arrow (first, second)
24−import Data.Generics.Product
26−import Data.CaseInsensitive (mk)
27−import qualified Data.List as L
28−import qualified Data.Map as M
29−import Data.Maybe (catMaybes)
30−import Data.Semigroup ((<>))
31−import qualified Data.Set as Set
32−import qualified Data.Text.Encoding as E
33−import Data.Text (Text)
34−import qualified Data.Text as T
35−import qualified Data.ByteString.Lazy as BL
37−import GHC.TypeLits (KnownSymbol, symbolVal)
38−import Reflex hiding (HList(..))
39−import Language.Javascript.JSaddle (MonadJSM)
40−import Servant.API hiding (HList(..))
41−import Servant.Common.Req hiding (QueryPart(..))
42−import Servant.Common.BaseUrl
44−import Reflex.Dom hiding (HList(..))
46−import Servant.Reflex (BuildHeaderKeysTo (..), toHeaders)
53− - [x] Verb (Headers content)
54− - [x] Verb (Headers nocontent)
57− - [ ] Capture' :> ...
58− - [x] CaptureAll :> ...
59− - [x] QueryParam :> ...
60− - [x] QueryParams :> ...
61− - [x] QueryFlag :> ...
66− - [x] Description :> ...
68− - [ ] RemoteHost :> ...
69− - [x] IsSecure :> ...
71− - [ ] WithNamedContext :> ...
72− - [ ] AuthenticatedRequest :> ...
73− - [x] BasicAuth :> ...
74− - [ ] EmptyClient :> ...
76− - [ ] HttpVersion :> ...
80− HCons :: x -> HList xs -> HList (x ': xs)
82−clientR :: forall t m layout f . (HasClientR t m (Seal layout) f, Applicative f, Reflex t)
83− => Proxy layout -> Proxy (m :: * -> *) -> Proxy t -> Proxy f
84− -> Dynamic t BaseUrl -> ClientR t m (Seal layout) f
85−clientR _ mP tP fP url =
86− clientRWithRoute (Proxy :: Proxy (Seal layout)) mP fP undefined url undefined
88−-- | A class for generating top-level the API client function
89−class HasClientR t (m :: * -> *) api (f :: * -> *) where
90− type ClientR t m api f :: *
91− clientRWithRoute :: Proxy api -> Proxy m -> Proxy f
92− -> Dynamic t (f (Req t)) -> Dynamic t BaseUrl
93− -> ClientOptions -> ClientR t m api f
95−-- instance EndpointR t m Raw f where
96−-- type EInputs t m Raw f = '[XhrRequest T.Text]
97−-- type EOutput t m Raw f = XhrResponse
99−-- mkReq (HCons (XhrRequest method url conf) NHil) =
103−-- | A class for generating endpoint-level API client functions
104−-- We need two separate type classes because the needs of endpoints
105−-- and top-level clients are incompatible
107−-- Endpoints need to accumulate a list of their input types from
108−-- the API definition (the @EInputs@ associated type) when building
109−-- up a function from a sequence of @:>@ combinators. But for
110−-- sequences of @:<|>@ combinators, such a listing doesn't make
111−-- sense. So, we use one class for endpoint-level recursion and
112−-- another for collecting endpoints into the top-level API
113−class EndpointR t m api f where
115− type EInputs t m api f :: [*]
116− type EOutput t m api f :: *
118− mkReq :: HList (EInputs t m api f) -> ReqR
119− getResp :: XhrResponse -> EOutput t m api f
122−------------------------------------------------------------------------------
124−instance {-# OVERLAPPING #-}
125− (HasClientR t m (layoutLeft) f,
126− HasClientR t m (layoutRight) f
127− ) => HasClientR t m (layoutLeft :<|> layoutRight) f where
128− type ClientR t m (layoutLeft :<|> layoutRight) f =
129− ClientR t m layoutLeft f :<|> ClientR t m layoutRight f
130− clientRWithRoute _ tP mP _ url opts =
131− clientRWithRoute (Proxy @layoutLeft) tP mP undefined url opts
133− clientRWithRoute (Proxy @layoutRight) tP mP undefined url opts
135−#if MIN_VERSION_servant (0,13,0)
137−instance HasClientR t m EmptyClient f where
138− type ClientR t m api f = EmptyClient
139− clientRWithRoute _ _ _ _ _ _ = EmptyClient
143−class ToTuple xs where
145− toTuple :: xs -> Tuple xs
146− fromTuple :: Tuple xs -> xs
151−type family Seal a where
152− Seal (a :<|> b) = Seal a :<|> Seal b
153− Seal Raw = SealedRaw
157−-- | Turn a single Endpoint into a client, by turning the input HList
159−instance {-# OVERLAPPING #-} forall t m layout f .(EndpointR t m layout f,
160− ToTuple (HList (EInputs t m layout f)),
163− , SupportsServantReflex t m
164− ) => HasClientR t (m :: * -> *) (Sealed layout) (f :: * -> *) where
165− type ClientR t m (Sealed layout) f =
166− Event t (f (Tuple (HList (EInputs t m layout f))))
167− -> m (Event t (f (EOutput t m layout f)))
168− clientRWithRoute _ mP fP dReq url opts (reqs :: Event t (f (Tuple (HList (EInputs t m layout f ))))) = do
169− let reqTuples = fmap (fromTuple @(HList (EInputs t m layout f ))) <$> reqs
171− -- TODO: replace these 2 lines w/ the next 2. The trace is for library debugging
172− reqRs = traceEventWith (concat . fmap ((<> "\n") . show)) $ fmap (mkReq @t @m @layout @f) <$> reqTuples
173− reqs' = ffor (attachPromptlyDyn url reqRs) $ \(bUrl, rs) -> mkXhrRequest bUrl <$> rs
174− -- reqs' = ffor (attachPromptlyDyn url reqTuples) $ \(bUrl, inputs) ->
175− -- mkXhrRequest bUrl . mkReq @t @m @layout @f <$> inputs
176− resps <- performRequestsAsync $ reqs'
177− return (fmap (getResp @t @m @layout @f) <$> resps)
180−instance (SupportsServantReflex t m, Traversable f) => HasClientR t m SealedRaw f where
181− type ClientR t m SealedRaw f = Event t (f (XhrRequest T.Text)) -> m (Event t (f XhrResponse))
182− clientRWithRoute _ mP fP dReq url opts reqs = performRequestsAsync reqs
185−instance {-# OVERLAPPING #-}(MimeUnrender ct a, ReflectMethod method, cts' ~ (ct ': cts), SupportsServantReflex t m, Applicative f
186− ) => EndpointR t m (Verb method status cts' a) f where
187− type EInputs t m (Verb method status cts' a) f = '[]
188− type EOutput t m (Verb method status cts' a) f = Either String a
190− mkReq _ = emptyReqR . E.decodeUtf8 $ reflectMethod (Proxy @method)
191− getResp resp = case _xhrResponse_response resp of
192− Just (XhrResponseBody_ArrayBuffer x) -> mimeUnrender (Proxy @ct) (BL.fromStrict x)
194−instance {-# OVERLAPPING #-}(ReflectMethod method, SupportsServantReflex t m, Applicative f
195− ) => EndpointR t m (Verb method status cts' NoContent) f where
196− type EInputs t m (Verb method status cts' NoContent) f = '[]
197− type EOutput t m (Verb method status cts' NoContent) f = Either String NoContent
199− mkReq _ = emptyReqR . E.decodeUtf8 $ reflectMethod (Proxy @method)
200− getResp resp = Right NoContent -- TODO: Should EOutput be `NoContent` rather than Either... ?
203−instance {-# OVERLAPPING #-}
206− ReflectMethod method, cts' ~ (ct ': cts),
207− SupportsServantReflex t m,
209− BuildHeaderKeysTo hs
210− ) => EndpointR t m (Verb method status cts' (Headers hs a)) f where
211− type EInputs t m (Verb method status cts' (Headers hs a)) f = '[]
212− type EOutput t m (Verb method status cts' (Headers hs a)) f = Either String (Headers hs a)
214− mkReq _ = set (field @"reqRRespHeaders") (OnlyHeaders (Set.fromList (buildHeaderKeysTo (Proxy @hs)))) $ emptyReqR $ E.decodeUtf8 $ reflectMethod (Proxy @method)
215− getResp resp = case _xhrResponse_response resp of
216− Just (XhrResponseBody_ArrayBuffer x) ->
217− let hs = buildHeadersTo
218− . fmap (first (mk . E.encodeUtf8) . second E.encodeUtf8)
220− $ _xhrResponse_headers resp
221− in fmap (flip Headers (hs)) $ mimeUnrender (Proxy @ct) (BL.fromStrict x)
224−instance {-# OVERLAPPING #-}(MimeUnrender ct a,
226− BuildHeaderKeysTo hs,
227− ReflectMethod method,
228− SupportsServantReflex t m,
230− ) => EndpointR t m (Verb method status cts' (Headers hs NoContent)) f where
231− type EInputs t m (Verb method status cts' (Headers hs NoContent)) f = '[]
232− type EOutput t m (Verb method status cts' (Headers hs NoContent)) f = Either String (Headers hs NoContent)
234− mkReq _ = set (field @"reqRRespHeaders") (OnlyHeaders (Set.fromList (buildHeaderKeysTo (Proxy @hs)))) $ emptyReqR . E.decodeUtf8 $ reflectMethod (Proxy @method)
235− getResp resp = case _xhrResponse_response resp of
236− Just (XhrResponseBody_ArrayBuffer x) ->
237− let hs = buildHeadersTo
238− . fmap (first (mk . E.encodeUtf8) . second E.encodeUtf8)
240− $ _xhrResponse_headers resp
241− in Right (Headers NoContent hs)
244−instance (SupportsServantReflex t m,
246− EndpointR t m sublayout f,
248− ) => EndpointR t m (Capture capture a :> sublayout) f where
250− type EInputs t m (Capture capture a :> sublayout) f = a ': EInputs t m sublayout f
251− type EOutput t m (Capture capture a :> sublayout) f = EOutput t m sublayout f
253− mkReq (HCons x xs) = (\a -> over (field @"reqRPathParts") (toUrlPiece a:)) x $
254− mkReq @t @m @sublayout @f xs
256− getResp = getResp @t @m @sublayout @f
258−instance (SupportsServantReflex t m,
260− EndpointR t m sublayout f,
262− ) => EndpointR t m (CaptureAll capture a :> sublayout) f where
264− type EInputs t m (CaptureAll capture a :> sublayout) f = [a] ': EInputs t m sublayout f
265− type EOutput t m (CaptureAll capture a :> sublayout) f = EOutput t m sublayout f
267− mkReq (HCons x xs) = (\a -> over (field @"reqRPathParts") (fmap toUrlPiece a <>)) x $
268− mkReq @t @m @sublayout @f xs
270− getResp = getResp @t @m @sublayout @f
273−instance (SupportsServantReflex t m,
275− EndpointR t m sublayout f,
277− ) => EndpointR t m (sym :> sublayout) f where
279− type EInputs t m (sym :> sublayout) f = EInputs t m sublayout f
280− type EOutput t m (sym :> sublayout) f = EOutput t m sublayout f
282− mkReq r = over (field @"reqRPathParts") (T.pack (symbolVal (Proxy @sym)) :) $ mkReq @t @m @sublayout @f r
284− getResp = getResp @t @m @sublayout @f
286−instance (SupportsServantReflex t m,
288− EndpointR t m sublayout f,
291− ) => EndpointR t m (QueryParam sym a :> sublayout) f where
293− type EInputs t m (QueryParam sym a :> sublayout) f = Maybe a ': EInputs t m sublayout f
294− type EOutput t m (QueryParam sym a :> sublayout) f = EOutput t m sublayout f
296− mkReq (HCons x xs) = over (field @"reqRParams") ((T.pack $ symbolVal (Proxy @sym),
297− QueryPartParam $ fmap (toQueryParam) x) : ) $
298− mkReq @t @m @sublayout @f xs
301− getResp = getResp @t @m @sublayout @f
303−instance (SupportsServantReflex t m,
305− EndpointR t m sublayout f,
308− ) => EndpointR t m (QueryParams sym a :> sublayout) f where
310− type EInputs t m (QueryParams sym a :> sublayout) f = [a] ': EInputs t m sublayout f
311− type EOutput t m (QueryParams sym a :> sublayout) f = EOutput t m sublayout f
313− mkReq (HCons x xs) =
314− let newParams = (T.pack (symbolVal (Proxy @sym)), QueryPartParams (toQueryParam <$> x))
315− in over (field @"reqRParams") (newParams :) $ mkReq @t @m @sublayout @f xs
317− getResp = getResp @t @m @sublayout @f
319−instance (SupportsServantReflex t m,
320− EndpointR t m sublayout f,
323− ) => EndpointR t m (QueryFlag sym :> sublayout) f where
325− type EInputs t m (QueryFlag sym :> sublayout) f = Bool ': EInputs t m sublayout f
326− type EOutput t m (QueryFlag sym :> sublayout) f = EOutput t m sublayout f
328− mkReq (HCons x xs) =
329− let newParam = (T.pack (symbolVal (Proxy @sym)), QueryPartFlag x)
330− in over (field @"reqRParams") (newParam :) $ mkReq @t @m @sublayout @f xs
332− getResp = getResp @t @m @sublayout @f
334−instance (SupportsServantReflex t m,
335− EndpointR t m sublayout f,
338− ) => EndpointR t m (ReqBody (ct ': cts) a :> sublayout) f where
341− type EInputs t m (ReqBody (ct ': cts) a :> sublayout) f = a ': EInputs t m sublayout f
342− type EOutput t m (ReqBody (ct ': cts) a :> sublayout) f = EOutput t m sublayout f
344− mkReq (HCons x xs) =
345− set (field @"reqRBody") (Just (mimeRender (Proxy @ct) x, T.pack (show (contentType (Proxy @ct))))) $ mkReq @t @m @sublayout @f xs
347− getResp = getResp @t @m @sublayout @f
350−instance (SupportsServantReflex t m,
351− EndpointR t m sublayout f,
355− ) => EndpointR t m (Header sym a :> sublayout) f where
358− type EInputs t m (Header sym a :> sublayout) f = a ': EInputs t m sublayout f
359− type EOutput t m (Header sym a :> sublayout) f = EOutput t m sublayout f
361− mkReq (HCons x xs) =
362− over (field @"reqRHeaders")
363− -- ((symbolVal (Proxy @sym), (mimeRender (Proxy @a) x)) :)
364− ((T.pack $ symbolVal (Proxy @sym), E.decodeUtf8 $ toHeader x) :)
365− $ mkReq @t @m @sublayout @f xs
367− getResp = getResp @t @m @sublayout @f
369−#if MIN_VERSION_servant(0,13,0)
371−instance (SupportsServantReflex t m,
372− EndpointR t m sublayout f,
376− ) => EndpointR t m (Summary desc :> sublayout) f where
378− type EInputs t m (Summary desc :> sublayout) f = EInputs t m sublayout f
379− type EOutput t m (Summary desc :> sublayout) f = EOutput t m sublayout f
381− mkReq = mkReq @t @m @sublayout @f
383− getResp = getResp @t @m @sublayout @f
387−#if MIN_VERSION_servant(0,13,0)
389−instance (SupportsServantReflex t m,
390− EndpointR t m sublayout f,
394− ) => EndpointR t m (Description desc :> sublayout) f where
396− type EInputs t m (Descriptiok desc :> sublayout) f = EInputs t m sublayout f
397− type EOutput t m (Description desc :> sublayout) f = EOutput t m sublayout f
399− mkReq = mkReq @t @m @sublayout @f
401− getResp = getResp @t @m @sublayout @f
404−instance (SupportsServantReflex t m,
405− EndpointR t m sublayout f,
409− ) => EndpointR t m (IsSecure :> sublayout) f where
412− type EInputs t m (IsSecure :> sublayout) f = EInputs t m sublayout f
413− type EOutput t m (IsSecure :> sublayout) f = EOutput t m sublayout f
415− mkReq = mkReq @t @m @sublayout @f
417− getResp = getResp @t @m @sublayout @f
419−instance (SupportsServantReflex t m,
420− EndpointR t m sublayout f,
424− ) => EndpointR t m (Vault :> sublayout) f where
427− type EInputs t m (Vault :> sublayout) f = EInputs t m sublayout f
428− type EOutput t m (Vault :> sublayout) f = EOutput t m sublayout f
430− mkReq = mkReq @t @m @sublayout @f
432− getResp = getResp @t @m @sublayout @f
434−instance (SupportsServantReflex t m,
435− EndpointR t m sublayout f,
437− ) => EndpointR t m (BasicAuth realm usr :> sublayout) f where
439− type EInputs t m (BasicAuth realm usr :> sublayout) f = BasicAuthData ': EInputs t m sublayout f
440− type EOutput t m (BasicAuth realm usr :> sublayout) f = EOutput t m sublayout f
442− mkReq (HCons x xs) =
443− set (field @"reqRAuthData") (Just x) $ mkReq @t @m @sublayout @f xs
445− getResp = getResp @t @m @sublayout @f
448−instance ToTuple (HList '[]) where
449− type Tuple (HList '[]) = ()
453−instance ToTuple (HList '[a]) where
454− type Tuple (HList '[a]) = a
455− toTuple (HCons a HNil) = a
456− fromTuple a = HCons a HNil
458−instance ToTuple (HList '[a,b]) where
459− type Tuple (HList '[a,b]) = (a,b)
460− toTuple (HCons a (HCons b HNil)) = (a,b)
461− fromTuple (a,b) = HCons a (HCons b HNil)
463−instance ToTuple (HList '[a,b,c]) where
464− type Tuple (HList '[a,b,c]) = (a,b,c)
465− toTuple (HCons a (HCons b (HCons c HNil))) = (a,b,c)
466− fromTuple (a,b,c) = HCons a (HCons b (HCons c HNil))
468−type MyAPI = Header "hi" Int :> Capture "hello" Int :> Capture "hello2" Bool :> Get '[JSON] (Headers '[Header "hi" Int] Int)
469− :<|> Get '[JSON] Bool
474−m :: forall t m.MonadWidget t m => m ()
476− let (a :<|> b) = clientR (Proxy @MyAPI) (Proxy :: Proxy m) (Proxy :: Proxy t)
477− (Proxy @[]) undefined
478− btn <- button "Hello"
479− resA <- a (fmap (:[]) ((2, 5,True) <$ btn))
480− resB <- b (fmap (:[]) (() <$ btn))
481− display =<< holdDyn "waiting" (leftmost [show <$> resB ])
486− let rawR = clientR (Proxy @MyAPI2) (Proxy @m) (Proxy @t) (Proxy @[]) undefined
490− { reqRMethod :: T.Text
491− , reqRPathParts :: [T.Text]
492− , reqRParams :: [(T.Text, QueryPart)]
493− , reqRBody :: Maybe (BL.ByteString, T.Text)
494− , reqRHeaders :: [(T.Text, T.Text)]
495− , reqRRespHeaders :: XhrResponseHeaders
496− , reqRAuthData :: Maybe BasicAuthData
497− } deriving (Generic)
499−instance Show ReqR where
500− show (ReqR m pp ps b hs hs' a) = concat $ L.intersperse "\n" [
502− , ("reqRMethod = " <> show m)
503− , ("reqRPathParts = " <> show pp)
504− , ("reqRParams = " <> show ps)
505− , ("reqRBody = " <> show b)
506− , ("reqRHeaders = " <> show hs)
507− , ("reqRRespHeaders = " <> show hs')
508− , ("reqRAuthData = " <> maybe "Nothing" (const "Just <<redacted>>") a)
511−emptyReqR :: T.Text -> ReqR
512−emptyReqR method = ReqR method [] [] Nothing [] (OnlyHeaders mempty) Nothing
514−data QueryPart = QueryPartParam (Maybe Text)
515− | QueryPartParams [Text]
516− | QueryPartFlag Bool
519−mkXhrRequest :: BaseUrl -> ReqR -> XhrRequest T.Text
520−mkXhrRequest reqHost req =
521− let path = T.intercalate "/" $ reqRPathParts req
523− queryPartString :: (Text, QueryPart) -> Maybe Text
524− queryPartString (pName, qp) = case qp of
526− QueryPartParam Nothing -> Nothing
527− QueryPartParam (Just a) -> Just (pName <> "=" <> escape a)
529− QueryPartParams ps -> Just . T.intercalate "&"
530− $ fmap (\p -> pName <> "=" <> escape p)
533− QueryPartFlag True -> Just pName
534− QueryPartFlag False -> Nothing
536− (</>) :: Text -> Text -> Text
537− x </> y | ("/" `T.isSuffixOf` x) || ("/" `T.isPrefixOf` y) = x <> y
538− | otherwise = x <> "/" <> y
540− queryString = T.intercalate "&" . catMaybes . map queryPartString $ reqRParams req
541− url = showBaseUrl reqHost </> path <> if T.null queryString then "" else (T.cons '?' queryString)
544− let headers0 = M.fromList $ reqRHeaders req
545− in case reqRBody req of
546− Nothing -> (headers0, "")
547− Just (rb,ct) -> (M.insert "Content-Type" ct headers0,
548− E.decodeUtf8 $ BL.toStrict rb)
551− { _xhrRequestConfig_headers = headers
552− , _xhrRequestConfig_user = E.decodeUtf8 . basicAuthUsername <$> reqRAuthData req
553− , _xhrRequestConfig_password = E.decodeUtf8 . basicAuthPassword <$> reqRAuthData req
554− , _xhrRequestConfig_responseType = Just XhrResponseType_ArrayBuffer
555− , _xhrRequestConfig_sendData = body
556− , _xhrRequestConfig_responseHeaders = reqRRespHeaders req
557− , _xhrRequestConfig_withCredentials = False
559− xhrReq = XhrRequest (reqRMethod req) url xhrReqConfig
562−transformExample :: MonadWidget t m => ((Int, Char) -> Performable m Bool) -> Event t (Int, Char) -> m (Event t Bool)
563−transformExample f = \triggers -> performEvent (f <$> triggers)
564−-- transformExample = undefined -- let x = performEvent :: _ in undefined
566−transform :: MonadWidget t m => forall a. (inp -> IO outp) -> (Event t inp -> m (Event t outp))
567−transform = undefined