@@ -0,0 +1,268 @@
1+module PureStack.Client
2+ ( module PureStack.Route
3+ , client
4+ -------------------------------------------------------------------------------------------------
5+ , class ClientAPI
6+ , clientAPI
7+ , class ClientRoute
8+ , clientRoute
9+ , class EzFetchMethod
10+ , ezFetchMethod
11+ , class ToRequest
12+ , toRequest
13+ , class FromResponse
14+ , fromResponse
15+ , class ToPathPiece
16+ , toPathPiece
17+ , class ClientQuery
18+ , clientQuery
19+ ) where
20+
21+import Prelude
22+import PureStack.Route
23+
24+import Control.Alternative (class Alternative, empty)
25+import Data.Argonaut (class DecodeJson, class EncodeJson, Json, decodeJson, encodeJson)
26+import Data.ArrayBuffer.Types (ArrayBuffer)
27+import Data.Either (Either(..))
28+import Data.Map as Map
29+import Data.Maybe (Maybe(..))
30+import Data.Symbol (class IsSymbol, reflectSymbol)
31+import Data.Tuple.Nested ((/\))
32+import Data.URL (URL, addQuery)
33+import Data.URL as URL
34+import Effect.Aff (Aff)
35+import Effect.Aff.Class (class MonadAff, liftAff)
36+import Effect.Aff.HTTP (Method(..), OptionalFields, fetch)
37+import Effect.Aff.HTTP.Header as Response
38+import Effect.Aff.HTTP.Request (Body(..), Credentials(..))
39+import Effect.Aff.HTTP.Request as HTTP
40+import Effect.Aff.HTTP.Response (Response)
41+import Effect.Aff.HTTP.Response as Response
42+import Foreign (Foreign)
43+import Prim.Row as Row
44+import Prim.RowList (class RowToList, RowList)
45+import Prim.RowList as RowList
46+import Record as Record
47+import Record.Builder (Builder)
48+import Record.Builder as Builder
49+import Type.Prelude (Proxy(..))
50+import Unsafe.Coerce (unsafeCoerce)
51+
52+class ClientAPI :: forall k. Row k -> RowList k -> Row Type -> Constraint
53+class ClientAPI row list req | row -> req, list -> row where
54+ clientAPI :: URL -> Builder (Record ()) (Record req)
55+
56+instance ClientAPI () RowList.Nil () where
57+ clientAPI _ = identity
58+
59+instance
60+ ( ClientRoute route req
61+ , Row.Cons field route tail row
62+ , Row.Cons field req reqTail reqs
63+ , ClientAPI tail rest reqTail
64+ , Row.Lacks field reqTail
65+ , IsSymbol field
66+ ) =>
67+ ClientAPI row (RowList.Cons field route rest) reqs where
68+ clientAPI baseUrl =
69+ clientAPI @tail @rest baseUrl >>> Builder.insert (Proxy @field) (clientRoute @route @req baseUrl)
70+
71+client :: forall @row rowList reqs. RowToList row rowList => ClientAPI row rowList reqs => URL -> Record reqs
72+client baseUrl = Builder.buildFromScratch (clientAPI @row @rowList baseUrl)
73+
74+class ClientRoute :: forall k. k -> Type -> Constraint
75+class ClientRoute route request | route -> request where
76+ clientRoute :: URL -> request
77+
78+instance (IsSymbol path, ClientRoute rest req) => ClientRoute (path / rest) req where
79+ clientRoute = \baseUrl -> clientRoute @rest (baseUrl `URL.addSegment` reflectSymbol (Proxy @path))
80+
81+else instance (ClientRoute rest req, ClientQuery row rowList, RowToList row rowList) => ClientRoute (Record row / rest) (Record row -> req) where
82+ clientRoute = \baseUrl rec -> clientRoute @rest (clientQuery @row @rowList rec baseUrl)
83+
84+else instance ClientRoute rest req => ClientRoute (Middleware middleware / rest) req where
85+ clientRoute = clientRoute @rest
86+
87+else instance (ToPathPiece t, ClientRoute rest req) => ClientRoute (t / rest) (t -> req) where
88+ clientRoute = \baseUrl t -> clientRoute @rest (baseUrl `URL.addSegment` toPathPiece t)
89+
90+else instance
91+ ( MethodName (meth req resp)
92+ , EzFetchMethod (meth req resp)
93+ , FromResponse resp
94+ ) =>
95+ ClientRoute (meth Unit (Headers headers resp)) (Aff resp) where
96+ clientRoute = \baseUrl -> do
97+ fetch (ezFetchMethod @(meth req resp)) baseUrl (toRequest unit)
98+ >>= (liftAff <<< fromResponse)
99+ >>= case _ of
100+ Nothing -> empty
101+ Just x -> pure x
102+
103+else instance
104+ ( MethodName (meth req resp)
105+ , EzFetchMethod (meth req resp)
106+ , ToRequest req
107+ , FromResponse resp
108+ ) =>
109+ ClientRoute (meth req (Headers headers resp)) (req -> Aff resp) where
110+ clientRoute = \baseUrl req -> do
111+ fetch (ezFetchMethod @(meth req resp)) baseUrl (toRequest req)
112+ >>= (liftAff <<< fromResponse)
113+ >>= case _ of
114+ Nothing -> empty
115+ Just x -> pure x
116+
117+else instance
118+ ( MethodName (meth req resp)
119+ , EzFetchMethod (meth req resp)
120+ , FromResponse resp
121+ ) =>
122+ ClientRoute (meth Unit resp) (Aff resp) where
123+ clientRoute = \baseUrl -> do
124+ fetch (ezFetchMethod @(meth req resp)) baseUrl (toRequest unit)
125+ >>= (liftAff <<< fromResponse)
126+ >>= case _ of
127+ Nothing -> empty
128+ Just x -> pure x
129+
130+else instance
131+ ( MethodName (meth req resp)
132+ , EzFetchMethod (meth req resp)
133+ , ToRequest req
134+ , FromResponse resp
135+ ) =>
136+ ClientRoute (meth req resp) (req -> Aff resp) where
137+ clientRoute = \baseUrl req -> do
138+ fetch (ezFetchMethod @(meth req resp)) baseUrl (toRequest req)
139+ >>= (liftAff <<< fromResponse)
140+ >>= case _ of
141+ Nothing -> empty
142+ Just x -> pure x
143+else instance (ClientAPI routes routesList req, RowToList routes routesList) => ClientRoute routes (Record req) where
144+ clientRoute baseUrl = Builder.buildFromScratch $ clientAPI @routes @routesList baseUrl
145+
146+class ClientQuery :: Row Type -> RowList Type -> Constraint
147+class ClientQuery row list where
148+ clientQuery :: Record row -> URL -> URL
149+
150+instance ClientQuery row RowList.Nil where
151+ clientQuery _ url = url
152+
153+instance
154+ ( ClientQuery row rest
155+ , ToPathPiece t
156+ , IsSymbol field
157+ , Row.Cons field (Array t) tail row
158+ ) =>
159+ ClientQuery row (RowList.Cons field (Array t) rest) where
160+ clientQuery rec =
161+ flip addQuery ((reflectSymbol (Proxy @field)) /\ map toPathPiece (Record.get (Proxy @field) rec))
162+ <<< clientQuery @row @rest rec
163+else instance
164+ ( ClientQuery row rest
165+ , ToPathPiece t
166+ , IsSymbol field
167+ , Row.Cons field (Maybe t) tail row
168+ ) =>
169+ ClientQuery row (RowList.Cons field (Maybe t) rest) where
170+ clientQuery rec = case (Record.get (Proxy @field) rec) of
171+ Just x ->
172+ flip addQuery ((reflectSymbol (Proxy @field)) /\ toPathPiece x)
173+ <<< clientQuery @row @rest rec
174+ Nothing -> identity
175+else instance
176+ ( ClientQuery row rest
177+ , ToPathPiece t
178+ , IsSymbol field
179+ , Row.Cons field t tail row
180+ ) =>
181+ ClientQuery row (RowList.Cons field t rest) where
182+ clientQuery rec =
183+ flip addQuery ((reflectSymbol (Proxy @field)) /\ toPathPiece (Record.get (Proxy @field) rec))
184+ <<< clientQuery @row @rest rec
185+
186+class ToPathPiece t where
187+ toPathPiece :: t -> String
188+
189+instance ToPathPiece String where
190+ toPathPiece s = s
191+
192+instance ToPathPiece Int where
193+ toPathPiece = show
194+
195+instance ToPathPiece Number where
196+ toPathPiece = show
197+
198+instance ToPathPiece Boolean where
199+ toPathPiece = show
200+
201+class ToRequest r where
202+ toRequest :: r -> Record OptionalFields
203+
204+instance ToRequest Body where
205+ toRequest body = { body, credentials: IncludeCredentials, headers: mempty }
206+
207+instance EncodeJson (Record row) => ToRequest (Record row) where
208+ toRequest body = { body: HTTP.json (jsonToForeign $ encodeJson body), credentials: IncludeCredentials, headers: mempty }
209+
210+instance ToRequest Unit where
211+ toRequest _ = { body: BodyEmpty, credentials: IncludeCredentials, headers: mempty }
212+
213+instance (ToRequest req, RowToList headers headersList, ToHeaders headers headersList) => ToRequest (Headers (Record headers) req) where
214+ toRequest (Headers headers req) =
215+ let
216+ request = toRequest req
217+ in
218+ request
219+ { headers =
220+ Response.Headers (Map.fromFoldableWithIndex $ toHeaders @headers @headersList headers)
221+ <> request.headers
222+
223+ }
224+
225+class FromResponse r where
226+ fromResponse :: Response -> Aff (Maybe r)
227+
228+instance DecodeJson (Record row) => FromResponse (Record row) where
229+ fromResponse resp = do
230+ json <- map foreignToJson (Response.json resp)
231+ pure $ case decodeJson json of
232+ Right x -> Just x
233+ Left _ -> Nothing
234+
235+instance FromResponse Unit where
236+ fromResponse _ = pure $ Just unit
237+
238+instance FromResponse String where
239+ fromResponse = map Just <<< Response.text
240+
241+instance FromResponse ArrayBuffer where
242+ fromResponse = map Just <<< Response.arrayBuffer
243+
244+class EzFetchMethod :: HttpMethod -> Constraint
245+class EzFetchMethod meth where
246+ ezFetchMethod :: Method
247+
248+instance EzFetchMethod (GET req resp) where
249+ ezFetchMethod = GET
250+
251+instance EzFetchMethod (POST req resp) where
252+ ezFetchMethod = POST
253+
254+instance EzFetchMethod (PATCH req resp) where
255+ ezFetchMethod = PATCH
256+
257+instance EzFetchMethod (PUT req resp) where
258+ ezFetchMethod = PUT
259+
260+instance EzFetchMethod (DELETE req resp) where
261+ ezFetchMethod = DELETE
262+
263+jsonToForeign :: Json -> Foreign
264+jsonToForeign = unsafeCoerce
265+
266+foreignToJson :: Foreign -> Json
267+foreignToJson = unsafeCoerce
268+