basis/http/client/client.factor

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