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 [ dup post-data>> raw>> write ] when ;
  57
  58 : write-request ( request -- )
  59     unparse-post-data
  60     write-request-line
  61     write-request-header
  62     binary encode-output
  63     write-post-data
  64     flush
  65     drop ;
  66
  67 : read-response-line ( response -- response )
  68     read-crlf parse-response-line first3
  69     [ >>version ] [ >>code ] [ >>message ] tri* ;
  70
  71 : read-response-header ( response -- response )
  72     read-header >>header
  73     dup "set-cookie" header parse-set-cookie >>cookies
  74     dup "content-type" header [
  75         parse-content-type
  76         [ >>content-type ]
  77         [ >>content-charset ] bi*
  78     ] when* ;
  79
  80 : read-response ( -- response )
  81     <response>
  82     read-response-line
  83     read-response-header ;
  84
  85 : max-redirects 10 ;
  86
  87 ERROR: too-many-redirects ;
  88
  89 <PRIVATE
  90
  91 DEFER: (with-http-request)
  92
  93 SYMBOL: redirects
  94
  95 : redirect-url ( request url -- request )
  96     '[ _ >url derive-url ensure-port ] change-url ;
  97
  98 : redirect? ( response -- ? )
  99     code>> 300 399 between? ;
 100
 101 : do-redirect ( quot: ( chunk -- ) response -- response )
 102     redirects inc
 103     redirects get max-redirects < [
 104         request get clone
 105         swap "location" header redirect-url
 106         "GET" >>method swap (with-http-request)
 107     ] [ too-many-redirects ] if ; inline recursive
 108
 109 : read-chunk-size ( -- n )
 110     read-crlf ";" split1 drop [ blank? ] trim-right
 111     hex> [ "Bad chunk size" throw ] unless* ;
 112
 113 : read-chunked ( quot: ( chunk -- ) -- )
 114     read-chunk-size dup zero?
 115     [ 2drop ] [
 116         read [ swap call ] [ drop ] 2bi
 117         read-crlf B{ } assert= read-chunked
 118     ] if ; inline recursive
 119
 120 : read-unchunked ( quot: ( chunk -- ) -- )
 121     8192 read-partial dup [
 122         [ swap call ] [ drop read-unchunked ] 2bi
 123     ] [ 2drop ] if ; inline recursive
 124
 125 : read-response-body ( quot response -- )
 126     binary decode-input
 127     "transfer-encoding" header "chunked" =
 128     [ read-chunked ] [ read-unchunked ] if ; inline
 129
 130 : <request-socket> ( -- stream )
 131     request get url>> url-addr ascii <client> drop
 132     1 minutes over set-timeout ;
 133
 134 : (with-http-request) ( request quot: ( chunk -- ) -- response )
 135     swap
 136     request [
 137         <request-socket> [
 138             [
 139                 out>>
 140                 [ request get write-request ]
 141                 with-output-stream*
 142             ] [
 143                 in>> [
 144                     read-response dup redirect? [ t ] [
 145                         [ nip response set ]
 146                         [ read-response-body ]
 147                         [ ]
 148                         2tri f
 149                     ] if
 150                 ] with-input-stream*
 151             ] bi
 152         ] with-disposal
 153         [ do-redirect ] [ nip ] if
 154     ] with-variable ; inline recursive
 155
 156 PRIVATE>
 157
 158 : success? ( code -- ? ) 200 299 between? ;
 159
 160 ERROR: download-failed response ;
 161
 162 : check-response ( response -- response )
 163     dup code>> success? [ download-failed ] unless ;
 164
 165 : with-http-request ( request quot -- response )
 166     (with-http-request) check-response ; inline
 167
 168 : http-request ( request -- response data )
 169     [ [ % ] with-http-request ] B{ } make
 170     over content-charset>> decode ;
 171
 172 : <get-request> ( url -- request )
 173     <request>
 174         "GET" >>method
 175         swap >url ensure-port >>url ;
 176
 177 : http-get ( url -- response data )
 178     <get-request> http-request ;
 179
 180 : with-http-get ( url quot -- response )
 181     [ <get-request> ] dip with-http-request ; inline
 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 drop ] with-file-writer ;
 188
 189 : download ( url -- )
 190     dup download-name download-to ;
 191
 192 : <post-request> ( post-data url -- request )
 193     <request>
 194         "POST" >>method
 195         swap >url ensure-port >>url
 196         swap >>post-data ;
 197
 198 : http-post ( post-data url -- response data )
 199     <post-request> http-request ;
 200
 201 USING: vocabs vocabs.loader ;
 202
 203 "debugger" vocab [ "http.client.debugger" require ] when