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