REST.purs 14.4 KB
Newer Older
1
module Gargantext.Config.REST where
2

3
import Affjax.Web (Error(..), defaultRequest, request)
4
import Affjax as Affjax
5
import Affjax.RequestBody (formData, formURLEncoded, string)
6
import Affjax.RequestHeader as ARH
Sudhir Kumar's avatar
Sudhir Kumar committed
7
import Affjax.ResponseFormat as ResponseFormat
8
import Affjax.StatusCode (StatusCode(..))
9
import Data.Argonaut.Core as AC
10
import Data.Either (Either(..))
11 12
import Data.Foldable (foldMap)
import Data.FormURLEncoded as FormURLEncoded
13
import Data.Generic.Rep (class Generic)
Sudhir Kumar's avatar
Sudhir Kumar committed
14
import Data.HTTP.Method (Method(..))
15
import Data.Maybe (Maybe(..))
16
import Data.MediaType.Common (applicationFormURLEncoded, applicationJSON, multipartFormData)
17
import Data.Show.Generic (genericShow)
18
import Data.Tuple (Tuple)
19
import Data.Tuple.Nested ((/\))
20
import Effect (Effect)
21
import Effect.Aff (Aff)
22
import Effect.Class (liftEffect)
23
import Foreign as Foreign
24 25
import Gargantext.Prelude
import Gargantext.Utils.Reactix as R2
26
import Simple.JSON as JSON
27
import Web.XHR.FormData as XHRFormData
28

29 30 31
here :: R2.Here
here = R2.here "Gargantext.Config.REST"

32 33
type Token = String

34
data RESTError =
35
    CustomError        String
36
  | FE                 FrontendError
37 38 39 40
  | ReadJSONError      Foreign.MultipleErrors
  | SendResponseError  Affjax.Error
  | ServerError        String
  | UnknownServerError String
41
derive instance Generic RESTError _
42
instance Show RESTError where
43
  show (CustomError       s) = "CustomError " <> s
44
  show (FE                e) = show e
45
  show (ReadJSONError     e) = "ReadJSONError " <> show e
46 47
  show (SendResponseError e) = "SendResponseError " <> showError e
    where
48
      showError (ResponseBodyError fe _) = "(ResponseBodyError " <> show fe <> " (rf)"  -- <> show rf <> ")"
