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