basis/http/client/client.factor

   1 ! Copyright (C) 2005, 2008 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors assocs kernel math math.parser namespaces make
   4 sequences io io.sockets io.streams.string io.files io.timeouts
   5 strings splitting calendar continuations accessors vectors
   6 math.order hashtables byte-arrays prettyprint destructors
   7 io.encodings
   8 io.encodings.string
   9 io.encodings.ascii
  10 io.encodings.8-bit
  11 io.encodings.binary
  12 io.streams.duplex
  13 fry debugger summary ascii urls urls.encoding present
  14 http http.parsers ;
  15 IN: http.client
  16
  17 : write-request-line ( request -- request )
  18     dup
  19     [ method>> write bl ]
  20     [ url>> relative-url present write bl ]
  21     [ "HTTP/" write version>> write crlf ]
  22     tri ;
  23
  24 : url-host ( url -- string )
  25     [ host>> ] [ port>> ] bi dup "http" protocol-port =
  26     [ drop ] [ ":" swap number>string 3append ] if ;
  27
  28 : write-request-header ( request -- request )
  29     dup header>> >hashtable
  30     over url>> host>> [ over url>> url-host "host" pick set-at ] when
  31     over post-data>> [
  32         [ raw>> length "content-length" pick set-at ]
  33         [ content-type>> "content-type" pick set-at ]
  34         bi
  35     ] when*
  36     over cookies>> [ unparse-cookie "cookie" pick set-at ] unless-empty
  37     write-header ;
  38
  39 GENERIC: >post-data ( object -- post-data )
  40
  41 M: post-data >post-data ;
  42
  43 M: string >post-data "application/octet-stream" <post-data> ;
  44
  45 M: byte-array >post-data "application/octet-stream" <post-data> ;
  46
  47 M: assoc >post-data assoc>query "application/x-www-form-urlencoded" <post-data> ;
  48
  49 M: f >post-data ;
  50
  51 : unparse-post-data ( request -- request )
  52     [ >post-data ] change-post-data ;
  53
  54 : write-post-data ( request -- request )
  55     dup method>> [ "POST" = ] [ "PUT" = ] bi or
  56     [ dup post-data>> [ raw>> write ] when* ] when ;
  57
  58 : write-request ( request -- )
  59     unparse-post-data
  60     write-request-line
  61     write-request-header
  62     write-post-data
  63     flush
  64     drop ;
  65
  66 : read-response-line ( response -- response )
  67     read-crlf parse-response-line first3
  68     [ >>version ] [ >>code ] [ >>message ] tri* ;
  69
  70 : read-response-header ( response -- response )
  71     read-header >>header
  72     dup "set-cookie" header parse-set-cookie >>cookies
  73     dup "content-type" header [
  74         parse-content-type
  75         [ >>content-type ]
  76         [ >>content-charset ] bi*
  77     ] when* ;
  78
  79 : read-response ( -- response )
  80     <response>
  81     read-response-line
  82     read-response-header ;
  83
  84 : max-redirects 10 ;
  85
  86 ERROR: too-many-redirects ;
  87
  88 M: too-many-redirects summary
  89     drop
  90     [ "Redirection limit of " % max-redirects # " exceeded" % ] "" make ;
  91
  92 DEFER: with-http-request
  93
  94 <PRIVATE
  95
  96 SYMBOL: redirects
  97
  98 : redirect-url ( request url -- request )
  99     '[ _ >url derive-url ensure-port ] change-url ;
 100
 101 : redirect? ( response -- ? )
 102     code>> 300 399 between? ;
 103
 104 : do-redirect ( quot: ( chunk -- ) response -- response )
 105     redirects inc
 106     redirects get max-redirects < [
 107         request get clone
 108         swap "location" header redirect-url
 109         "GET" >>method swap with-http-request
 110     ] [ too-many-redirects ] if ; inline recursive
 111
 112 : read-chunk-size ( -- n )
 113     read-crlf ";" split1 drop [ blank? ] trim-right
 114     hex> [ "Bad chunk size" throw ] unless* ;
 115
 116 : read-chunked ( quot: ( chunk -- ) -- )
 117     read-chunk-size dup zero?
 118     [ 2drop ] [
 119         read [ swap call ] [ drop ] 2bi
 120         read-crlf B{ } assert= read-chunked
 121     ] if ; inline recursive
 122
 123 : read-unchunked ( quot: ( chunk -- ) -- )
 124     8192 read-partial dup [
 125         [ swap call ] [ drop read-unchunked ] 2bi
 126     ] [ 2drop ] if ; inline recursive
 127
 128 : read-response-body ( quot response -- )
 129     binary decode-input
 130     "transfer-encoding" header "chunked" =
 131     [ read-chunked ] [ read-unchunked ] if ; inline
 132
 133 : <request-socket> ( -- stream )
 134     request get url>> url-addr ascii <client> drop
 135     1 minutes over set-timeout ;
 136
 137 PRIVATE>
 138
 139 : with-http-request ( request quot: ( chunk -- ) -- response )
 140     swap
 141     request [
 142         <request-socket> [
 143             [
 144                 out>>
 145                 [ request get write-request ]
 146                 with-output-stream*
 147             ] [
 148                 in>> [
 149                     read-response dup redirect? [ t ] [
 150                         [ nip response set ]
 151                         [ read-response-body ]
 152                         [ ]
 153                         2tri f
 154                     ] if
 155                 ] with-input-stream*
 156             ] bi
 157         ] with-disposal
 158         [ do-redirect ] [ nip ] if
 159     ] with-variable ; inline recursive
 160
 161 : success? ( code -- ? ) 200 299 between? ;
 162
 163 ERROR: download-failed response data ;
 164
 165 M: download-failed error.
 166     "HTTP request failed:" print nl
 167     [ response>> . ] [ data>> . ] bi ;
 168
 169 : check-response* ( response data -- response data )
 170     over code>> success? [ download-failed ] unless ;
 171
 172 : check-response ( response -- response )
 173     f check-response* drop ;
 174
 175 : http-request ( request -- response data )
 176     [ [ % ] with-http-request ] B{ } make
 177     over content-charset>> decode check-response* ;
 178
 179 : <client-request> ( url -- request )
 180     <request> swap >url ensure-port >>url ;
 181
 182 : <client-data-request> ( data url -- request )
 183     <client-request> swap >>post-data ;
 184
 185 : <get-request> ( url -- request )
 186     <client-request> "GET" >>method ;
 187
 188 : http-get ( url -- response data )
 189     <get-request> http-request ;
 190
 191 : with-http-get ( url quot -- response )
 192     [ <get-request> ] dip with-http-request check-response ; inline
 193
 194 : <delete-request> ( url -- request )
 195     <client-request> "DELETE" >>method ;
 196
 197 : http-delete ( url -- response data )
 198     <delete-request> http-request ;
 199
 200 : <trace-request> ( url -- request )
 201     <client-request> "TRACE" >>method ;
 202
 203 : http-trace ( url -- response data )
 204     <trace-request> http-request ;
 205
 206 : download-name ( url -- name )
 207     present file-name "?" split1 drop "/" ?tail drop ;
 208
 209 : download-to ( url file -- )
 210     binary [ [ write ] with-http-get drop ] with-file-writer ;
 211
 212 : download ( url -- )
 213     dup download-name download-to ;
 214
 215 : <post-request> ( post-data url -- request )
 216     <client-data-request> "POST" >>method ;
 217
 218 : http-post ( post-data url -- response data )
 219     <post-request> http-request ;
 220
 221 : <put-request> ( data url -- request )
 222     <client-data-request> "PUT" >>method ;
 223
 224 : http-put ( data url -- response data )
 225     <put-request> http-request ;