basis/http/client/client.factor

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