REST.purs 6.49 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 Data.Argonaut.Core as AC
9
import Data.Either (Either(..))
10 11
import Data.Foldable (foldMap)
import Data.FormURLEncoded as FormURLEncoded
12
import Data.Generic.Rep (class Generic)
Sudhir Kumar's avatar
Sudhir Kumar committed
13
import Data.HTTP.Method (Method(..))
14
import Data.Maybe (Maybe(..))
15
import Data.MediaType.Common (applicationFormURLEncoded, applicationJSON, multipartFormData)
16
import Data.Tuple (Tuple)
17
import Effect (Effect)
18
import Effect.Aff (Aff)
19
import Effect.Class (liftEffect)
20
import Foreign as Foreign
21 22
import Gargantext.Prelude
import Gargantext.Utils.Reactix as R2
23
import Simple.JSON as JSON
24
import Web.XHR.FormData as XHRFormData
25

26 27
type Token = String

28 29 30
data RESTError =
    SendResponseError Affjax.Error
  | ReadJSONError     Foreign.MultipleErrors
31
  | CustomError       String
32
derive instance Generic RESTError _
33 34 35
instance Show RESTError where
  show (SendResponseError e) = "SendResponseError " <> showError e
    where
36
      showError (RequestContentError e')  = "(RequestContentError " <> show e' <> ")"
37
      showError (ResponseBodyError fe _) = "(ResponseBodyError " <> show fe <> " (rf)"  -- <> show rf <> ")"
38 39 40 41 42
      showError (TimeoutError)            = "(TimeoutError)"
      showError (RequestFailedError)      = "(RequestFailedError)"
      showError (XHROtherError e')        = "(XHROtherError " <> show e' <> ")"
  show (ReadJSONError     e)              = "ReadJSONError " <> show e
  show (CustomError       s)              = "CustomError " <> s
43 44 45 46
instance Eq RESTError where
  -- this is crude but we need it only because of useLoader
  eq _ _ = false

47
logRESTError :: R2.Here -> String -> RESTError -> Effect Unit
48 49 50 51
logRESTError here prefix e = here.warn2 (prefix <> " " <> show e) e
-- 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
52

53 54
type AffRESTError a = Aff (Either RESTError a)

55

56 57 58 59 60 61
readJSON :: forall a b. JSON.ReadForeign a =>
            Either Affjax.Error
            { body :: AC.Json
            | b
            } -> Either RESTError a
readJSON affResp =
62 63
  case affResp of
    Left err -> do
64 65 66
      -- _ <- liftEffect $ log $ printError err
      --throwError $ error $ printError err
      Left $ SendResponseError err
67 68 69 70
    Right resp -> do
      --_ <-  liftEffect $ log json.status
      --_ <-  liftEffect $ log json.headers
      --_ <-  liftEffect $ log json.body
71 72 73
      case (JSON.readJSON $ AC.stringify resp.body) of
        Left err -> Left $ ReadJSONError err
        Right r -> Right r
74

75
-- TODO too much duplicate code in `postWwwUrlencoded`
76
send :: forall body res. JSON.WriteForeign body => JSON.ReadForeign res =>
77
        Method -> Maybe Token -> String -> Maybe body -> AffRESTError res
78
send m mtoken url reqbody = do
79
  let req = defaultRequest
80 81 82
         { url = url
         , responseFormat = ResponseFormat.json
         , method = Left m
83 84
         , headers =  [ ARH.ContentType applicationJSON
                      , ARH.Accept applicationJSON
85 86
                      ] <>
                      foldMap (\token ->
87
                        [ARH.RequestHeader "Authorization" $  "Bearer " <> token]
88
                      ) mtoken
89
         , content  = Just $ string $ JSON.writeJSON reqbody
90
         }
91 92 93 94 95
  case mtoken of
    Nothing -> pure unit
    Just token -> liftEffect $ do
      let cookie = "JWT-Cookie=" <> token <> "; Path=/;" --" HttpOnly; Secure; SameSite=Lax"
      R2.setCookie cookie
96
  affResp <- request req
97
  pure $ readJSON affResp
98

99 100 101
noReqBody :: Maybe String
noReqBody = Just ""
--noReqBody = Nothing
102

103
get :: forall a. JSON.ReadForeign a => Maybe Token -> String -> AffRESTError a
104
get mtoken url = send GET mtoken url noReqBody
105

106
put :: forall a b. JSON.WriteForeign a => JSON.ReadForeign b => Maybe Token -> String -> a -> AffRESTError b
107
put mtoken url = send PUT mtoken url <<< Just
108

109
put_ :: forall a. JSON.ReadForeign a => Maybe Token -> String -> AffRESTError a
110 111
put_ mtoken url = send PUT mtoken url noReqBody

112
delete :: forall a. JSON.ReadForeign a => Maybe Token -> String -> AffRESTError a
113
delete mtoken url = send DELETE mtoken url noReqBody
114

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

120
post :: forall a b. JSON.WriteForeign a => JSON.ReadForeign b => Maybe Token -> String -> a -> AffRESTError b
121
post mtoken url = send POST mtoken url <<< Just
122

123 124
type FormDataParams = Array (Tuple String (Maybe String))

125
-- TODO too much duplicate code with `send`
126
postWwwUrlencoded :: forall b. JSON.ReadForeign b => Maybe Token -> String -> FormDataParams -> AffRESTError b
127
postWwwUrlencoded mtoken url bodyParams = do
128 129 130 131
  affResp <- request $ defaultRequest
             { url = url
             , responseFormat = ResponseFormat.json
             , method = Left POST
132 133
             , headers =  [ ARH.ContentType applicationFormURLEncoded
                          , ARH.Accept applicationJSON
134 135
                          ] <>
                          foldMap (\token ->
136
                            [ARH.RequestHeader "Authorization" $  "Bearer " <> token]
137
                          ) mtoken
138
             , content  = Just $ formURLEncoded urlEncodedBody
139
             }
140
  pure $ readJSON affResp
141
  where
142
    urlEncodedBody = FormURLEncoded.fromArray bodyParams
143

144
postMultipartFormData :: forall b. JSON.ReadForeign b => Maybe Token -> String -> String -> AffRESTError b
145 146 147 148 149 150 151
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
152 153
             , headers = [ ARH.ContentType multipartFormData
                         , ARH.Accept applicationJSON
154 155
                         ] <>
                         foldMap (\token ->
156
                           [ ARH.RequestHeader "Authorization" $ " " <> token ]
157 158 159
                         ) mtoken
             , content = Just $ formData fd
             }
160
  pure $ readJSON affResp