@@ -0,0 +1,244 @@
1+module Yoga.Fetch.Om.Simple
2+ ( class DecodeResponse
3+ , decodeResponse
4+ , FetchError
5+ , FetchResponse
6+ , get
7+ , getWithHeaders
8+ , delete
9+ , deleteWithHeaders
10+ , delete_
11+ , post
12+ , postWithHeaders
13+ , post_
14+ , put
15+ , putWithHeaders
16+ , put_
17+ , patch
18+ , patchWithHeaders
19+ , patch_
20+ ) where
21+
22+import Prelude
23+
24+import Data.HTTP.Method (Method(..))
25+import Data.Maybe (Maybe(..))
26+import Data.Tuple.Nested ((/\))
27+import Effect.Class (liftEffect)
28+import JS.Fetch as Fetch
29+import JS.Fetch.Duplex as Duplex
30+import JS.Fetch.Headers (Headers)
31+import JS.Fetch.Headers as Headers
32+import JS.Fetch.Integrity (Integrity(..))
33+import JS.Fetch.Referrer as Referrer
34+import JS.Fetch.ReferrerPolicy as ReferrerPolicy
35+import JS.Fetch.Request as Request
36+import JS.Fetch.RequestBody as Body
37+import JS.Fetch.RequestCache as Cache
38+import JS.Fetch.RequestCredentials as Credentials
39+import JS.Fetch.RequestMode as Mode
40+import JS.Fetch.Response as Resp
41+import Promise.Aff as Promise
42+import Type.Row.Homogeneous (class Homogeneous)
43+import Yoga.HTTP.API.Route.Encoding (PlainText)
44+import Yoga.JSON (class ReadForeign, class WriteForeign, readJSON_, writeJSON)
45+import Yoga.Om (Om, fromAff, throw)
46+
47+type FetchError = { status :: Int, body :: String }
48+
49+type FetchResponse a = { headers :: Headers, body :: a }
50+
51+class DecodeResponse :: forall k. k -> Type -> Constraint
52+class DecodeResponse a result | a -> result where
53+ decodeResponse :: String -> Maybe result
54+
55+instance DecodeResponse (PlainText String) String where
56+ decodeResponse = Just
57+
58+else instance ReadForeign a => DecodeResponse a a where
59+ decodeResponse = readJSON_
60+
61+simpleFetch
62+ :: forall @a result headers ctx err
63+ . DecodeResponse a result
64+ => Homogeneous headers String
65+ => Method
66+ -> Record headers
67+ -> String
68+ -> Maybe String
69+ -> Om ctx (fetchError :: FetchError | err) (FetchResponse result)
70+simpleFetch method headers url maybeBody = do
71+ resp <- doFetch # fromAff
72+ respText <- Promise.toAffE (Resp.text resp) # fromAff
73+ let status = Resp.status resp
74+ let respHeaders = Resp.headers resp
75+ if status >= 200 && status < 300 then
76+ case decodeResponse @a respText of
77+ Nothing -> throw { fetchError: { status, body: respText } }
78+ Just body -> pure { headers: respHeaders, body }
79+ else
80+ throw { fetchError: { status, body: respText } }
81+ where
82+ doFetch = do
83+ request <- Request.new url options # liftEffect
84+ Promise.toAffE $ Fetch.fetch request
85+ contentTypeHeaders = case maybeBody of
86+ Nothing -> Headers.empty
87+ Just _ -> Headers.fromFoldable [ "Content-Type" /\ "application/json" ]
88+ allHeaders = Headers.fromFoldable
89+ (Headers.toArray contentTypeHeaders <> Headers.toArray (Headers.fromRecord headers))
90+ reqBody = case maybeBody of
91+ Nothing -> Body.empty
92+ Just b -> Body.fromString b
93+ options =
94+ { method
95+ , headers: allHeaders
96+ , body: reqBody
97+ , credentials: Credentials.Include
98+ , mode: Mode.Cors
99+ , referrer: Referrer.ReferrerClient
100+ , referrerPolicy: ReferrerPolicy.NoReferrer
101+ , integrity: Integrity ""
102+ , duplex: Duplex.Half
103+ , cache: Cache.Default
104+ }
105+
106+get
107+ :: forall @a result headers ctx err
108+ . DecodeResponse a result
109+ => Homogeneous headers String
110+ => Record headers
111+ -> String
112+ -> Om ctx (fetchError :: FetchError | err) result
113+get headers url = _.body <$> simpleFetch @a GET headers url Nothing
114+
115+getWithHeaders
116+ :: forall @a result headers ctx err
117+ . DecodeResponse a result
118+ => Homogeneous headers String
119+ => Record headers
120+ -> String
121+ -> Om ctx (fetchError :: FetchError | err) (FetchResponse result)
122+getWithHeaders headers url = simpleFetch @a GET headers url Nothing
123+
124+delete
125+ :: forall @a result headers ctx err
126+ . DecodeResponse a result
127+ => Homogeneous headers String
128+ => Record headers
129+ -> String
130+ -> Om ctx (fetchError :: FetchError | err) result
131+delete headers url = _.body <$> simpleFetch @a DELETE headers url Nothing
132+
133+deleteWithHeaders
134+ :: forall @a result headers ctx err
135+ . DecodeResponse a result
136+ => Homogeneous headers String
137+ => Record headers
138+ -> String
139+ -> Om ctx (fetchError :: FetchError | err) (FetchResponse result)
140+deleteWithHeaders headers url = simpleFetch @a DELETE headers url Nothing
141+
142+delete_
143+ :: forall headers ctx err
144+ . Homogeneous headers String
145+ => Record headers
146+ -> String
147+ -> Om ctx (fetchError :: FetchError | err) Unit
148+delete_ headers url = void $ simpleFetch @(PlainText String) DELETE headers url Nothing
149+
150+post
151+ :: forall @a result headers body ctx err
152+ . DecodeResponse a result
153+ => Homogeneous headers String
154+ => WriteForeign body
155+ => Record headers
156+ -> String
157+ -> body
158+ -> Om ctx (fetchError :: FetchError | err) result
159+post headers url body = _.body <$> simpleFetch @a POST headers url (Just (writeJSON body))
160+
161+postWithHeaders
162+ :: forall @a result headers body ctx err
163+ . DecodeResponse a result
164+ => Homogeneous headers String
165+ => WriteForeign body
166+ => Record headers
167+ -> String
168+ -> body
169+ -> Om ctx (fetchError :: FetchError | err) (FetchResponse result)
170+postWithHeaders headers url body = simpleFetch @a POST headers url (Just (writeJSON body))
171+
172+post_
173+ :: forall headers body ctx err
174+ . Homogeneous headers String
175+ => WriteForeign body
176+ => Record headers
177+ -> String
178+ -> body
179+ -> Om ctx (fetchError :: FetchError | err) Unit
180+post_ headers url body = void $ simpleFetch @(PlainText String) POST headers url (Just (writeJSON body))
181+
182+put
183+ :: forall @a result headers body ctx err
184+ . DecodeResponse a result
185+ => Homogeneous headers String
186+ => WriteForeign body
187+ => Record headers
188+ -> String
189+ -> body
190+ -> Om ctx (fetchError :: FetchError | err) result
191+put headers url body = _.body <$> simpleFetch @a PUT headers url (Just (writeJSON body))
192+
193+putWithHeaders
194+ :: forall @a result headers body ctx err
195+ . DecodeResponse a result
196+ => Homogeneous headers String
197+ => WriteForeign body
198+ => Record headers
199+ -> String
200+ -> body
201+ -> Om ctx (fetchError :: FetchError | err) (FetchResponse result)
202+putWithHeaders headers url body = simpleFetch @a PUT headers url (Just (writeJSON body))
203+
204+put_
205+ :: forall headers body ctx err
206+ . Homogeneous headers String
207+ => WriteForeign body
208+ => Record headers
209+ -> String
210+ -> body
211+ -> Om ctx (fetchError :: FetchError | err) Unit
212+put_ headers url body = void $ simpleFetch @(PlainText String) PUT headers url (Just (writeJSON body))
213+
214+patch
215+ :: forall @a result headers body ctx err
216+ . DecodeResponse a result
217+ => Homogeneous headers String
218+ => WriteForeign body
219+ => Record headers
220+ -> String
221+ -> body
222+ -> Om ctx (fetchError :: FetchError | err) result
223+patch headers url body = _.body <$> simpleFetch @a PATCH headers url (Just (writeJSON body))
224+
225+patchWithHeaders
226+ :: forall @a result headers body ctx err
227+ . DecodeResponse a result
228+ => Homogeneous headers String
229+ => WriteForeign body
230+ => Record headers
231+ -> String
232+ -> body
233+ -> Om ctx (fetchError :: FetchError | err) (FetchResponse result)
234+patchWithHeaders headers url body = simpleFetch @a PATCH headers url (Just (writeJSON body))
235+
236+patch_
237+ :: forall headers body ctx err
238+ . Homogeneous headers String
239+ => WriteForeign body
240+ => Record headers
241+ -> String
242+ -> body
243+ -> Om ctx (fetchError :: FetchError | err) Unit
244+patch_ headers url body = void $ simpleFetch @(PlainText String) PATCH headers url (Just (writeJSON body))