1 ! Copyright (C) 2005, 2010 Slava Pestov.
2 ! See https://factorcode.org/license.txt for BSD license.
3 USING: accessors arrays ascii assocs calendar combinators
4 combinators.short-circuit continuations destructors effects
5 environment hashtables http http.client.post-data http.parsers
6 http.websockets io io.crlf io.encodings io.encodings.ascii
7 io.encodings.binary io.encodings.iana io.encodings.string
8 io.files io.files.info io.pathnames io.sockets io.sockets.secure
9 io.timeouts kernel math math.order math.parser mime.types
10 namespaces present protocols sequences splitting urls
14 ERROR: too-many-redirects ;
15 ERROR: invalid-proxy proxy ;
17 : success? ( code -- ? ) 200 299 between? ;
19 ERROR: download-failed response ;
21 : check-response ( response -- response )
22 dup code>> success? [ download-failed ] unless ;
26 : authority-uri ( url -- str )
27 [ host>> ] [ port>> number>string ] bi ":" glue ;
29 : absolute-uri ( url -- str )
30 clone f >>username f >>password f >>anchor present ;
32 : abs-path-uri ( url -- str )
33 relative-url f >>anchor present ;
35 : request-uri ( request -- str )
37 { [ dup proxy-url>> ] [ url>> absolute-uri ] }
38 { [ dup method>> "CONNECT" = ] [ url>> authority-uri ] }
39 [ url>> abs-path-uri ]
42 : write-request-line ( request -- request )
45 [ request-uri write bl ]
46 [ "HTTP/" write version>> write crlf ]
49 : default-port? ( url -- ? )
52 [ [ port>> ] [ protocol>> lookup-protocol-port ] bi = ]
55 : unparse-host ( url -- string )
56 dup default-port? [ host>> ] [
57 [ host>> ] [ port>> number>string ] bi ":" glue
60 : set-host-header ( request header -- request header )
61 over url>> unparse-host "Host" pick set-at ;
63 : set-cookie-header ( header cookies -- header )
64 unparse-cookie "Cookie" pick set-at ;
66 : ?set-basic-auth ( header url name -- header )
68 [ username>> ] [ password>> ] bi 2dup and
69 [ basic-auth swap pick set-at ] [ 3drop ] if
72 : write-request-header ( request -- request )
73 dup header>> >hashtable
74 over url>> host>> [ set-host-header ] when
75 over url>> "Authorization" ?set-basic-auth
76 over proxy-url>> "Proxy-Authorization" ?set-basic-auth
77 over post-data>> [ set-post-data-headers ] when*
78 over cookies>> [ set-cookie-header ] unless-empty
81 : write-request ( request -- )
90 : read-response-line ( response -- response )
91 read-?crlf parse-response-line first3
92 [ >>version ] [ >>code ] [ >>message ] tri* ;
94 : detect-encoding ( response -- encoding )
95 [ content-charset>> name>encoding ]
96 [ content-type>> mime-type-encoding ] bi
99 : read-response-header ( response -- response )
101 dup "set-cookie" header parse-set-cookie >>cookies
102 dup "content-type" header [
104 [ >>content-type ] [ >>content-charset ] bi*
105 dup detect-encoding >>content-encoding
108 : read-response ( -- response )
111 read-response-header ;
115 : redirect-url ( request url -- request )
116 '[ _ >url derive-url ensure-port ] change-url ;
118 : redirect? ( response -- ? )
119 code>> 300 399 between? ;
121 :: prepare-redirect ( response -- response )
123 redirects get request get redirects>> < [
125 response "location" header redirect-url
126 response code>> 307 = [ "GET" >>method f >>post-data ] unless
127 ] [ too-many-redirects ] if ; inline recursive
129 : read-chunk-size ( -- n )
130 read-crlf ";" split1 drop [ blank? ] trim-tail
131 hex> [ "Bad chunk size" throw ] unless* ;
133 : read-chunked ( quot: ( chunk -- ) -- )
134 read-chunk-size [ drop ] [
135 read [ swap call ] [ drop ] 2bi
136 read-crlf B{ } assert= read-chunked
137 ] if-zero ; inline recursive
139 : read-response-body ( quot: ( chunk -- ) response -- )
141 "transfer-encoding" header "chunked" =
142 [ read-chunked ] [ each-block ] if ; inline
144 : request-socket-endpoints ( request -- physical logical )
145 [ proxy-url>> ] [ url>> ] bi [ or ] keep ;
147 : <request-socket> ( -- stream )
148 request get request-socket-endpoints [ url-addr ] bi@
149 remote-address set ascii <client> local-address set
150 1 minutes over set-timeout ;
152 : https-tunnel? ( request -- ? )
153 [ proxy-url>> ] [ url>> protocol>> "https" = ] bi and ;
155 : ?copy-proxy-basic-auth ( dst-request src-request -- dst-request )
156 proxy-url>> [ username>> ] [ password>> ] bi 2dup and
157 [ set-proxy-basic-auth ] [ 2drop ] if ;
159 : ?https-tunnel ( -- )
160 request get dup https-tunnel? [
161 <request> swap [ url>> >>url ] [ ?copy-proxy-basic-auth ] bi
162 f >>proxy-url "CONNECT" >>method write-request
163 read-response check-response drop send-secure-handshake
166 ! Note: ipv4 addresses are interpreted as subdomains but "work"
167 : no-proxy-match? ( host-path no-proxy-path -- ? )
168 dup first empty? [ [ rest ] bi@ ] when
169 [ drop f ] [ tail? ] if-empty ;
171 : get-no-proxy-list ( -- list )
173 [ "no_proxy" os-env ] unless*
174 [ "NO_PROXY" os-env ] unless* ;
176 : no-proxy? ( request -- ? )
178 [ url>> host>> "." split ] dip "," split
179 [ "." split no-proxy-match? ] with any?
182 : (check-proxy) ( proxy -- ? )
184 { [ dup URL" " = ] [ drop f ] }
185 { [ dup host>> ] [ drop t ] }
189 : check-proxy ( request proxy -- request' )
190 dup [ (check-proxy) ] [ f ] if*
191 [ drop f ] unless [ clone ] dip >>proxy-url ;
193 : get-default-proxy ( request -- default-proxy )
194 url>> protocol>> "https" = [
196 [ "https_proxy" os-env ] unless*
197 [ "HTTPS_PROXY" os-env ] unless*
200 [ "http_proxy" os-env ] unless*
201 [ "HTTP_PROXY" os-env ] unless*
204 : misparsed-url? ( url -- url' )
205 [ protocol>> not ] [ host>> not ] [ path>> ] tri and and ;
207 : request-url ( url -- url' )
208 dup >url dup misparsed-url? [
209 drop dup url? [ present ] when
210 "http://" prepend >url
211 ] [ nip ] if ensure-port ;
213 : ?default-proxy ( request -- request' )
214 dup get-default-proxy
215 over proxy-url>> dup [ request-url ] when 2dup and [
216 pick no-proxy? [ nip ] [ [ request-url ] dip derive-url ] if
217 ] [ nip ] if check-proxy ;
219 : upgrade-to-websocket? ( response -- ? )
223 [ message>> >lower "switching protocols" = ]
224 [ header>> "connection" of "upgrade" = ]
225 [ header>> "upgrade" of "websocket" = ]
230 SYMBOL: request-socket
232 : do-http-request ( request quot: ( chunk -- ) -- response/stream )
233 [ ?default-proxy \ request ] dip dup '[
235 <request-socket> |dispose
236 dup request-socket set
238 [ in>> ] [ out>> ] bi [ ?https-tunnel ] with-streams*
242 [ request get write-request ]
249 request get redirects>> 0 > and [
250 request-socket get dispose
251 prepare-redirect _ do-http-request
253 dup upgrade-to-websocket?
254 [ drop request-socket get ]
256 [ _ ] dip [ read-response-body ] keep
257 request-socket get dispose
263 ] with-variable ; inline recursive
265 : add-default-headers ( request -- request )
266 dup url>> protocol>> {
267 { [ dup { "ws" "wss" } member? ] [ drop add-websocket-upgrade-headers ] }
271 : <client-request> ( url method -- request )
274 swap request-url >>url
275 add-default-headers ; inline
277 : with-http-request ( request quot: ( chunk -- ) -- response/stream )
278 do-http-request check-response ; inline
280 : http-request* ( request -- response data )
281 BV{ } clone [ '[ _ push-all ] do-http-request ] keep
282 B{ } like over content-encoding>> decode [ >>body ] keep ;
284 : http-request ( request -- response data )
285 http-request* [ check-response ] dip ;
287 : <get-request> ( url -- request )
288 "GET" <client-request> ;
290 : http-get ( url -- response data )
291 <get-request> http-request ;
293 : http-get* ( url -- response data )
294 <get-request> http-request* ;
296 : file-too-old? ( file duration -- ? )
298 [ file-info created>> ago ] dip after?
301 : download-name ( url -- name )
302 present file-name "?" split1 drop "/" ?tail drop ;
304 : download-to ( url file -- )
306 <get-request> [ write ] with-http-request drop
309 : ?download-to ( url file -- )
310 dup file-exists? [ 2drop ] [ download-to ] if ;
312 : ?download-update-to ( url file duration -- )
313 2dup file-too-old? [ drop download-to ] [ 3drop ] if ;
315 : download ( url -- )
316 dup download-name download-to ;
318 : <post-request> ( post-data url -- request )
319 "POST" <client-request>
322 : http-post ( post-data url -- response data )
323 <post-request> http-request ;
325 : http-post* ( post-data url -- response data )
326 <post-request> http-request* ;
328 : <put-request> ( post-data url -- request )
329 "PUT" <client-request>
332 : http-put ( post-data url -- response data )
333 <put-request> http-request ;
335 : http-put* ( post-data url -- response data )
336 <put-request> http-request* ;
338 : <delete-request> ( url -- request )
339 "DELETE" <client-request> ;
341 : http-delete ( url -- response data )
342 <delete-request> http-request ;
344 : http-delete* ( url -- response data )
345 <delete-request> http-request* ;
347 : <head-request> ( url -- request )
348 "HEAD" <client-request> ;
350 : http-head ( url -- response data )
351 <head-request> http-request ;
353 : http-head* ( url -- response data )
354 <head-request> http-request* ;
356 : <options-request> ( url -- request )
357 "OPTIONS" <client-request> ;
359 : http-options ( url -- response data )
360 <options-request> http-request ;
362 : http-options* ( url -- response data )
363 <options-request> http-request* ;
365 : <patch-request> ( patch-data url -- request )
366 "PATCH" <client-request>
369 : http-patch ( patch-data url -- response data )
370 <patch-request> http-request ;
372 : http-patch* ( patch-data url -- response data )
373 <patch-request> http-request* ;
375 : <trace-request> ( url -- request )
376 "TRACE" <client-request> ;
378 : http-trace ( url -- response data )
379 <trace-request> http-request ;
381 : http-trace* ( url -- response data )
382 <trace-request> http-request* ;
384 { "http.client" "debugger" } "http.client.debugger" require-when