0 | module Network.HTTP.Client
  1 |
  2 | import Network.HTTP.Pool.ConnectionPool
  3 | import Network.HTTP.Scheduler
  4 | import Network.HTTP.Protocol
  5 | import Network.HTTP.Message
  6 | import Network.HTTP.Error
  7 | import Network.HTTP.Header
  8 | import Network.HTTP.Method
  9 | import Network.HTTP.URL
 10 | import Network.HTTP.Path
 11 | import Network.HTTP.Status
 12 | import Network.HTTP.Cookie
 13 | import Network.TLS
 14 | import Network.TLS.Certificate.System
 15 | import Network.TLS.Signature
 16 | import Utils.Streaming
 17 | import Utils.String
 18 | import Utils.Bytes
 19 | import Control.Monad.Error.Either
 20 | import Control.Monad.Error.Interface
 21 | import Control.Monad.Trans
 22 | import Data.String
 23 | import Data.String.Extra
 24 | import Data.Nat
 25 | import Data.IORef
 26 | import Decidable.Equality
 27 |
 28 | public export
 29 | record HttpClient e where
 30 |   constructor MkHttpClient
 31 |   cookie_jar : IORef CookieJar
 32 |   store_cookie : Bool
 33 |   follow_redirect : Bool
 34 |   pool_manager : PoolManager e
 35 |
 36 | ||| Close all existing connections in the HTTP client.
 37 | ||| A closed client can be reused again.
 38 | export
 39 | close : {e : _} -> HasIO io => HttpClient e -> io ()
 40 | close client = liftIO $ evict_all {m=IO,e=e} $ client.pool_manager
 41 |
 42 | ||| Creates a new HTTP client.
 43 | ||| Arguments:
 44 | |||
 45 | ||| @ cert_checker the function used to verify the website's TLS certificate.
 46 | |||                `certificate_check` and `certificate_ignore_check` are provided in `Network.TLS`.
 47 | ||| @ max_total_connection the maximum alive connections (per protocol) allowed
 48 | ||| @ max_per_site_connection the maximum alive connections (per protocol) per site allowed
 49 | ||| @ store_cookie whether the client should store received cookies
 50 | ||| @ follow_redirect whether the client should follow redirects according to response status codes
 51 | export
 52 | new_client : HasIO io => (String -> CertificateCheck IO) ->
 53 |              (max_total_connection : Nat) -> {auto 0 n01 : NonZero max_total_connection} ->
 54 |              (max_per_site_connection: Nat) -> {auto 0 no2 : NonZero max_per_site_connection} ->
 55 |              {auto 0 lte : LTE max_per_site_connection max_total_connection} ->
 56 |              Bool -> Bool -> io (HttpClient e)
 57 | new_client cert_checker max_total_connection max_per_site_connection store_cookie follow_redirect = do
 58 |   manager <- new_pool_manager max_per_site_connection max_total_connection cert_checker
 59 |   jar <- newIORef $ MkCookieJar []
 60 |   pure $ MkHttpClient jar store_cookie follow_redirect manager
 61 |
 62 | ||| Create a new HTTP client with default configuration.
 63 | ||| This would also verify the website's TLS certificate with the system's trusted CAs.
 64 | ||| max_total_connection = 25
 65 | ||| max_per_site_connection = 5
 66 | ||| store_cookie = True
 67 | ||| follow_redirect = True
 68 | export
 69 | new_client_default : HasIO io => io (HttpClient e)
 70 | new_client_default = do
 71 |   Right certs <- liftIO get_system_trusted_certs
 72 |   | Left err => assert_total $ idris_crash "error when trying to get system certificats, please report this issue."
 73 |   new_client (certificate_check certs) 25 5 True True
 74 |
 75 | replace : Eq a => List (a, b) -> List (a, b) -> List (a, b)
 76 | replace original [] = original
 77 | replace original ((k, v) :: xs) = replace (loop [] original k v) xs where
 78 |   loop : List (a, b) -> List (a, b) -> a -> b -> List (a, b)
 79 |   loop acc [] k v = acc
 80 |   loop acc ((k', v') :: xs) k v = if k' == k then (k, v) :: (acc <+> xs) else loop ((k', v') :: acc) xs k v
 81 |
 82 | add_if_not_exist : Eq a => (a, b) -> List (a, b) -> List (a, b)
 83 | add_if_not_exist (k, v) headers = if any (\(k', v') => k' == k) headers then headers else (k, v) :: headers
 84 |
 85 | unwrap : Functor f => Stream f (EitherT e IO) a -> Stream f IO (Either e a)
 86 | unwrap = fold (Return . Right) (go . runEitherT) (\x => Step x) where
 87 |   go : IO (Either e (Stream f IO (Either e a))) -> ?
 88 |   go stream = case !(lift stream) of
 89 |     Left err => Return (Left err)
 90 |     Right stream => stream
 91 |
 92 | wrap : (Functor f, MonadError e m) => HasIO m => Stream f IO (Either e ()) -> Stream f m ()
 93 | wrap = fold (\case Right a => Return a; Left a => Effect $ throwError a) (Effect . delay . liftIO) (\x => Step x)
 94 |
 95 | ||| Send a HTTP request, returns a `HttpResponse` containing the status code and headers,
 96 | ||| and also a stream of the content body from the response.
 97 | ||| Arguments:
 98 | |||
 99 | ||| @ client the HTTP client
100 | ||| @ method the HTTP method, e.g. GET / POST
101 | ||| @ url the URL to of the website to be connected to
102 | ||| @ headers the HTTP headers, represented as a list of (key, value)
103 | ||| @ length the length of the content to be sent
104 | ||| @ input the stream of bytes to be sent, which should be at least `length` bytes
105 | export
106 | request' : {e,m : _} -> MonadError (HttpError e) m => HasIO m => HttpClient e -> Method -> URL -> List (String, String)
107 |   -> (length: Nat)
108 |   -> (input : Stream (Of Bits8) (EitherT e IO) ())
109 |   -> m (HttpResponse, Stream (Of Bits8) m ())
110 | request' client method url headers payload_size payload = do
111 |   let Just protocol = protocol_from_str url.protocol
112 |   | Nothing => throwError (UnknownProtocol url.protocol)
113 |
114 |   cookies_jar <- liftIO $ readIORef client.cookie_jar
115 |
116 |   let headers_with_missing_info =
117 |         add_if_not_exist ("Host", hostname_string url.host) .
118 |         add_if_not_exist ("User-Agent", "idris2-http") .
119 |         add_if_not_exist ("Content-Length", show payload_size) .
120 |         add_if_not_exist ("Cookie", join "; " $ map serialize_cookie_no_attr cookies_jar.cookies) $ headers
121 |
122 |   let message = MkRawHttpMessage method (show url.path <+> url.extensions) headers_with_missing_info
123 |   Right (response, content) <- liftIO $ start_request {m=IO} client.pool_manager protocol message (unwrap payload)
124 |   | Left err => throwError err
125 |
126 |   when client.store_cookie $ do
127 |     let cookies = lookup_headers response.headers SetCookie
128 |     liftIO $ modifyIORef client.cookie_jar (\og => foldl add_cookie og cookies)
129 |
130 |   if (client.follow_redirect && (Redirection == status_code_class response.status_code.snd))
131 |     then do
132 |       let Just location = lookup_header response.headers Location
133 |       | Nothing => throwError (MissingHeader "Location")
134 |
135 |       -- discard responded content to make way for another request
136 |       liftIO $ consume content
137 |       request' client method (add url location) headers payload_size payload
138 |     else
139 |       pure $ map wrap (response, content)
140 |
141 | public export
142 | interface Bytestream (a : Type) where
143 |   to_stream : Monad m => a -> (Nat, Stream (Of Bits8) m ())
144 |
145 | export
146 | Bytestream () where
147 |   to_stream () = (0, pure ())
148 |
149 | export
150 | Bytestream (List Bits8) where
151 |   to_stream list = (length list, fromList_ list)
152 |
153 | export
154 | Bytestream String where
155 |   to_stream = to_stream . utf8_unpack
156 |
157 | ||| Send a HTTP request, returns a `HttpResponse` containing the status code and headers,
158 | ||| and also a stream of the content body from the response.
159 | ||| Arguments:
160 | |||
161 | ||| @ client the HTTP client
162 | ||| @ method the HTTP method, e.g. GET / POST
163 | ||| @ url the URL to of the website to be connected to
164 | ||| @ headers the HTTP headers, represented as a list of (key, value)
165 | ||| @ payload the content payload of the request. Use () for empty content.
166 | export
167 | request : {e,m,a : _} -> MonadError (HttpError e) m => HasIO m => Bytestream a =>
168 |           HttpClient e -> Method -> URL -> List (String, String) ->
169 |           a ->
170 |           m (HttpResponse, Stream (Of Bits8) m ())
171 | request client method url headers payload =
172 |   let (len, stream) = to_stream {m=EitherT e IO} payload
173 |   in request' client method url headers len stream
174 |