350 lines
10 KiB
Factor
350 lines
10 KiB
Factor
! Copyright (C) 2005, 2010 Slava Pestov.
|
|
! See http://factorcode.org/license.txt for BSD license.
|
|
USING: accessors ascii assocs calendar combinators.short-circuit
|
|
destructors fry hashtables http http.client.post-data
|
|
http.parsers io io.crlf io.encodings io.encodings.ascii
|
|
io.encodings.binary io.encodings.iana io.encodings.string
|
|
io.files io.pathnames io.sockets io.sockets.secure io.timeouts
|
|
kernel locals math math.order math.parser mime.types namespaces
|
|
present sequences splitting urls vocabs.loader combinators
|
|
environment ;
|
|
IN: http.client
|
|
|
|
ERROR: too-many-redirects ;
|
|
ERROR: invalid-proxy proxy ;
|
|
|
|
: success? ( code -- ? ) 200 299 between? ;
|
|
|
|
ERROR: download-failed response ;
|
|
|
|
: check-response ( response -- response )
|
|
dup code>> success? [ download-failed ] unless ;
|
|
|
|
<PRIVATE
|
|
|
|
: authority-uri ( url -- str )
|
|
[ host>> ] [ port>> number>string ] bi ":" glue ;
|
|
|
|
: absolute-uri ( url -- str )
|
|
clone f >>username f >>password f >>anchor present ;
|
|
|
|
: abs-path-uri ( url -- str )
|
|
relative-url f >>anchor present ;
|
|
|
|
: request-uri ( request -- str )
|
|
{
|
|
{ [ dup proxy-url>> ] [ url>> absolute-uri ] }
|
|
{ [ dup method>> "CONNECT" = ] [ url>> authority-uri ] }
|
|
[ url>> abs-path-uri ]
|
|
} cond ;
|
|
|
|
: write-request-line ( request -- request )
|
|
dup
|
|
[ method>> write bl ]
|
|
[ request-uri write bl ]
|
|
[ "HTTP/" write version>> write crlf ]
|
|
tri ;
|
|
|
|
: default-port? ( url -- ? )
|
|
{
|
|
[ port>> not ]
|
|
[ [ port>> ] [ protocol>> protocol-port ] bi = ]
|
|
} 1|| ;
|
|
|
|
: unparse-host ( url -- string )
|
|
dup default-port? [ host>> ] [
|
|
[ host>> ] [ port>> number>string ] bi ":" glue
|
|
] if ;
|
|
|
|
: set-host-header ( request header -- request header )
|
|
over url>> unparse-host "host" pick set-at ;
|
|
|
|
: set-cookie-header ( header cookies -- header )
|
|
unparse-cookie "cookie" pick set-at ;
|
|
|
|
: ?set-basic-auth ( header url name -- header )
|
|
swap [
|
|
[ username>> ] [ password>> ] bi 2dup and
|
|
[ basic-auth swap pick set-at ] [ 3drop ] if
|
|
] [ drop ] if* ;
|
|
|
|
: write-request-header ( request -- request )
|
|
dup header>> >hashtable
|
|
over url>> host>> [ set-host-header ] when
|
|
over url>> "Authorization" ?set-basic-auth
|
|
over proxy-url>> "Proxy-Authorization" ?set-basic-auth
|
|
over post-data>> [ set-post-data-headers ] when*
|
|
over cookies>> [ set-cookie-header ] unless-empty
|
|
write-header ;
|
|
|
|
: write-request ( request -- )
|
|
unparse-post-data
|
|
write-request-line
|
|
write-request-header
|
|
binary encode-output
|
|
write-post-data
|
|
flush
|
|
drop ;
|
|
|
|
: read-response-line ( response -- response )
|
|
read-?crlf parse-response-line first3
|
|
[ >>version ] [ >>code ] [ >>message ] tri* ;
|
|
|
|
: detect-encoding ( response -- encoding )
|
|
[ content-charset>> name>encoding ]
|
|
[ content-type>> mime-type-encoding ] bi
|
|
or ;
|
|
|
|
: read-response-header ( response -- response )
|
|
read-header >>header
|
|
dup "set-cookie" header parse-set-cookie >>cookies
|
|
dup "content-type" header [
|
|
parse-content-type
|
|
[ >>content-type ] [ >>content-charset ] bi*
|
|
dup detect-encoding >>content-encoding
|
|
] when* ;
|
|
|
|
: read-response ( -- response )
|
|
<response>
|
|
read-response-line
|
|
read-response-header ;
|
|
|
|
DEFER: (with-http-request)
|
|
|
|
SYMBOL: redirects
|
|
|
|
: redirect-url ( request url -- request )
|
|
'[ _ >url derive-url ensure-port ] change-url ;
|
|
|
|
: redirect? ( response -- ? )
|
|
code>> 300 399 between? ;
|
|
|
|
:: do-redirect ( quot: ( chunk -- ) response -- response )
|
|
redirects inc
|
|
redirects get request get redirects>> < [
|
|
request get clone
|
|
response "location" header redirect-url
|
|
response code>> 307 = [ "GET" >>method f >>post-data ] unless
|
|
quot (with-http-request)
|
|
] [ too-many-redirects ] if ; inline recursive
|
|
|
|
: read-chunk-size ( -- n )
|
|
read-crlf ";" split1 drop [ blank? ] trim-tail
|
|
hex> [ "Bad chunk size" throw ] unless* ;
|
|
|
|
: read-chunked ( quot: ( chunk -- ) -- )
|
|
read-chunk-size dup zero?
|
|
[ 2drop ] [
|
|
read [ swap call ] [ drop ] 2bi
|
|
read-crlf B{ } assert= read-chunked
|
|
] if ; inline recursive
|
|
|
|
: read-response-body ( quot: ( chunk -- ) response -- )
|
|
binary decode-input
|
|
"transfer-encoding" header "chunked" =
|
|
[ read-chunked ] [ each-block ] if ; inline
|
|
|
|
: request-socket-endpoints ( request -- physical logical )
|
|
[ proxy-url>> ] [ url>> ] bi [ or ] keep ;
|
|
|
|
: <request-socket> ( -- stream )
|
|
request get request-socket-endpoints [ url-addr ] bi@
|
|
remote-address set ascii <client> local-address set
|
|
1 minutes over set-timeout ;
|
|
|
|
: https-tunnel? ( request -- ? )
|
|
[ proxy-url>> ] [ url>> protocol>> "https" = ] bi and ;
|
|
|
|
: ?copy-proxy-basic-auth ( dst-request src-request -- dst-request )
|
|
proxy-url>> [ username>> ] [ password>> ] bi 2dup and
|
|
[ set-proxy-basic-auth ] [ 2drop ] if ;
|
|
|
|
: ?https-tunnel ( -- )
|
|
request get dup https-tunnel? [
|
|
<request> swap [ url>> >>url ] [ ?copy-proxy-basic-auth ] bi
|
|
f >>proxy-url "CONNECT" >>method write-request
|
|
read-response check-response drop send-secure-handshake
|
|
] [ drop ] if ;
|
|
|
|
! Note: ipv4 addresses are interpreted as subdomains but "work"
|
|
: no-proxy-match? ( host-path no-proxy-path -- ? )
|
|
dup first empty? [ [ rest ] bi@ ] when
|
|
[ drop f ] [ tail? ] if-empty ;
|
|
|
|
: get-no-proxy-list ( -- list )
|
|
"no_proxy" get
|
|
[ "no_proxy" os-env ] unless*
|
|
[ "NO_PROXY" os-env ] unless* ;
|
|
|
|
: no-proxy? ( request -- ? )
|
|
get-no-proxy-list [
|
|
[ url>> host>> "." split ] dip "," split
|
|
[ "." split no-proxy-match? ] with any?
|
|
] [ drop f ] if* ;
|
|
|
|
: (check-proxy) ( proxy -- ? )
|
|
{
|
|
{ [ dup URL" " = ] [ drop f ] }
|
|
{ [ dup host>> ] [ drop t ] }
|
|
[ invalid-proxy ]
|
|
} cond ;
|
|
|
|
: check-proxy ( request proxy -- request' )
|
|
dup [ (check-proxy) ] [ f ] if*
|
|
[ drop f ] unless [ clone ] dip >>proxy-url ;
|
|
|
|
: get-default-proxy ( request -- default-proxy )
|
|
url>> protocol>> "https" = [
|
|
"https.proxy" get
|
|
[ "https_proxy" os-env ] unless*
|
|
[ "HTTPS_PROXY" os-env ] unless*
|
|
] [
|
|
"http.proxy" get
|
|
[ "http_proxy" os-env ] unless*
|
|
[ "HTTP_PROXY" os-env ] unless*
|
|
] if ;
|
|
|
|
: misparsed-url? ( url -- url' )
|
|
[ protocol>> not ] [ host>> not ] [ path>> ]
|
|
tri and and ;
|
|
|
|
: request-url ( url -- url' )
|
|
dup >url dup misparsed-url? [
|
|
drop dup url? [ present ] when
|
|
"http://" prepend >url
|
|
] [ nip ] if ensure-port ;
|
|
|
|
: ?default-proxy ( request -- request' )
|
|
dup get-default-proxy
|
|
over proxy-url>> dup [ request-url ] when 2dup and [
|
|
pick no-proxy? [ nip ] [ [ request-url ] dip derive-url ] if
|
|
] [ nip ] if check-proxy ;
|
|
|
|
: (with-http-request) ( request quot: ( chunk -- ) -- response )
|
|
swap ?default-proxy
|
|
request [
|
|
<request-socket> [
|
|
[
|
|
[ in>> ] [ out>> ] bi
|
|
[ ?https-tunnel ] with-streams*
|
|
]
|
|
[
|
|
out>>
|
|
[ request get write-request ]
|
|
with-output-stream*
|
|
] [
|
|
in>> [
|
|
read-response dup redirect?
|
|
request get redirects>> 0 > and [ t ] [
|
|
[ nip response set ]
|
|
[ read-response-body ]
|
|
[ ]
|
|
2tri f
|
|
] if
|
|
] with-input-stream*
|
|
] tri
|
|
] with-disposal
|
|
[ do-redirect ] [ nip ] if
|
|
] with-variable ; inline recursive
|
|
|
|
: <client-request> ( url method -- request )
|
|
<request>
|
|
swap >>method
|
|
swap request-url >>url ; inline
|
|
|
|
PRIVATE>
|
|
|
|
: with-http-request* ( request quot: ( chunk -- ) -- response )
|
|
[ (with-http-request) ] with-destructors ; inline
|
|
|
|
: with-http-request ( request quot: ( chunk -- ) -- response )
|
|
with-http-request* check-response ; inline
|
|
|
|
: http-request* ( request -- response data )
|
|
BV{ } clone [ '[ _ push-all ] with-http-request* ] keep
|
|
B{ } like over content-encoding>> decode [ >>body ] keep ;
|
|
|
|
: http-request ( request -- response data )
|
|
http-request* [ check-response ] dip ;
|
|
|
|
: <get-request> ( url -- request )
|
|
"GET" <client-request> ;
|
|
|
|
: http-get ( url -- response data )
|
|
<get-request> http-request ;
|
|
|
|
: http-get* ( url -- response data )
|
|
<get-request> http-request* ;
|
|
|
|
: download-name ( url -- name )
|
|
present file-name "?" split1 drop "/" ?tail drop ;
|
|
|
|
: download-to ( url file -- )
|
|
binary [
|
|
<get-request> [ write ] with-http-request drop
|
|
] with-file-writer ;
|
|
|
|
: ?download-to ( url file -- )
|
|
dup exists? [ 2drop ] [ download-to ] if ;
|
|
|
|
: download ( url -- )
|
|
dup download-name download-to ;
|
|
|
|
: <post-request> ( post-data url -- request )
|
|
"POST" <client-request>
|
|
swap >>post-data ;
|
|
|
|
: http-post ( post-data url -- response data )
|
|
<post-request> http-request ;
|
|
|
|
: http-post* ( post-data url -- response data )
|
|
<post-request> http-request* ;
|
|
|
|
: <put-request> ( post-data url -- request )
|
|
"PUT" <client-request>
|
|
swap >>post-data ;
|
|
|
|
: http-put ( post-data url -- response data )
|
|
<put-request> http-request ;
|
|
|
|
: http-put* ( post-data url -- response data )
|
|
<put-request> http-request* ;
|
|
|
|
: <delete-request> ( url -- request )
|
|
"DELETE" <client-request> ;
|
|
|
|
: http-delete ( url -- response data )
|
|
<delete-request> http-request ;
|
|
|
|
: http-delete* ( url -- response data )
|
|
<delete-request> http-request* ;
|
|
|
|
: <head-request> ( url -- request )
|
|
"HEAD" <client-request> ;
|
|
|
|
: http-head ( url -- response data )
|
|
<head-request> http-request ;
|
|
|
|
: http-head* ( url -- response data )
|
|
<head-request> http-request* ;
|
|
|
|
: <options-request> ( url -- request )
|
|
"OPTIONS" <client-request> ;
|
|
|
|
: http-options ( url -- response data )
|
|
<options-request> http-request ;
|
|
|
|
: http-options* ( url -- response data )
|
|
<options-request> http-request* ;
|
|
|
|
: <trace-request> ( url -- request )
|
|
"TRACE" <client-request> ;
|
|
|
|
: http-trace ( url -- response data )
|
|
<trace-request> http-request ;
|
|
|
|
: http-trace* ( url -- response data )
|
|
<trace-request> http-request* ;
|
|
|
|
{ "http.client" "debugger" } "http.client.debugger" require-when
|