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