1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
module Gargantext.Config.REST where
import Affjax.Web (Error(..), defaultRequest, request)
import Affjax as Affjax
import Affjax.RequestBody (formData, formURLEncoded, string)
import Affjax.RequestHeader as ARH
import Affjax.ResponseFormat as ResponseFormat
import Data.Argonaut.Core as AC
import Data.Either (Either(..))
import Data.Foldable (foldMap)
import Data.FormURLEncoded as FormURLEncoded
import Data.Generic.Rep (class Generic)
import Data.HTTP.Method (Method(..))
import Data.Maybe (Maybe(..))
import Data.MediaType.Common (applicationFormURLEncoded, applicationJSON, multipartFormData)
import Data.Tuple (Tuple)
import Effect (Effect)
import Effect.Aff (Aff)
import Effect.Class (liftEffect)
import Foreign as Foreign
import Gargantext.Prelude
import Gargantext.Utils.Reactix as R2
import Simple.JSON as JSON
import Web.XHR.FormData as XHRFormData
type Token = String
data RESTError =
SendResponseError Affjax.Error
| ReadJSONError Foreign.MultipleErrors
| CustomError String
derive instance Generic RESTError _
instance Show RESTError where
show (SendResponseError e) = "SendResponseError " <> showError e
where
showError (RequestContentError e') = "(RequestContentError " <> show e' <> ")"
showError (ResponseBodyError fe _) = "(ResponseBodyError " <> show fe <> " (rf)" -- <> show rf <> ")"
showError (TimeoutError) = "(TimeoutError)"
showError (RequestFailedError) = "(RequestFailedError)"
showError (XHROtherError e') = "(XHROtherError " <> show e' <> ")"
show (ReadJSONError e) = "ReadJSONError " <> show e
show (CustomError s) = "CustomError " <> s
instance Eq RESTError where
-- this is crude but we need it only because of useLoader
eq _ _ = false
logRESTError :: R2.Here -> String -> RESTError -> Effect Unit
logRESTError here prefix (SendResponseError e) = here.warn2 (prefix <> " SendResponseError ") e -- TODO: No show
logRESTError here prefix (ReadJSONError e) = here.warn2 (prefix <> " ReadJSONError ") $ show e
logRESTError here prefix (CustomError e) = here.warn2 (prefix <> " CustomError ") $ e
type AffRESTError a = Aff (Either RESTError a)
readJSON :: forall a b. JSON.ReadForeign a =>
Either Affjax.Error
{ body :: AC.Json
| b
} -> Either RESTError a
readJSON affResp =
case affResp of
Left err -> do
-- _ <- liftEffect $ log $ printError err
--throwError $ error $ printError err
Left $ SendResponseError err
Right resp -> do
--_ <- liftEffect $ log json.status
--_ <- liftEffect $ log json.headers
--_ <- liftEffect $ log json.body
case (JSON.readJSON $ AC.stringify resp.body) of
Left err -> Left $ ReadJSONError err
Right r -> Right r
-- TODO too much duplicate code in `postWwwUrlencoded`
send :: forall body res. JSON.WriteForeign body => JSON.ReadForeign res =>
Method -> Maybe Token -> String -> Maybe body -> AffRESTError res
send m mtoken url reqbody = do
let req = defaultRequest
{ url = url
, responseFormat = ResponseFormat.json
, method = Left m
, headers = [ ARH.ContentType applicationJSON
, ARH.Accept applicationJSON
] <>
foldMap (\token ->
[ARH.RequestHeader "Authorization" $ "Bearer " <> token]
) mtoken
, content = Just $ string $ JSON.writeJSON reqbody
}
case mtoken of
Nothing -> pure unit
Just token -> liftEffect $ do
let cookie = "JWT-Cookie=" <> token <> "; Path=/;" --" HttpOnly; Secure; SameSite=Lax"
R2.setCookie cookie
affResp <- request req
pure $ readJSON affResp
noReqBody :: Maybe String
noReqBody = Just ""
--noReqBody = Nothing
get :: forall a. JSON.ReadForeign a => Maybe Token -> String -> AffRESTError a
get mtoken url = send GET mtoken url noReqBody
put :: forall a b. JSON.WriteForeign a => JSON.ReadForeign b => Maybe Token -> String -> a -> AffRESTError b
put mtoken url = send PUT mtoken url <<< Just
put_ :: forall a. JSON.ReadForeign a => Maybe Token -> String -> AffRESTError a
put_ mtoken url = send PUT mtoken url noReqBody
delete :: forall a. JSON.ReadForeign a => Maybe Token -> String -> AffRESTError a
delete mtoken url = send DELETE mtoken url noReqBody
-- This might not be a good idea:
-- https://stackoverflow.com/questions/14323716/restful-alternatives-to-delete-request-body
deleteWithBody :: forall a b. JSON.WriteForeign a => JSON.ReadForeign b => Maybe Token -> String -> a -> AffRESTError b
deleteWithBody mtoken url = send DELETE mtoken url <<< Just
post :: forall a b. JSON.WriteForeign a => JSON.ReadForeign b => Maybe Token -> String -> a -> AffRESTError b
post mtoken url = send POST mtoken url <<< Just
type FormDataParams = Array (Tuple String (Maybe String))
-- TODO too much duplicate code with `send`
postWwwUrlencoded :: forall b. JSON.ReadForeign b => Maybe Token -> String -> FormDataParams -> AffRESTError b
postWwwUrlencoded mtoken url bodyParams = do
affResp <- request $ defaultRequest
{ url = url
, responseFormat = ResponseFormat.json
, method = Left POST
, headers = [ ARH.ContentType applicationFormURLEncoded
, ARH.Accept applicationJSON
] <>
foldMap (\token ->
[ARH.RequestHeader "Authorization" $ "Bearer " <> token]
) mtoken
, content = Just $ formURLEncoded urlEncodedBody
}
pure $ readJSON affResp
where
urlEncodedBody = FormURLEncoded.fromArray bodyParams
postMultipartFormData :: forall b. JSON.ReadForeign b => Maybe Token -> String -> String -> AffRESTError b
postMultipartFormData mtoken url body = do
fd <- liftEffect $ XHRFormData.new
_ <- liftEffect $ XHRFormData.append (XHRFormData.EntryName "body") body fd
affResp <- request $ defaultRequest
{ url = url
, responseFormat = ResponseFormat.json
, method = Left POST
, headers = [ ARH.ContentType multipartFormData
, ARH.Accept applicationJSON
] <>
foldMap (\token ->
[ ARH.RequestHeader "Authorization" $ " " <> token ]
) mtoken
, content = Just $ formData fd
}
pure $ readJSON affResp