|
| 1 | +module Conduit.Api.Client where |
| 2 | + |
| 3 | +import Prelude |
| 4 | +import Affjax (defaultRequest) |
| 5 | +import Affjax as Affjax |
| 6 | +import Affjax.RequestBody as RequestBody |
| 7 | +import Affjax.RequestHeader (RequestHeader(..)) |
| 8 | +import Affjax.ResponseFormat as ResponseFormat |
| 9 | +import Affjax.ResponseHeader (ResponseHeader) |
| 10 | +import Affjax.StatusCode (StatusCode(..)) |
| 11 | +import Conduit.Api.Endpoint (Endpoint, endpointCodec) |
| 12 | +import Conduit.Capability.Auth (class MonadAuth) |
| 13 | +import Conduit.Capability.Auth as Auth |
| 14 | +import Conduit.Capability.Routing (class MonadRouting) |
| 15 | +import Conduit.Capability.Routing as Routing |
| 16 | +import Conduit.Config as Config |
| 17 | +import Conduit.Data.Route (Route(..)) |
| 18 | +import Control.Monad.Except (ExceptT(..), except, runExceptT, throwError, withExceptT) |
| 19 | +import Data.Argonaut.Core as AC |
| 20 | +import Data.Argonaut.Decode (class DecodeJson, JsonDecodeError, decodeJson, printJsonDecodeError) |
| 21 | +import Data.Argonaut.Encode (class EncodeJson, encodeJson) |
| 22 | +import Data.Array as Array |
| 23 | +import Data.Bitraversable (lfor) |
| 24 | +import Data.Either (Either(..)) |
| 25 | +import Data.HTTP.Method (Method) |
| 26 | +import Data.Maybe (Maybe(..)) |
| 27 | +import Data.MediaType.Common (applicationJSON) |
| 28 | +import Effect.Aff (Aff) |
| 29 | +import Effect.Aff.Class (class MonadAff, liftAff) |
| 30 | +import Effect.Class (class MonadEffect) |
| 31 | +import Effect.Class.Console as Console |
| 32 | +import Routing.Duplex (print) |
| 33 | + |
| 34 | +type URL |
| 35 | + = String |
| 36 | + |
| 37 | +type Request |
| 38 | + = { method :: Method |
| 39 | + , url :: URL |
| 40 | + , headers :: Array RequestHeader |
| 41 | + , body :: AC.Json |
| 42 | + } |
| 43 | + |
| 44 | +type Response |
| 45 | + = { status :: StatusCode |
| 46 | + , headers :: Array ResponseHeader |
| 47 | + , body :: AC.Json |
| 48 | + } |
| 49 | + |
| 50 | +data Error |
| 51 | + = NotAuthorized |
| 52 | + | RuntimeError Affjax.Error |
| 53 | + | DecodeError Request Response JsonDecodeError |
| 54 | + | UnexpectedResponse Request Response |
| 55 | + |
| 56 | +instance showError :: Show Error where |
| 57 | + show NotAuthorized = "(NotAuthorized)" |
| 58 | + show (RuntimeError err) = "(RuntimeError {- " <> Affjax.printError err <> " -})" |
| 59 | + show (DecodeError req res err) = "(DecodeError " <> printRequest req <> " " <> printResponse res <> " " <> printJsonDecodeError err <> ")" |
| 60 | + show (UnexpectedResponse req res) = "(UnexpectedResponse " <> printRequest req <> " " <> printResponse res <> ")" |
| 61 | + |
| 62 | +makeRequest' :: |
| 63 | + forall m body response. |
| 64 | + MonadAff m => |
| 65 | + EncodeJson body => |
| 66 | + DecodeJson response => |
| 67 | + Method -> |
| 68 | + StatusCode -> |
| 69 | + Endpoint -> |
| 70 | + (Request -> Request) -> |
| 71 | + body -> |
| 72 | + m (Either Error response) |
| 73 | +makeRequest' method statusCode endpoint transform body = liftAff $ runExceptT $ handle =<< fetch request |
| 74 | + where |
| 75 | + request = transform $ buildRequest method endpoint body |
| 76 | + |
| 77 | + handle resp |
| 78 | + | resp.status == statusCode = decode resp |
| 79 | + | otherwise = throwError $ UnexpectedResponse request resp |
| 80 | + |
| 81 | + decode resp = withExceptT (DecodeError request resp) $ except $ decodeJson resp.body |
| 82 | + |
| 83 | +makeRequest :: |
| 84 | + forall m body response. |
| 85 | + MonadAff m => |
| 86 | + EncodeJson body => |
| 87 | + DecodeJson response => |
| 88 | + Method -> |
| 89 | + StatusCode -> |
| 90 | + Endpoint -> |
| 91 | + body -> |
| 92 | + m (Either Error response) |
| 93 | +makeRequest method statusCode endpoint body = do |
| 94 | + res <- makeRequest' method statusCode endpoint addBaseUrl body |
| 95 | + void $ lfor res onError |
| 96 | + pure res |
| 97 | + |
| 98 | +makeSecureRequest' :: |
| 99 | + forall m body response. |
| 100 | + MonadAff m => |
| 101 | + EncodeJson body => |
| 102 | + DecodeJson response => |
| 103 | + String -> |
| 104 | + Method -> |
| 105 | + StatusCode -> |
| 106 | + Endpoint -> |
| 107 | + body -> |
| 108 | + m (Either Error response) |
| 109 | +makeSecureRequest' token method statusCode endpoint body = do |
| 110 | + res <- makeRequest' method statusCode endpoint (addBaseUrl <<< addToken token) body |
| 111 | + void $ lfor res onError |
| 112 | + pure res |
| 113 | + |
| 114 | +makeSecureRequest :: |
| 115 | + forall m body response. |
| 116 | + MonadAuth m => |
| 117 | + MonadRouting m => |
| 118 | + MonadAff m => |
| 119 | + EncodeJson body => |
| 120 | + DecodeJson response => |
| 121 | + Method -> |
| 122 | + StatusCode -> |
| 123 | + Endpoint -> |
| 124 | + body -> |
| 125 | + m (Either Error response) |
| 126 | +makeSecureRequest method statusCode endpoint body = do |
| 127 | + auth <- Auth.read |
| 128 | + case auth of |
| 129 | + Nothing -> do |
| 130 | + Routing.redirect Register |
| 131 | + pure $ Left $ NotAuthorized |
| 132 | + Just { token } -> do |
| 133 | + makeSecureRequest' token method statusCode endpoint body |
| 134 | + |
| 135 | +buildRequest :: forall body. EncodeJson body => Method -> Endpoint -> body -> Request |
| 136 | +buildRequest method endpoint body = |
| 137 | + { method |
| 138 | + , url: print endpointCodec endpoint |
| 139 | + , headers: [ ContentType applicationJSON ] |
| 140 | + , body: encodeJson body |
| 141 | + } |
| 142 | + |
| 143 | +fetch :: Request -> ExceptT Error Aff Response |
| 144 | +fetch { method, url, headers, body } = do |
| 145 | + response <- withExceptT RuntimeError $ ExceptT runRequest |
| 146 | + pure |
| 147 | + { status: response.status |
| 148 | + , headers: response.headers |
| 149 | + , body: response.body |
| 150 | + } |
| 151 | + where |
| 152 | + runRequest = |
| 153 | + Affjax.request |
| 154 | + $ defaultRequest |
| 155 | + { method = Left method |
| 156 | + , url = url |
| 157 | + , headers = headers |
| 158 | + , responseFormat = ResponseFormat.json |
| 159 | + , content = if AC.isNull body then Nothing else pure $ RequestBody.json body |
| 160 | + } |
| 161 | + |
| 162 | +addBaseUrl :: forall r. { url :: String | r } -> { url :: String | r } |
| 163 | +addBaseUrl request@{ url } = request { url = Config.apiEndpoint <> url } |
| 164 | + |
| 165 | +addToken :: forall r. String -> { headers :: Array RequestHeader | r } -> { headers :: Array RequestHeader | r } |
| 166 | +addToken token request@{ headers } = request { headers = Array.snoc headers (RequestHeader "Authorization" ("Token " <> token)) } |
| 167 | + |
| 168 | +onError :: forall m. MonadEffect m => Error -> m Unit |
| 169 | +onError error = do |
| 170 | + when (Config.nodeEnv /= "production") do |
| 171 | + Console.log $ show error |
| 172 | + |
| 173 | +isNotFound :: forall response. Either Error response -> Boolean |
| 174 | +isNotFound = case _ of |
| 175 | + Left (UnexpectedResponse _ { status }) |
| 176 | + | status == StatusCode 404 -> true |
| 177 | + _ -> false |
| 178 | + |
| 179 | +isUnprocessableEntity :: forall response. Either Error response -> Boolean |
| 180 | +isUnprocessableEntity = case _ of |
| 181 | + Left (UnexpectedResponse _ { status }) |
| 182 | + | status == StatusCode 422 -> true |
| 183 | + _ -> false |
| 184 | + |
| 185 | +printRequest :: Request -> String |
| 186 | +printRequest req@{ body } = show $ req { body = AC.stringify body } |
| 187 | + |
| 188 | +printResponse :: Response -> String |
| 189 | +printResponse res@{ body } = show $ res { body = AC.stringify body } |
0 commit comments