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 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
  11 vocabs.loader ;
  12 IN: http.client
  13
  14 ERROR: too-many-redirects ;
  15 ERROR: invalid-proxy proxy ;
  16
  17 : success? ( code -- ? ) 200 299 between? ;
  18
  19 ERROR: download-failed response ;
  20
  21 : check-response ( response -- response )
  22     dup code>> success? [ download-failed ] unless ;
  23
  24 <PRIVATE
  25
  26 : authority-uri ( url -- str )
  27     [ host>> ] [ port>> number>string ] bi ":" glue ;
  28
  29 : absolute-uri ( url -- str )
  30     clone f >>username f >>password f >>anchor present ;
  31
  32 : abs-path-uri ( url -- str )
  33     relative-url f >>anchor present ;
  34
  35 : request-uri ( request -- str )
  36     {
  37         { [ dup proxy-url>> ] [ url>> absolute-uri ] }
  38         { [ dup method>> "CONNECT" = ] [ url>> authority-uri ] }
  39         [ url>> abs-path-uri ]
  40     } cond ;
  41
  42 : write-request-line ( request -- request )
  43     dup
  44     [ method>> write bl ]
  45     [ request-uri write bl ]
  46     [ "HTTP/" write version>> write crlf ]
  47     tri ;
  48
  49 : default-port? ( url -- ? )
  50     {
  51         [ port>> not ]
  52         [ [ port>> ] [ protocol>> lookup-protocol-port ] bi = ]
  53     } 1|| ;
  54
  55 : unparse-host ( url -- string )
  56     dup default-port? [ host>> ] [
  57         [ host>> ] [ port>> number>string ] bi ":" glue
  58     ] if ;
  59
  60 : set-host-header ( request header -- request header )
  61     over url>> unparse-host "Host" pick set-at ;
  62
  63 : set-cookie-header ( header cookies -- header )
  64     unparse-cookie "Cookie" pick set-at ;
  65
  66 : ?set-basic-auth ( header url name -- header )
  67     swap [
  68         [ username>> ] [ password>> ] bi 2dup and
  69         [ basic-auth swap pick set-at ] [ 3drop ] if
  70     ] [ drop ] if* ;
  71
  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
  79     write-header ;
  80
  81 : write-request ( request -- )
  82     unparse-post-data
  83     write-request-line
  84     write-request-header
  85     binary encode-output
  86     write-post-data
  87     flush
  88     drop ;
  89
  90 : read-response-line ( response -- response )
  91     read-?crlf parse-response-line first3
  92     [ >>version ] [ >>code ] [ >>message ] tri* ;
  93
  94 : detect-encoding ( response -- encoding )
  95     [ content-charset>> name>encoding ]
  96     [ content-type>> mime-type-encoding ] bi
  97     or ;
  98
  99 : read-response-header ( response -- response )
 100     read-header >>header
 101     dup "set-cookie" header parse-set-cookie >>cookies
 102     dup "content-type" header [
 103         parse-content-type
 104         [ >>content-type ] [ >>content-charset ] bi*
 105         dup detect-encoding >>content-encoding
 106     ] when* ;
 107
 108 : read-response ( -- response )
 109     <response>
 110     read-response-line
 111     read-response-header ;
 112
 113 SYMBOL: redirects
 114
 115 : redirect-url ( request url -- request )
 116     '[ _ >url derive-url ensure-port ] change-url ;
 117
 118 : redirect? ( response -- ? )
 119     code>> 300 399 between? ;
 120
 121 :: prepare-redirect ( response -- response )
 122     redirects inc
 123     redirects get request get redirects>> < [
 124         request get clone
 125         response "location" header redirect-url
 126         response code>> 307 = [ "GET" >>method f >>post-data ] unless
 127     ] [ too-many-redirects ] if ; inline recursive
 128
 129 : read-chunk-size ( -- n )
 130     read-crlf ";" split1 drop [ blank? ] trim-tail
 131     hex> [ "Bad chunk size" throw ] unless* ;
 132
 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
 138
 139 : read-response-body ( quot: ( chunk -- ) response -- )
 140     binary decode-input
 141     "transfer-encoding" header "chunked" =
 142     [ read-chunked ] [ each-block ] if ; inline
 143
 144 : request-socket-endpoints ( request -- physical logical )
 145     [ proxy-url>> ] [ url>> ] bi [ or ] keep ;
 146
 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 ;
 151
 152 : https-tunnel? ( request -- ? )
 153     [ proxy-url>> ] [ url>> protocol>> "https" = ] bi and ;
 154
 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 ;
 158
 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
 164     ] [ drop ] if ;
 165
 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 ;
 170
 171 : get-no-proxy-list ( -- list )
 172     "no_proxy" get
 173     [ "no_proxy" os-env ] unless*
 174     [ "NO_PROXY" os-env ] unless* ;
 175
 176 : no-proxy? ( request -- ? )
 177     get-no-proxy-list [
 178         [ url>> host>> "." split ] dip "," split
 179         [ "." split no-proxy-match? ] with any?
 180     ] [ drop f ] if* ;
 181
 182 : (check-proxy) ( proxy -- ? )
 183     {
 184         { [ dup URL" " = ] [ drop f ] }
 185         { [ dup host>> ] [ drop t ] }
 186         [ invalid-proxy ]
 187     } cond ;
 188
 189 : check-proxy ( request proxy -- request' )
 190     dup [ (check-proxy) ] [ f ] if*
 191     [ drop f ] unless [ clone ] dip >>proxy-url ;
 192
 193 : get-default-proxy ( request -- default-proxy )
 194     url>> protocol>> "https" = [
 195         "https.proxy" get
 196         [ "https_proxy" os-env ] unless*
 197         [ "HTTPS_PROXY" os-env ] unless*
 198     ] [
 199         "http.proxy" get
 200         [ "http_proxy" os-env ] unless*
 201         [ "HTTP_PROXY" os-env ] unless*
 202     ] if ;
 203
 204 : misparsed-url? ( url -- url' )
 205     [ protocol>> not ] [ host>> not ] [ path>> ] tri and and ;
 206
 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 ;
 212
 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 ;
 218
 219 : upgrade-to-websocket? ( response -- ? )
 220     {
 221         [ response? ]
 222         [ code>> 101 = ]
 223         [ message>> >lower "switching protocols" = ]
 224         [ header>> "connection" of "upgrade" = ]
 225         [ header>> "upgrade" of "websocket" = ]
 226     } 1&& ;
 227
 228 PRIVATE>
 229
 230 SYMBOL: request-socket
 231
 232 : do-http-request ( request quot: ( chunk -- ) -- response/stream )
 233     [ ?default-proxy \ request ] dip dup '[
 234         [
 235             <request-socket> |dispose
 236             dup request-socket set
 237             [
 238                 [ in>> ] [ out>> ] bi [ ?https-tunnel ] with-streams*
 239             ]
 240             [
 241                 out>>
 242                 [ request get write-request ]
 243                 with-output-stream*
 244             ]
 245             [
 246                 in>> [
 247                     read-response
 248                     dup redirect?
 249                     request get redirects>> 0 > and [
 250                         request-socket get dispose
 251                         prepare-redirect _ do-http-request
 252                     ] [
 253                         dup upgrade-to-websocket?
 254                         [ drop request-socket get ]
 255                         [
 256                             [ _ ] dip [ read-response-body ] keep
 257                             request-socket get dispose
 258                         ] if
 259                     ] if
 260                 ] with-input-stream*
 261             ] tri
 262         ] with-destructors
 263     ] with-variable ; inline recursive
 264
 265 : add-default-headers ( request -- request )
 266     dup url>> protocol>> {
 267         { [ dup { "ws" "wss" } member? ] [ drop add-websocket-upgrade-headers ] }
 268         [ drop ]
 269     } cond ;
 270
 271 : <client-request> ( url method -- request )
 272     <request>
 273         swap >>method
 274         swap request-url >>url
 275         add-default-headers ; inline
 276
 277 : with-http-request ( request quot: ( chunk -- ) -- response/stream )
 278     do-http-request check-response ; inline
 279
 280 : http-request* ( request -- response data )
 281     BV{ } clone [ '[ _ push-all ] do-http-request ] keep
 282     B{ } like over content-encoding>> decode [ >>body ] keep ;
 283
 284 : http-request ( request -- response data )
 285     http-request* [ check-response ] dip ;
 286
 287 : <get-request> ( url -- request )
 288     "GET" <client-request> ;
 289
 290 : http-get ( url -- response data )
 291     <get-request> http-request ;
 292
 293 : http-get* ( url -- response data )
 294     <get-request> http-request* ;
 295
 296 : <post-request> ( post-data url -- request )
 297     "POST" <client-request>
 298         swap >>post-data ;
 299
 300 : http-post ( post-data url -- response data )
 301     <post-request> http-request ;
 302
 303 : http-post* ( post-data url -- response data )
 304     <post-request> http-request* ;
 305
 306 : <put-request> ( post-data url -- request )
 307     "PUT" <client-request>
 308         swap >>post-data ;
 309
 310 : http-put ( post-data url -- response data )
 311     <put-request> http-request ;
 312
 313 : http-put* ( post-data url -- response data )
 314     <put-request> http-request* ;
 315
 316 : <delete-request> ( url -- request )
 317     "DELETE" <client-request> ;
 318
 319 : http-delete ( url -- response data )
 320     <delete-request> http-request ;
 321
 322 : http-delete* ( url -- response data )
 323     <delete-request> http-request* ;
 324
 325 : <head-request> ( url -- request )
 326     "HEAD" <client-request> ;
 327
 328 : http-head ( url -- response data )
 329     <head-request> http-request ;
 330
 331 : http-head* ( url -- response data )
 332     <head-request> http-request* ;
 333
 334 : <options-request> ( url -- request )
 335     "OPTIONS" <client-request> ;
 336
 337 : http-options ( url -- response data )
 338     <options-request> http-request ;
 339
 340 : http-options* ( url -- response data )
 341     <options-request> http-request* ;
 342
 343 : <patch-request> ( patch-data url -- request )
 344     "PATCH" <client-request>
 345         swap >>post-data ;
 346
 347 : http-patch ( patch-data url -- response data )
 348     <patch-request> http-request ;
 349
 350 : http-patch* ( patch-data url -- response data )
 351     <patch-request> http-request* ;
 352
 353 : <trace-request> ( url -- request )
 354     "TRACE" <client-request> ;
 355
 356 : http-trace ( url -- response data )
 357     <trace-request> http-request ;
 358
 359 : http-trace* ( url -- response data )
 360     <trace-request> http-request* ;
 361
 362 { "http.client" "debugger" } "http.client.debugger" require-when