49 50 51 52 53 54
      showError (RequestContentError e') = "(RequestContentError " <> show e' <> ")"
      showError (RequestFailedError)     = "(RequestFailedError)"
      showError (TimeoutError)           = "(TimeoutError)"
      showError (XHROtherError e')       = "(XHROtherError " <> show e' <> ")"
  show (ServerError        e) = "ServerError: " <> e
  show (UnknownServerError e) = "UnknownServerError: " <> e
55 56 57 58
instance Eq RESTError where
  -- this is crude but we need it only because of useLoader
  eq _ _ = false

59

60 61 62
type AffRESTError a = Aff (Either RESTError a)


63 64 65 66 67 68 69 70 71 72 73 74 75
data FrontendError =
    EC_400__node_creation_failed_insert_node { user_id :: Int
                                             , parent_id :: Int }
  | EC_400__node_creation_failed_no_parent { user_id :: Int }
  | EC_400__node_creation_failed_parent_exists { parent_id :: Int
                                               , user_id :: Int }
  | EC_400__node_creation_failed_user_negative_id { user_id :: Int }
  | EC_400__node_lookup_failed_user_too_many_roots { user_id :: Int
                                                   , roots :: Array Int }
  | EC_400__node_needs_configuration
  | EC_403__login_failed_error { node_id :: Int
                               , user_id :: Int }
  | EC_403__login_failed_invalid_username_or_password
76 77
  | EC_403__user_not_authorized { user_id :: Int
                                , msg     :: String }
78 79 80 81 82 83 84 85 86 87
  | EC_404__node_context_not_found { context_id :: Int }
  | EC_404__node_lookup_failed_not_found { node_id :: Int }
  | EC_404__node_lookup_failed_parent_not_found { node_id :: Int }
  | EC_404__node_lookup_failed_username_not_found { username :: String }
  | EC_404__node_list_not_found { list_id :: Int }
  | EC_404__node_root_not_found
  | EC_500__node_generic_exception { error :: String }
  | EC_500__node_not_implemented_yet
derive instance Generic FrontendError _
instance Show FrontendError where
88 89 90 91 92 93 94 95 96 97 98 99 100 101 102
  show (EC_400__node_creation_failed_insert_node { user_id, parent_id }) =
    "Failed to insert node for user " <> show user_id <> ", parent " <> show parent_id
  show (EC_400__node_creation_failed_no_parent { user_id }) =
    "Failed to insert node for user " <> show user_id <> ": no parent"
  show (EC_400__node_creation_failed_parent_exists { user_id, parent_id }) =
    "Failed to insert node for user " <> show user_id <> ", parent " <> show parent_id <> " exists"
  show (EC_400__node_creation_failed_user_negative_id { user_id }) =
    "Failed to insert node for use " <> show user_id <> " (negative user_id)"
  show (EC_400__node_lookup_failed_user_too_many_roots { user_id, roots }) =
    "Failed to lookup node for user " <> show user_id <> ": too many roots (" <> show roots <> ")"
  show EC_400__node_needs_configuration = "Node needs configuration"
  show (EC_403__login_failed_error { node_id, user_id }) =
    "Login failed for node_id " <> show node_id <> ", user id " <> show user_id
  show EC_403__login_failed_invalid_username_or_password =
    "Invalid username or password"
103 104
  show (EC_403__user_not_authorized { user_id, msg }) =
    "User not authorized to perform action: " <> show user_id <> ". " <> msg
105 106 107 108 109 110 111 112 113 114 115 116 117 118
  show (EC_404__node_context_not_found { context_id }) =
    "Context not found with id " <> show context_id
  show (EC_404__node_lookup_failed_not_found { node_id }) =
    "Node not found with id " <> show node_id
  show (EC_404__node_lookup_failed_parent_not_found { node_id }) =
    "Node parent not found for id " <> show node_id
  show (EC_404__node_lookup_failed_username_not_found { username }) =
    "User '" <> username <> "' not found"
  show (EC_404__node_list_not_found { list_id }) =
    "Node list not found for id " <> show list_id
  show EC_404__node_root_not_found = "Node root not found"
  show (EC_500__node_generic_exception { error }) =
    "Node exception: " <> error
  show EC_500__node_not_implemented_yet = "Node not implemented yet"
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
instance JSON.ReadForeign FrontendError where
  readImpl f = do
    { type: type_ } <- JSON.readImpl f :: Foreign.F { type :: String }
    case type_ of
      "EC_400__node_creation_failed_insert_node" -> do
        { data: { parent_id, user_id } } <- JSON.readImpl f :: Foreign.F { data :: { parent_id :: Int
                                                                                   , user_id :: Int } }
        pure $ EC_400__node_creation_failed_insert_node { parent_id, user_id }
      "EC_400__node_creation_failed_no_parent" -> do
        { data: { user_id } } <- JSON.readImpl f :: Foreign.F { data :: { user_id :: Int } }
        pure $ EC_400__node_creation_failed_no_parent { user_id }
      "EC_400__node_creation_failed_parent_exists" -> do
        { data: { parent_id, user_id } } <- JSON.readImpl f :: Foreign.F { data :: { parent_id :: Int
                                                                                   , user_id :: Int } }
        pure $ EC_400__node_creation_failed_parent_exists { parent_id, user_id }
      "EC_400__node_creation_failed_user_negative_id" -> do
        { data: { user_id } } <- JSON.readImpl f :: Foreign.F { data :: { user_id :: Int } }
        pure $ EC_400__node_creation_failed_user_negative_id { user_id }
      "EC_400__node_lookup_failed_user_too_many_roots" -> do
        { data: { user_id, roots } } <- JSON.readImpl f :: Foreign.F { data :: { user_id :: Int
                                                                               , roots :: Array Int } }
        pure $ EC_400__node_lookup_failed_user_too_many_roots { user_id, roots }
      "EC_400__node_needs_configuration" -> do
        pure $ EC_400__node_needs_configuration
      "EC_403__login_failed_error" -> do
        { data: { node_id, user_id } } <- JSON.readImpl f :: Foreign.F { data :: { node_id :: Int
                                                                                 , user_id :: Int } }
        pure $ EC_403__login_failed_error { node_id, user_id }
      "EC_403__login_failed_invalid_username_or_password" -> do
        pure $ EC_403__login_failed_invalid_username_or_password
149 150 151 152
      "EC_403__user_not_authorized" -> do
        { data: { user_id, msg } } <- JSON.readImpl f :: Foreign.F { data :: { user_id :: Int
                                                                             , msg :: String } }
        pure $ EC_403__user_not_authorized { user_id, msg }
153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174
      "EC_404__node_context_not_found" -> do
        { data: { context_id } } <- JSON.readImpl f :: Foreign.F { data :: { context_id :: Int } }
        pure $ EC_404__node_context_not_found { context_id }
      "EC_404__node_lookup_failed_not_found" -> do
        { data: { node_id } } <- JSON.readImpl f :: Foreign.F { data :: { node_id :: Int } }
        pure $ EC_404__node_lookup_failed_not_found { node_id }
      "EC_404__node_lookup_failed_parent_not_found" -> do
        { data: { node_id } } <- JSON.readImpl f :: Foreign.F { data :: { node_id :: Int } }
        pure $ EC_404__node_lookup_failed_parent_not_found { node_id }
      "EC_404__node_lookup_failed_username_not_found" -> do
        { data: { username } } <- JSON.readImpl f :: Foreign.F { data :: { username :: String } }
        pure $ EC_404__node_lookup_failed_username_not_found { username }
      "EC_404__node_list_not_found" -> do
        { data: { list_id } } <- JSON.readImpl f :: Foreign.F { data :: { list_id :: Int } }
        pure $ EC_404__node_list_not_found { list_id }
      "EC_404__node_root_not_found" -> do
        pure $ EC_404__node_root_not_found
      "EC_500__node_generic_exception" -> do
        { data: { error } } <- JSON.readImpl f :: Foreign.F { data :: { error :: String } }
        pure $ EC_500__node_generic_exception { error }
      "EC_500__node_not_implemented_yet" -> do
        pure $ EC_500__node_not_implemented_yet
175 176
      _ -> do
        Foreign.fail $ Foreign.ForeignError $ "deserialization for '" <> type_ <> "' not implemented"
177

178 179 180

logRESTError :: R2.HerePrefix -> RESTError -> Effect Unit
logRESTError (R2.HerePrefix { here: here', prefix }) e = here'.warn2 (prefix <> " " <> show e) e
181 182 183
-- 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
184

185

186 187
readJSON :: forall a. JSON.ReadForeign a
         => Either Affjax.Error (Affjax.Response AC.Json)
188
         -> Either RESTError a
189
readJSON affResp =
190 191
  case affResp of
    Left err -> do
192 193 194
      -- _ <- liftEffect $ log $ printError err
      --throwError $ error $ printError err
      Left $ SendResponseError err
195 196 197 198
    Right resp -> do
      --_ <-  liftEffect $ log json.status
      --_ <-  liftEffect $ log json.headers
      --_ <-  liftEffect $ log json.body
199
      
200
      case resp.status of
201
        StatusCode 200 -> 
202 203 204
          case (JSON.readJSON $ AC.stringify resp.body) of
            Left err -> Left $ ReadJSONError err
            Right r -> Right r
205 206 207 208
        _ -> case (JSON.readJSON $ AC.stringify resp.body :: JSON.E FrontendError) of
          Right err -> Left $ FE err
          Left _    -> Left $ UnknownServerError $ AC.stringify resp.body

209

210
-- TODO too much duplicate code in `postWwwUrlencoded`
211
send :: forall body res. JSON.WriteForeign body => JSON.ReadForeign res =>
212
        Method -> Maybe Token -> String -> Maybe body -> AffRESTError res
213
send m mtoken url reqbody = do
214
  let req = defaultRequest
215 216 217
         { url = url
         , responseFormat = ResponseFormat.json
         , method = Left m
218 219
         , headers =  [ ARH.ContentType applicationJSON
                      , ARH.Accept applicationJSON
220
                      , ARH.RequestHeader "X-Garg-Error-Scheme" $ "new" 
221 222
                      ] <>
                      foldMap (\token ->
223
                        [ARH.RequestHeader "Authorization" $  "Bearer " <> token]
224
                      ) mtoken
225
         , content  = Just $ string $ JSON.writeJSON reqbody
226
         }
227 228 229 230 231
  case mtoken of
    Nothing -> pure unit
    Just token -> liftEffect $ do
      let cookie = "JWT-Cookie=" <> token <> "; Path=/;" --" HttpOnly; Secure; SameSite=Lax"
      R2.setCookie cookie
232
  affResp <- request req
233
  -- liftEffect $ here.log2 "[send] affResp" affResp
234
  pure $ readJSON affResp
235

236 237 238
noReqBody :: Maybe String
noReqBody = Just ""
--noReqBody = Nothing
239

240
get :: forall a. JSON.ReadForeign a => Maybe Token -> String -> AffRESTError a
241
get mtoken url = send GET mtoken url noReqBody
242

243
put :: forall a b. JSON.WriteForeign a => JSON.ReadForeign b => Maybe Token -> String -> a -> AffRESTError b
244
put mtoken url = send PUT mtoken url <<< Just
245

246
put_ :: forall a. JSON.ReadForeign a => Maybe Token -> String -> AffRESTError a
247 248
put_ mtoken url = send PUT mtoken url noReqBody

249
delete :: forall a. JSON.ReadForeign a => Maybe Token -> String -> AffRESTError a
250
delete mtoken url = send DELETE mtoken url noReqBody
251

252 253
-- This might not be a good idea:
-- https://stackoverflow.com/questions/14323716/restful-alternatives-to-delete-request-body
254
deleteWithBody :: forall a b. JSON.WriteForeign a => JSON.ReadForeign b => Maybe Token -> String -> a -> AffRESTError b
255
deleteWithBody mtoken url = send DELETE mtoken url <<< Just
256

257
post :: forall a b. JSON.WriteForeign a => JSON.ReadForeign b => Maybe Token -> String -> a -> AffRESTError b
258
post mtoken url = send POST mtoken url <<< Just
259

260 261
type FormDataParams = Array (Tuple String (Maybe String))

262
-- TODO too much duplicate code with `send`
263
postWwwUrlencoded :: forall b. JSON.ReadForeign b => Maybe Token -> String -> FormDataParams -> AffRESTError b
264
postWwwUrlencoded mtoken url bodyParams = do
265 266 267 268
  affResp <- request $ defaultRequest
             { url = url
             , responseFormat = ResponseFormat.json
             , method = Left POST
269 270
             , headers =  [ ARH.ContentType applicationFormURLEncoded
                          , ARH.Accept applicationJSON
271 272
                          ] <>
                          foldMap (\token ->
273
                            [ARH.RequestHeader "Authorization" $  "Bearer " <> token]
274
                          ) mtoken
275
             , content  = Just $ formURLEncoded urlEncodedBody
276
             }
277
  pure $ readJSON affResp
278
  where
279
    urlEncodedBody = FormURLEncoded.fromArray bodyParams
280

281
postMultipartFormData :: forall b. JSON.ReadForeign b => Maybe Token -> String -> String -> AffRESTError b
282 283 284 285 286 287 288
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
289 290
             , headers = [ ARH.ContentType multipartFormData
                         , ARH.Accept applicationJSON
291 292
                         ] <>
                         foldMap (\token ->
293
                           [ ARH.RequestHeader "Authorization" $ " " <> token ]
294 295 296
                         ) mtoken
             , content = Just $ formData fd
             }
297
  pure $ readJSON affResp