@@ -0,0 +1,390 @@
1+{-# LANGUAGE AllowAmbiguousTypes #-}
2+{-# LANGUAGE CPP #-}
3+{-# LANGUAGE DataKinds #-}
4+{-# LANGUAGE DeriveGeneric #-}
5+{-# LANGUAGE FlexibleContexts #-}
6+{-# LANGUAGE FlexibleInstances #-}
7+{-# LANGUAGE GADTs #-}
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 #-}
19+
20+module Servant.Reflex.RequestAPI where
21+
22+import Control.Lens
23+import Data.Generics.Product
24+import Data.Proxy
25+import qualified Data.Map as M
26+import Data.Maybe (catMaybes)
27+import Data.Semigroup ((<>))
28+import qualified Data.Text.Encoding as E
29+import Data.Text (Text)
30+import qualified Data.Text as T
31+import qualified Data.ByteString.Lazy as BL
32+import GHC.Generics
33+import GHC.TypeLits (KnownSymbol, symbolVal)
34+import Reflex hiding (HList(..))
35+import Language.Javascript.JSaddle (MonadJSM)
36+import Servant.API hiding (HList(..))
37+import Servant.Common.Req hiding (QueryPart(..))
38+import Servant.Common.BaseUrl
39+
40+import Reflex.Dom hiding (HList(..))
41+
42+data HList xs where
43+ HNil :: HList '[]
44+ HCons :: x -> HList xs -> HList (x ': xs)
45+
46+clientR :: forall t m layout f tag. (HasClientR t m (Seal layout) f tag, Applicative f, Reflex t)
47+ => Proxy layout -> Proxy (m :: * -> *) -> Proxy t -> Proxy f -> Proxy tag
48+ -> Dynamic t BaseUrl -> ClientR t m (Seal layout) f tag
49+clientR _ mP tP fP tagP url =
50+ clientRWithRoute (Proxy :: Proxy (Seal layout)) mP fP tagP undefined url undefined
51+
52+-- | A class for generating top-level the API client function
53+class HasClientR t (m :: * -> *) api (f :: * -> *) tag where
54+ type ClientR t m api f tag :: *
55+ clientRWithRoute :: Proxy api -> Proxy m -> Proxy f -> Proxy tag
56+ -> Dynamic t (f (Req t)) -> Dynamic t BaseUrl
57+ -> ClientOptions -> ClientR t m api f tag
58+
59+
60+
61+-- | A class for generating endpoint-level API client functions
62+-- We need two separate type classes because the needs of endpoints
63+-- and top-level clients are incompatible
64+--
65+-- Endpoints need to accumulate a list of their input types from
66+-- the API definition (the @EInputs@ associated type) when building
67+-- up a function from a sequence of @:>@ combinators. But for
68+-- sequences of @:<|>@ combinators, such a listing doesn't make
69+-- sense. So, we use one class for endpoint-level recursion and
70+-- another for collecting endpoints into the top-level API
71+class EndpointR t m api f tag where
72+
73+ type EndpointResult t m api f tag :: *
74+ type EInputs t m api f tag :: [*]
75+ type EOutput t m api f tag :: *
76+
77+ mkReq :: HList (EInputs t m api f tag) -> ReqR
78+ getResp :: XhrResponse -> EOutput t m api f tag
79+
80+ eInputs :: HList (EInputs t m api f tag)
81+ clientEndpoint :: Proxy api -> Proxy m -> Proxy f -> Proxy tag
82+ -> f ReqR -> Dynamic t BaseUrl
83+ -> ClientOptions -> EndpointResult t m api f tag
84+
85+
86+instance {-# OVERLAPPING #-} (HasClientR t m (layoutLeft) f tag,
87+ HasClientR t m (layoutRight) f tag
88+ ) => HasClientR t m (layoutLeft :<|> layoutRight) f tag where
89+ type ClientR t m (layoutLeft :<|> layoutRight) f tag =
90+ ClientR t m (layoutLeft) f tag :<|> ClientR t m (layoutRight) f tag
91+ clientRWithRoute _ tP mP tagP _ url opts =
92+ clientRWithRoute (Proxy @(layoutLeft)) tP mP tagP undefined url opts
93+ :<|>
94+ clientRWithRoute (Proxy @(layoutRight)) tP mP tagP undefined url opts
95+
96+
97+
98+-- instance {-# OVERLAPPING #-} (HasClientR t m (Sealed layoutLeft) f tag,
99+-- HasClientR t m (Sealed layoutRight) f tag
100+-- ) => HasClientR t m (Sealed layoutLeft :<|> Sealed layoutRight) f tag where
101+-- type ClientR t m (Sealed layoutLeft :<|> Sealed layoutRight) f tag =
102+-- ClientR t m (Sealed layoutLeft) f tag :<|> ClientR t m (Sealed layoutRight) f tag
103+-- clientRWithRoute _ tP mP tagP _ url opts =
104+-- clientRWithRoute (Proxy @(Sealed layoutLeft)) tP mP tagP undefined url opts
105+-- :<|>
106+-- clientRWithRoute (Proxy @(Sealed layoutRight)) tP mP tagP undefined url opts
107+
108+
109+class ToTuple xs where
110+ type Tuple xs :: *
111+ toTuple :: xs -> Tuple xs
112+ fromTuple :: Tuple xs -> xs
113+
114+-- class FromTuple xs where
115+-- type UnTuple xs :: *
116+-- fromTuple :: Tuple xs -> xs
117+
118+data Sealed a
119+
120+type family Seal a where
121+ Seal (a :<|> b) = Seal a :<|> Seal b
122+ Seal a = Sealed a
123+
124+-- | Turn a single Endpoint into a client, by turning the input HList
125+-- into a tuple
126+instance {-# OVERLAPPING #-} forall t m layout f tag .(EndpointR t m layout f tag,
127+ ToTuple (HList (EInputs t m layout f tag)),
128+ Monad m
129+ , Traversable f
130+ , SupportsServantReflex t m
131+ ) => HasClientR t (m :: * -> *) (Sealed layout) (f :: * -> *) tag where
132+ type ClientR t m (Sealed layout) f tag =
133+ Event t (f (Tuple (HList (EInputs t m layout f tag))))
134+ -> m (Event t (f (EOutput t m layout f tag)))
135+ clientRWithRoute _ mP fP tagP dReq url opts (reqs :: Event t (f (Tuple (HList (EInputs t m layout f tag))))) = do
136+ let reqTuples = fmap (fromTuple @(HList (EInputs t m layout f tag))) <$> reqs
137+ reqs' = ffor (attachPromptlyDyn url reqTuples) $ \(bUrl, inputs) ->
138+ mkXhrRequest bUrl . mkReq @t @m @layout @f @tag <$> inputs
139+ resps <- performRequestsAsync reqs'
140+ return (fmap (getResp @t @m @layout @f @tag) <$> resps)
141+
142+
143+instance (SupportsServantReflex t m, Traversable f) => HasClientR t m Raw f tag where
144+ type ClientR t m Raw f tag = Event t (f (XhrRequest T.Text)) -> m (Event t (f XhrResponse))
145+ clientRWithRoute _ mP fP tagP dReq url opts reqs = performRequestsAsync reqs
146+
147+
148+instance (MimeUnrender ct a, ReflectMethod method, cts' ~ (ct ': cts), SupportsServantReflex t m, Applicative f
149+ ) => EndpointR t m (Verb method status cts' a) f (tag :: *) where
150+ type EndpointResult t m (Verb method status cts' a) f tag = Event t tag -> m (Event t (ReqResult tag a))
151+ type EInputs t m (Verb method status cts' a) f tag = '[]
152+ type EOutput t m (Verb method status cts' a) f tag = Either String a
153+
154+ eInputs = HNil
155+ clientEndpoint _ _ _ _ _ _ _ = undefined
156+ mkReq _ = emptyReqR . E.decodeUtf8 $ reflectMethod (Proxy @method)
157+ getResp resp = case _xhrResponse_response resp of
158+ Just (XhrResponseBody_ArrayBuffer x) -> mimeUnrender (Proxy @ct) (BL.fromStrict x)
159+
160+-- type ClientFunction t m f tag ein eout = Event t (f (tag, Tuple (HList ein))) -> m (Event t (f (tag, eout)))
161+
162+instance (SupportsServantReflex t m,
163+ ToHttpApiData a,
164+ EndpointR t m sublayout f tag,
165+ Applicative f
166+ ) => EndpointR t m (Capture capture a :> sublayout) f (tag :: *) where
167+
168+ type EndpointResult t m (Capture capture a :> sublayout) f tag =
169+ f a ->
170+ EndpointResult t m sublayout f tag
171+
172+ type EInputs t m (Capture capture a :> sublayout) f tag = a ': EInputs t m sublayout f tag
173+ type EOutput t m (Capture capture a :> sublayout) f tag = EOutput t m sublayout f tag
174+ eInputs = undefined
175+ clientEndpoint _ pM pF pTag reqs url opts vals =
176+ clientEndpoint (Proxy :: Proxy sublayout) pM pF pTag reqs' url opts
177+ where reqs' = (\v -> over (field @"reqRPathParts") (toUrlPiece v :))
178+ <$> vals
179+ <*> reqs
180+ mkReq (HCons x xs) = (\a -> over (field @"reqRPathParts") (toUrlPiece a:)) x $ mkReq @t @m @sublayout @f @tag xs
181+
182+ getResp = getResp @t @m @sublayout @f @tag
183+
184+
185+instance (SupportsServantReflex t m,
186+ KnownSymbol sym,
187+ EndpointR t m sublayout f tag,
188+ Applicative f
189+ ) => EndpointR t m (sym :> sublayout) f (tag :: *) where
190+
191+ type EndpointResult t m (sym :> sublayout) f tag =
192+ EndpointResult t m sublayout f tag
193+
194+ type EInputs t m (sym :> sublayout) f tag = EInputs t m sublayout f tag
195+ type EOutput t m (sym :> sublayout) f tag = EOutput t m sublayout f tag
196+ clientEndpoint _ pM pF pTag reqs url opts =
197+ clientEndpoint (Proxy :: Proxy sublayout) pM pF pTag reqs' url opts
198+ where reqs' = (over (field @"reqRPathParts") (T.pack (symbolVal (Proxy @sym)) :))
199+ <$> reqs
200+ mkReq r = over (field @"reqRPathParts") (T.pack (symbolVal (Proxy @sym)) :) $ mkReq @t @m @sublayout @f @tag r
201+
202+ getResp = getResp @t @m @sublayout @f @tag
203+instance (SupportsServantReflex t m,
204+ ToHttpApiData a,
205+ EndpointR t m sublayout f tag,
206+ KnownSymbol sym,
207+ Applicative f
208+ ) => EndpointR t m (QueryParam sym a :> sublayout) f (tag :: *) where
209+
210+ type EndpointResult t m (QueryParam sym a :> sublayout) f tag =
211+ f a ->
212+ EndpointResult t m sublayout f tag
213+
214+ type EInputs t m (QueryParam sym a :> sublayout) f tag = Maybe a ': EInputs t m sublayout f tag
215+ type EOutput t m (QueryParam sym a :> sublayout) f tag = EOutput t m sublayout f tag
216+ clientEndpoint _ pM pF pTag reqs url opts vals = undefined -- TODO
217+ -- clientEndpoint (Proxy :: Proxy sublayout) pM pF pTag reqs' url opts
218+ -- where reqs' = (\v -> over (field @"reqRPathParts") (toUrlPiece v :))
219+ -- <$> vals
220+ -- <*> reqs
221+ mkReq (HCons x xs) = over (field @"reqRParams") ((T.pack $ symbolVal (Proxy @sym),
222+ QueryPartParam $ fmap (toQueryParam) x) : ) $
223+ mkReq @t @m @sublayout @f @tag xs
224+
225+
226+ getResp = getResp @t @m @sublayout @f @tag
227+
228+instance (SupportsServantReflex t m,
229+ ToHttpApiData a,
230+ EndpointR t m sublayout f tag,
231+ KnownSymbol sym,
232+ Applicative f
233+ ) => EndpointR t m (QueryParams sym a :> sublayout) f (tag :: *) where
234+
235+ type EndpointResult t m (QueryParams sym a :> sublayout) f tag =
236+ f a ->
237+ EndpointResult t m sublayout f tag
238+
239+ type EInputs t m (QueryParams sym a :> sublayout) f tag = [a] ': EInputs t m sublayout f tag
240+ type EOutput t m (QueryParams sym a :> sublayout) f tag = EOutput t m sublayout f tag
241+ eInputs = undefined
242+ clientEndpoint _ pM pF pTag reqs url opts vals = undefined -- TODO
243+ mkReq (HCons x xs) =
244+ let newParams = (T.pack (symbolVal (Proxy @sym)), QueryPartParams (toQueryParam <$> x))
245+ in over (field @"reqRParams") (newParams :) $ mkReq @t @m @sublayout @f @tag xs
246+
247+ getResp = getResp @t @m @sublayout @f @tag
248+
249+instance (SupportsServantReflex t m,
250+ EndpointR t m sublayout f tag,
251+ KnownSymbol sym,
252+ Applicative f
253+ ) => EndpointR t m (QueryFlag sym :> sublayout) f (tag :: *) where
254+
255+ type EndpointResult t m (QueryFlag sym :> sublayout) f tag =
256+ f Bool ->
257+ EndpointResult t m sublayout f tag
258+
259+ type EInputs t m (QueryFlag sym :> sublayout) f tag = Bool ': EInputs t m sublayout f tag
260+ type EOutput t m (QueryFlag sym :> sublayout) f tag = EOutput t m sublayout f tag
261+
262+ mkReq (HCons x xs) =
263+ let newParam = (T.pack (symbolVal (Proxy @sym)), QueryPartFlag x)
264+ in over (field @"reqRParams") (newParam :) $ mkReq @t @m @sublayout @f @tag xs
265+
266+ getResp = getResp @t @m @sublayout @f @tag
267+
268+instance (SupportsServantReflex t m,
269+ EndpointR t m sublayout f tag,
270+ MimeRender ct a,
271+ Applicative f
272+ ) => EndpointR t m (ReqBody (ct ': cts) a :> sublayout) f (tag :: *) where
273+
274+ type EndpointResult t m ( ReqBody (ct ': cts) a :> sublayout) f tag =
275+ f Bool ->
276+ EndpointResult t m sublayout f tag
277+
278+ type EInputs t m (ReqBody (ct ': cts) a :> sublayout) f tag = a ': EInputs t m sublayout f tag
279+ type EOutput t m (ReqBody (ct ': cts) a :> sublayout) f tag = EOutput t m sublayout f tag
280+
281+ mkReq (HCons x xs) =
282+ set (field @"reqRBody") (Just (mimeRender (Proxy @ct) x, T.pack (show (contentType (Proxy @ct))))) $ mkReq @t @m @sublayout @f @tag xs
283+
284+ getResp = getResp @t @m @sublayout @f @tag
285+
286+instance (SupportsServantReflex t m,
287+ EndpointR t m sublayout f tag,
288+ Applicative f
289+ ) => EndpointR t m (BasicAuth realm usr :> sublayout) f (tag :: *) where
290+
291+ type EndpointResult t m ( BasicAuth realm usr :> sublayout) f tag =
292+ f Bool ->
293+ EndpointResult t m sublayout f tag
294+
295+ type EInputs t m (BasicAuth realm usr :> sublayout) f tag = BasicAuthData ': EInputs t m sublayout f tag
296+ type EOutput t m (BasicAuth realm usr :> sublayout) f tag = EOutput t m sublayout f tag
297+
298+ mkReq (HCons x xs) =
299+ set (field @"reqRAuthData") (Just x) $ mkReq @t @m @sublayout @f @tag xs
300+
301+ getResp = getResp @t @m @sublayout @f @tag
302+
303+
304+instance ToTuple (HList '[]) where
305+ type Tuple (HList '[]) = ()
306+ toTuple _ = ()
307+ fromTuple _ = HNil
308+
309+instance ToTuple (HList '[a]) where
310+ type Tuple (HList '[a]) = a
311+ toTuple (HCons a HNil) = a
312+ fromTuple a = HCons a HNil
313+
314+instance ToTuple (HList '[a,b]) where
315+ type Tuple (HList '[a,b]) = (a,b)
316+ toTuple (HCons a (HCons b HNil)) = (a,b)
317+ fromTuple (a,b) = HCons a (HCons b HNil)
318+
319+instance ToTuple (HList '[a,b,c]) where
320+ type Tuple (HList '[a,b,c]) = (a,b,c)
321+ toTuple (HCons a (HCons b (HCons c HNil))) = (a,b,c)
322+ fromTuple (a,b,c) = HCons a (HCons b (HCons c HNil))
323+
324+type MyAPI = Capture "hello" Int :> Capture "hello2" Bool :> Get '[JSON] Int
325+ :<|> Get '[JSON] Bool
326+
327+
328+m :: forall t m.MonadWidget t m => m ()
329+m = do
330+ let (a :<|> b) = clientR (Proxy @(MyAPI)) (Proxy :: Proxy m) (Proxy :: Proxy t)
331+ (Proxy @[]) (Proxy @Integer) undefined
332+ btn <- button "Hello"
333+ resA <- a (fmap (:[]) ((5,True) <$ btn))
334+ resB <- b (fmap (:[]) (() <$ btn))
335+ display =<< holdDyn "waiting" (leftmost [show <$> resA, show <$> resB])
336+ return ()
337+
338+data ReqR = ReqR
339+ { reqRMethod :: T.Text
340+ , reqRPathParts :: [T.Text]
341+ , reqRParams :: [(T.Text, QueryPart)]
342+ , reqRBody :: Maybe (BL.ByteString, T.Text)
343+ , reqRHeaders :: [(T.Text, T.Text)]
344+ , reqRRespHeaders :: XhrResponseHeaders
345+ , reqRAuthData :: Maybe BasicAuthData
346+ } deriving (Generic)
347+
348+emptyReqR :: T.Text -> ReqR
349+emptyReqR method = ReqR method [] [] Nothing [] (OnlyHeaders mempty) Nothing
350+
351+data QueryPart = QueryPartParam (Maybe Text)
352+ | QueryPartParams [Text]
353+ | QueryPartFlag Bool
354+
355+mkXhrRequest :: BaseUrl -> ReqR -> XhrRequest T.Text
356+mkXhrRequest reqHost req =
357+ let path = T.intercalate "/" $ reqRPathParts req
358+
359+ queryPartString :: (Text, QueryPart) -> Maybe Text
360+ queryPartString (pName, qp) = case qp of
361+
362+ QueryPartParam Nothing -> Nothing
363+ QueryPartParam (Just a) -> Just (pName <> "=" <> escape a)
364+
365+ QueryPartParams ps -> Just . T.intercalate "&"
366+ $ fmap (\p -> pName <> "=" <> escape p)
367+ ps
368+
369+ QueryPartFlag True -> Just pName
370+ QueryPartFlag False -> Nothing
371+
372+ (</>) :: Text -> Text -> Text
373+ x </> y | ("/" `T.isSuffixOf` x) || ("/" `T.isPrefixOf` y) = x <> y
374+ | otherwise = x <> "/" <> y
375+
376+ queryString = T.intercalate "&" . catMaybes . map queryPartString $ reqRParams req
377+ url = showBaseUrl reqHost </> path <> if T.null queryString then "" else (T.cons '?' queryString)
378+
379+ xhrHeaders = [] -- TODO
380+
381+ xhrReqConfig = def
382+ { _xhrRequestConfig_headers = M.fromList xhrHeaders
383+ , _xhrRequestConfig_user = E.decodeUtf8 . basicAuthUsername <$> reqRAuthData req
384+ , _xhrRequestConfig_password = E.decodeUtf8 . basicAuthPassword <$> reqRAuthData req
385+ , _xhrRequestConfig_responseType = Just XhrResponseType_ArrayBuffer
386+ , _xhrRequestConfig_sendData = "" -- TODO
387+ , _xhrRequestConfig_withCredentials = False
388+ }
389+ xhrReq = XhrRequest (reqRMethod req) url xhrReqConfig
390+ in xhrReq