0 | module HTTP.API.Client
  1 |
  2 | import Data.Linear.Traverse1
  3 | import HTTP.API.Client.FFI
  4 | import HTTP.I18n
  5 | import IO.Async.JS
  6 | import JSON.Simple
  7 | import JS
  8 | import Syntax.T1
  9 | import Web.Internal.Types
 10 |
 11 | import public HTTP.API.Client.Content
 12 | import public HTTP.API.Client.Header
 13 | import public HTTP.API.Client.Interface
 14 | import public HTTP.API.Client.Method
 15 | import public HTTP.API.Client.Path
 16 | import public HTTP.API.Client.Query
 17 | import public HTTP.API.Client.Request
 18 |
 19 | %default total
 20 |
 21 | ||| HTTP Errors
 22 | public export
 23 | data HTTPError : Type where
 24 |   Timeout      : HTTPError
 25 |   NetworkError : HTTPError
 26 |   DecError     : Bits16 -> DecodeErr -> HTTPError
 27 |   ReqError     : RequestErr -> HTTPError
 28 |
 29 | setFD : FormData -> (String,FDPart) -> IO1 ()
 30 | setFD fd (nm,FDBlob b)   t = appendBlob fd nm b t
 31 | setFD fd (nm,FDBytes b)  t = appendBytes fd nm b t
 32 | setFD fd (nm,FDFile f)   t = appendFile fd nm f t
 33 | setFD fd (nm,FDString s) t = appendTxt fd nm s t
 34 |
 35 | sendBody : XMLHttpRequest -> RequestBody -> IO1 ()
 36 | sendBody x None         t = send x t
 37 | sendBody x (Bytes mt b) t =
 38 |  let _   # t := setRequestHeader x Content_Type (encodeMediaType mt) t
 39 |      buf # t := ioToF1 (toBuffer b) t
 40 |   in sendBuffer x buf t
 41 | sendBody x (Str mt s)  t =
 42 |  let _   # t := setRequestHeader x Content_Type (encodeMediaType mt) t
 43 |   in sendTxt x s t
 44 | sendBody x (FD xs)     t =
 45 |  let fd  # t := newFD t
 46 |      _   # t := for1_ xs (setFD fd) t
 47 |   in sendFD x fd t
 48 |
 49 | data Decoder : Type -> Type where
 50 |   NoDec : Decoder ()
 51 |   Dec   : {0 f : Type} -> DecodeVia f t -> Decoder t
 52 |
 53 | adjHeader : Decoder t -> XMLHttpRequest -> IO1 ()
 54 | adjHeader NoDec   x t = () # t
 55 | adjHeader (Dec d) x t =
 56 |   setRequestHeader x Accept (encodeMediaType $ mediaType @{d}) t
 57 |
 58 | parameters {auto has : Has HTTPError es}
 59 |            {auto loc : HTTPLocal}
 60 |            (dec      : Decoder t)
 61 |            (cb       : Result es t -> IO1 ())
 62 |
 63 |   onerror : HTTPError -> Event -> IO1 ()
 64 |   onerror x _ = cb (Left $ inject x)
 65 |
 66 |   onsuccess : XMLHttpRequest -> IO1 ()
 67 |   onsuccess x =
 68 |     case dec of
 69 |       NoDec => cb (Right ())
 70 |       Dec d => T1.do
 71 |         st <- status x
 72 |         bs <- responseBytes x
 73 |         cb (mapFst (inject . DecError st) $ decodeVia @{d} [] bs)
 74 |
 75 |   onload : XMLHttpRequest -> Event -> IO1 ()
 76 |   onload x ev = T1.do
 77 |     st <- status x
 78 |     case st >= 200 && st < 300 of
 79 |       False => T1.do
 80 |         bs <- responseBytes x
 81 |         let res := decodeVia {from = JSON, to = RequestErr} [] bs
 82 |         cb (Left $ either (inject . DecError st) (inject . ReqError) res)
 83 |       True  => onsuccess x
 84 |
 85 |   export
 86 |   send1 : HTTPRequest -> IO1 (IO1 ())
 87 |   send1 r = T1.do
 88 |     x <- xmlhttpRequest
 89 |     addEventListener (up x) "error" $ onerror NetworkError
 90 |     addEventListener (up x) "load" $ onload x
 91 |     addEventListener (up x) "timeout" $ onerror Timeout
 92 |     opn x r.method r.uri
 93 |
 94 |     for1_ (kvList r.headers) $ setRequestHeaderP x
 95 |     adjHeader dec x
 96 |     sendBody x r.body
 97 |
 98 |     pure (abort x)
 99 |
100 | parameters {auto has  : Has HTTPError es}
101 |            {auto loc  : HTTPLocal}
102 |            (endpoint  : HList ts)
103 |            {auto all  : All Receive ts}
104 |            {auto cons : HList (AllRecConstraints endpoint)}
105 |            (args      : HList (AllRecTypes endpoint))
106 |
107 |   export
108 |   sendEndpoint : Async JS es ()
109 |   sendEndpoint =
110 |     primAsync $ \cb =>
111 |       send1 NoDec cb (endpointRequest endpoint args emptyRequest)
112 |
113 |   export
114 |   requestEndpoint : (0 f,t : Type) -> (dec : DecodeVia f t) => Async JS es t
115 |   requestEndpoint f t =
116 |     primAsync $ \cb =>
117 |       send1 (Dec dec) cb (endpointRequest endpoint args emptyRequest)
118 |
119 |   export %inline
120 |   requestJSONEndpoint : (0 t : Type) -> DecodeVia JSON t => Async JS es t
121 |   requestJSONEndpoint = requestEndpoint JSON
122 |