basis/http/client/client.factor

   1 ! Copyright (C) 2005, 2010 Slava Pestov.
   2 ! See https://factorcode.org/license.txt for BSD license.
   3 USING: accessors ascii assocs calendar combinators
   4 combinators.short-circuit destructors effects environment
   5 hashtables http http.client.post-data http.parsers io io.crlf
   6 io.encodings io.encodings.ascii io.encodings.binary
   7 io.encodings.iana io.encodings.string io.files io.pathnames
   8 io.sockets io.sockets.secure io.timeouts kernel math math.order
   9 math.parser mime.types namespaces present sequences splitting
  10 urls vocabs.loader ;
  11 IN: http.client
  12
  13 ERROR: too-many-redirects ;
  14 ERROR: invalid-proxy proxy ;
  15
  16 : success? ( code -- ? ) 200 299 between? ;
  17
  18 ERROR: download-failed response ;
  19
  20 : check-response ( response -- response )
  21     dup code>> success? [ download-failed ] unless ;
  22
  23 <PRIVATE
  24
  25 : authority-uri ( url -- str )
  26     [ host>> ] [ port>> number>string ] bi ":" glue ;
  27
  28 : absolute-uri ( url -- str )
  29     clone f >>username f >>password f >>anchor present ;
  30
  31 : abs-path-uri ( url -- str )
  32     relative-url f >>anchor present ;
  33
  34 : request-uri ( request -- str )
  35     {
  36         { [ dup proxy-url>> ] [ url>> absolute-uri ] }
  37         { [ dup method>> "CONNECT" = ] [ url>> authority-uri ] }
  38         [ url>> abs-path-uri ]
  39     } cond ;
  40
  41 : write-request-line ( request -- request )
  42     dup
  43     [ method>> write bl ]
  44     [ request-uri write bl ]
  45     [ "HTTP/" write version>> write crlf ]
  46     tri ;
  47
  48 : default-port? ( url -- ? )
  49     {
  50         [ port>> not ]
  51         [ [ port>> ] [ protocol>> protocol-port ] bi = ]
  52     } 1|| ;
  53
  54 : unparse-host ( url -- string )
  55     dup default-port? [ host>> ] [
  56         [ host>> ] [ port>> number>string ] bi ":" glue
  57     ] if ;
  58
  59 : set-host-header ( request header -- request header )
  60     over url>> unparse-host "Host" pick set-at ;
  61
  62 : set-cookie-header ( header cookies -- header )
  63     unparse-cookie "Cookie" pick set-at ;
  64
  65 : ?set-basic-auth ( header url name -- header )
  66     swap [
  67         [ username>> ] [ password>> ] bi 2dup and
  68         [ basic-auth swap pick set-at ] [ 3drop ] if
  69     ] [ drop ] if* ;
  70
  71 : write-request-header ( request -- request )
  72     dup header>> >hashtable
  73     over url>> host>> [ set-host-header ] when
  74     over url>> "Authorization" ?set-basic-auth
  75     over proxy-url>> "Proxy-Authorization" ?set-basic-auth
  76     over post-data>> [ set-post-data-headers ] when*
  77     over cookies>> [ set-cookie-header ] unless-empty
  78     write-header ;
  79
  80 : write-request ( request -- )
  81     unparse-post-data
  82     write-request-line
  83     write-request-header
  84     binary encode-output
  85     write-post-data
  86     flush
  87     drop ;
  88
  89 : read-response-line ( response -- response )
  90     read-?crlf parse-response-line first3
  91     [ >>version ] [ >>code ] [ >>message ] tri* ;
  92
  93 : detect-encoding ( response -- encoding )
  94     [ content-charset>> name>encoding ]
  95     [ content-type>> mime-type-encoding ] bi
  96     or ;
  97
  98 : read-response-header ( response -- response )
  99     read-header >>header
 100     dup "set-cookie" header parse-set-cookie >>cookies
 101     dup "content-type" header [
 102         parse-content-type
 103         [ >>content-type ] [ >>content-charset ] bi*
 104         dup detect-encoding >>content-encoding
 105     ] when* ;
 106
 107 : read-response ( -- response )
 108     <response>
 109     read-response-line
 110     read-response-header ;
 111
 112 DEFER: (with-http-request)
 113
 114 SYMBOL: redirects
 115
 116 : redirect-url ( request url -- request )
 117     '[ _ >url derive-url ensure-port ] change-url ;
 118
 119 : redirect? ( response -- ? )
 120     code>> 300 399 between? ;
 121
 122 :: do-redirect ( quot: ( chunk -- ) response -- response )
 123     redirects inc
 124     redirects get request get redirects>> < [
 125         request get clone
 126         response "location" header redirect-url
 127         response code>> 307 = [ "GET" >>method f >>post-data ] unless
 128         quot (with-http-request)
 129     ] [ too-many-redirects ] if ; inline recursive
 130
 131 : read-chunk-size ( -- n )
 132     read-crlf ";" split1 drop [ blank? ] trim-tail
 133     hex> [ "Bad chunk size" throw ] unless* ;
 134
 135 : read-chunked ( quot: ( chunk -- ) -- )
 136     read-chunk-size [ drop ] [
 137         read [ swap call ] [ drop ] 2bi
 138         read-crlf B{ } assert= read-chunked
 139     ] if-zero ; inline recursive
 140
 141 : read-response-body ( quot: ( chunk -- ) response -- )
 142     binary decode-input
 143     "transfer-encoding" header "chunked" =
 144     [ read-chunked ] [ each-block ] if ; inline
 145
 146 : request-socket-endpoints ( request -- physical logical )
 147     [ proxy-url>> ] [ url>> ] bi [ or ] keep ;
 148
 149 : <request-socket> ( -- stream )
 150     request get request-socket-endpoints [ url-addr ] bi@
 151     remote-address set ascii <client> local-address set
 152     1 minutes over set-timeout ;
 153
 154 : https-tunnel? ( request -- ? )
 155     [ proxy-url>> ] [ url>> protocol>> "https" = ] bi and ;
 156
 157 : ?copy-proxy-basic-auth ( dst-request src-request -- dst-request )
 158     proxy-url>> [ username>> ] [ password>> ] bi 2dup and
 159     [ set-proxy-basic-auth ] [ 2drop ] if ;
 160
 161 : ?https-tunnel ( -- )
 162     request get dup https-tunnel? [
 163         <request> swap [ url>> >>url ] [ ?copy-proxy-basic-auth ] bi
 164         f >>proxy-url "CONNECT" >>method write-request
 165         read-response check-response drop send-secure-handshake
 166     ] [ drop ] if ;
 167
 168 ! Note: ipv4 addresses are interpreted as subdomains but "work"
 169 : no-proxy-match? ( host-path no-proxy-path -- ? )
 170     dup first empty? [ [ rest ] bi@ ] when
 171     [ drop f ] [ tail? ] if-empty ;
 172
 173 : get-no-proxy-list ( -- list )
 174     "no_proxy" get
 175     [ "no_proxy" os-env ] unless*
 176     [ "NO_PROXY" os-env ] unless* ;
 177
 178 : no-proxy? ( request -- ? )
 179     get-no-proxy-list [
 180         [ url>> host>> "." split ] dip "," split
 181         [ "." split no-proxy-match? ] with any?
 182     ] [ drop f ] if* ;
 183
 184 : (check-proxy) ( proxy -- ? )
 185     {
 186         { [ dup URL" " = ] [ drop f ] }
 187         { [ dup host>> ] [ drop t ] }
 188         [ invalid-proxy ]
 189     } cond ;
 190
 191 : check-proxy ( request proxy -- request' )
 192     dup [ (check-proxy) ] [ f ] if*
 193     [ drop f ] unless [ clone ] dip >>proxy-url ;
 194
 195 : get-default-proxy ( request -- default-proxy )
 196     url>> protocol>> "https" = [
 197         "https.proxy" get
 198         [ "https_proxy" os-env ] unless*
 199         [ "HTTPS_PROXY" os-env ] unless*
 200     ] [
 201         "http.proxy" get
 202         [ "http_proxy" os-env ] unless*
 203         [ "HTTP_PROXY" os-env ] unless*
 204     ] if ;
 205
 206 : misparsed-url? ( url -- url' )
 207     [ protocol>> not ] [ host>> not ] [ path>> ] tri and and ;
 208
 209 : request-url ( url -- url' )
 210     dup >url dup misparsed-url? [
 211         drop dup url? [ present ] when
 212         "http://" prepend >url
 213     ] [ nip ] if ensure-port ;
 214
 215 : ?default-proxy ( request -- request' )
 216     dup get-default-proxy
 217     over proxy-url>> dup [ request-url ] when 2dup and [
 218         pick no-proxy? [ nip ] [ [ request-url ] dip derive-url ] if
 219     ] [ nip ] if check-proxy ;
 220
 221 : (with-http-request) ( request quot: ( chunk -- ) -- response )
 222     swap ?default-proxy
 223     request [
 224         <request-socket> [
 225             [
 226                 in-out [ ?https-tunnel ] with-streams*
 227             ]
 228             [
 229                 out>>
 230                 [ request get write-request ]
 231                 with-output-stream*
 232             ] [
 233                 in>> [
 234                     read-response dup redirect?
 235                     request get redirects>> 0 > and [ t ] [
 236                         [ nip response set ]
 237                         [ read-response-body ]
 238                         [ ]
 239                         2tri f
 240                     ] if
 241                 ] with-input-stream*
 242             ] tri
 243         ] with-disposal
 244         [ do-redirect ] [ nip ] if
 245     ] with-variable ; inline recursive
 246
 247 : <client-request> ( url method -- request )
 248     <request>
 249         swap >>method
 250         swap request-url >>url ; inline
 251
 252 PRIVATE>
 253
 254 : with-http-request* ( request quot: ( chunk -- ) -- response )
 255     [ (with-http-request) ] with-destructors ; inline
 256
 257 : with-http-request ( request quot: ( chunk -- ) -- response )
 258     with-http-request* check-response ; inline
 259
 260 : http-request* ( request -- response data )
 261     BV{ } clone [ '[ _ push-all ] with-http-request* ] keep
 262     B{ } like over content-encoding>> decode [ >>body ] keep ;
 263
 264 : http-request ( request -- response data )
 265     http-request* [ check-response ] dip ;
 266
 267 : <get-request> ( url -- request )
 268     "GET" <client-request> ;
 269
 270 : http-get ( url -- response data )
 271     <get-request> http-request ;
 272
 273 : http-get* ( url -- response data )
 274     <get-request> http-request* ;
 275
 276 : download-name ( url -- name )
 277     present file-name "?" split1 drop "/" ?tail drop ;
 278
 279 : download-to ( url file -- )
 280     binary [
 281         <get-request> [ write ] with-http-request drop
 282     ] with-file-writer ;
 283
 284 : ?download-to ( url file -- )
 285     dup file-exists? [ 2drop ] [ download-to ] if ;
 286
 287 : download ( url -- )
 288     dup download-name download-to ;
 289
 290 : <post-request> ( post-data url -- request )
 291     "POST" <client-request>
 292         swap >>post-data ;
 293
 294 : http-post ( post-data url -- response data )
 295     <post-request> http-request ;
 296
 297 : http-post* ( post-data url -- response data )
 298     <post-request> http-request* ;
 299
 300 : <put-request> ( post-data url -- request )
 301     "PUT" <client-request>
 302         swap >>post-data ;
 303
 304 : http-put ( post-data url -- response data )
 305     <put-request> http-request ;
 306
 307 : http-put* ( post-data url -- response data )
 308     <put-request> http-request* ;
 309
 310 : <delete-request> ( url -- request )
 311     "DELETE" <client-request> ;
 312
 313 : http-delete ( url -- response data )
 314     <delete-request> http-request ;
 315
 316 : http-delete* ( url -- response data )
 317     <delete-request> http-request* ;
 318
 319 : <head-request> ( url -- request )
 320     "HEAD" <client-request> ;
 321
 322 : http-head ( url -- response data )
 323     <head-request> http-request ;
 324
 325 : http-head* ( url -- response data )
 326     <head-request> http-request* ;
 327
 328 : <options-request> ( url -- request )
 329     "OPTIONS" <client-request> ;
 330
 331 : http-options ( url -- response data )
 332     <options-request> http-request ;
 333
 334 : http-options* ( url -- response data )
 335     <options-request> http-request* ;
 336
 337 : <patch-request> ( url -- request )
 338     "PATCH" <client-request> ;
 339
 340 : http-patch ( url -- response data )
 341     <patch-request> http-request ;
 342
 343 : http-patch* ( url -- response data )
 344     <patch-request> http-request* ;
 345
 346 : <trace-request> ( url -- request )
 347     "TRACE" <client-request> ;
 348
 349 : http-trace ( url -- response data )
 350     <trace-request> http-request ;
 351
 352 : http-trace* ( url -- response data )
 353     <trace-request> http-request* ;
 354
 355 { "http.client" "debugger" } "http.client.debugger" require-when