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 (Blob mt b) t =
 42 |  let _   # t := setRequestHeader x Content_Type (encodeMediaType mt) t
 43 |   in sendBlob x b t
 44 | sendBody x (Str mt s)  t =
 45 |  let _   # t := setRequestHeader x Content_Type (encodeMediaType mt) t
 46 |   in sendTxt x s t
 47 | sendBody x (FD xs)     t =
 48 |  let fd  # t := newFD t
 49 |      _   # t := for1_ xs (setFD fd) t
 50 |   in sendFD x fd t
 51 |
 52 | data Decoder : Type -> Type where
 53 |   NoDec : Decoder ()
 54 |   Dec   : {0 f : Type} -> DecodeVia f t -> Decoder t
 55 |
 56 | adjHeader : Decoder t -> XMLHttpRequest -> IO1 ()
 57 | adjHeader NoDec   x t = () # t
 58 | adjHeader (Dec d) x t =
 59 |   setRequestHeader x Accept (encodeMediaType $ mediaType @{d}) t
 60 |
 61 | parameters {auto has : Has HTTPError es}
 62 |            {auto loc : HTTPLocal}
 63 |            (dec      : Decoder t)
 64 |            (cb       : Result es t -> IO1 ())
 65 |
 66 |   onerror : HTTPError -> Event -> IO1 ()
 67 |   onerror x _ = cb (Left $ inject x)
 68 |
 69 |   onsuccess : XMLHttpRequest -> IO1 ()
 70 |   onsuccess x =
 71 |     case dec of
 72 |       NoDec => cb (Right ())
 73 |       Dec d => T1.do
 74 |         st <- status x
 75 |         bs <- responseBytes x
 76 |         cb (mapFst (inject . DecError st) $ decodeVia @{d} [] bs)
 77 |
 78 |   onload : XMLHttpRequest -> Event -> IO1 ()
 79 |   onload x ev = T1.do
 80 |     st <- status x
 81 |     case st >= 200 && st < 300 of
 82 |       False => T1.do
 83 |         bs <- responseBytes x
 84 |         let res := decodeVia {from = JSON, to = RequestErr} [] bs
 85 |         cb (Left $ either (inject . DecError st) (inject . ReqError) res)
 86 |       True  => onsuccess x
 87 |
 88 |   export
 89 |   send1 : HTTPRequest -> IO1 (IO1 ())
 90 |   send1 r = T1.do
 91 |     x <- xmlhttpRequest
 92 |     addEventListener (up x) "error" $ onerror NetworkError
 93 |     addEventListener (up x) "load" $ onload x
 94 |     addEventListener (up x) "timeout" $ onerror Timeout
 95 |     opn x r.method r.uri
 96 |
 97 |     for1_ (kvList r.headers) $ setRequestHeaderP x
 98 |     adjHeader dec x
 99 |     sendBody x r.body
100 |
101 |     pure (abort x)
102 |
103 | parameters {auto has  : Has HTTPError es}
104 |            {auto loc  : HTTPLocal}
105 |            (endpoint  : HList ts)
106 |            {auto all  : All Receive ts}
107 |            {auto cons : HList (AllRecConstraints endpoint)}
108 |            (args      : HList (AllRecTypes endpoint))
109 |
110 |   export
111 |   sendEndpoint : Async JS es ()
112 |   sendEndpoint =
113 |     primAsync $ \cb =>
114 |       send1 NoDec cb (endpointRequest endpoint args emptyRequest)
115 |
116 |   export
117 |   requestEndpoint : (0 f,t : Type) -> (dec : DecodeVia f t) => Async JS es t
118 |   requestEndpoint f t =
119 |     primAsync $ \cb =>
120 |       send1 (Dec dec) cb (endpointRequest endpoint args emptyRequest)
121 |
122 |   export %inline
123 |   requestJSONEndpoint : (0 t : Type) -> DecodeVia JSON t => Async JS es t
124 |   requestJSONEndpoint = requestEndpoint JSON
125 |