@@ -1,282 +0,0 @@
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, JsonDecodeError, 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 FromResponse Json where
229− fromResponse resp = map (Just <<< foreignToJson) (Response.json resp)
230−
231−instance DecodeJson x => FromResponse (Array x) where
232− fromResponse resp = do
233− fromResponse resp <#> case _ of
234− Nothing -> Nothing
235− Just json ->
236− case decodeJson json of
237− Right x -> Just x
238− Left _ -> Nothing
239−
240−instance DecodeJson (Record row) => FromResponse (Record row) where
241− fromResponse resp = do
242− fromResponse resp <#> case _ of
243− Nothing -> Nothing
244− Just json ->
245− case decodeJson json of
246− Right x -> Just x
247− Left _ -> Nothing
248−
249−instance FromResponse Unit where
250− fromResponse _ = pure $ Just unit
251−
252−instance FromResponse String where
253− fromResponse = map Just <<< Response.text
254−
255−instance FromResponse ArrayBuffer where
256− fromResponse = map Just <<< Response.arrayBuffer
257−
258−class EzFetchMethod :: HttpMethod -> Constraint
259−class EzFetchMethod meth where
260− ezFetchMethod :: Method
261−
262−instance EzFetchMethod (GET req resp) where
263− ezFetchMethod = GET
264−
265−instance EzFetchMethod (POST req resp) where
266− ezFetchMethod = POST
267−
268−instance EzFetchMethod (PATCH req resp) where
269− ezFetchMethod = PATCH
270−
271−instance EzFetchMethod (PUT req resp) where
272− ezFetchMethod = PUT
273−
274−instance EzFetchMethod (DELETE req resp) where
275− ezFetchMethod = DELETE
276−
277−jsonToForeign :: Json -> Foreign
278−jsonToForeign = unsafeCoerce
279−
280−foreignToJson :: Foreign -> Json
281−foreignToJson = unsafeCoerce
282−