basis/http/client/client.factor

   1 ! Copyright (C) 2005, 2010 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors ascii assocs calendar combinators.short-circuit
   4 destructors fry hashtables http http.client.post-data
   5 http.parsers io io.crlf io.encodings io.encodings.ascii
   6 io.encodings.binary io.encodings.iana io.encodings.string
   7 io.files io.pathnames io.sockets io.timeouts kernel locals math
   8 math.order math.parser mime.types namespaces present sequences
   9 splitting urls vocabs.loader ;
  10 IN: http.client
  11
  12 ERROR: too-many-redirects ;
  13
  14 <PRIVATE
  15
  16 : write-request-line ( request -- request )
  17     dup
  18     [ method>> write bl ]
  19     [ url>> relative-url present write bl ]
  20     [ "HTTP/" write version>> write crlf ]
  21     tri ;
  22
  23 : default-port? ( url -- ? )
  24     {
  25         [ port>> not ]
  26         [ [ port>> ] [ protocol>> protocol-port ] bi = ]
  27     } 1|| ;
  28
  29 : unparse-host ( url -- string )
  30     dup default-port? [ host>> ] [
  31         [ host>> ] [ port>> number>string ] bi ":" glue
  32     ] if ;
  33
  34 : set-host-header ( request header -- request header )
  35     over url>> unparse-host "host" pick set-at ;
  36
  37 : set-cookie-header ( header cookies -- header )
  38     unparse-cookie "cookie" pick set-at ;
  39
  40 : write-request-header ( request -- request )
  41     dup header>> >hashtable
  42     over url>> host>> [ set-host-header ] when
  43     over post-data>> [ set-post-data-headers ] when*
  44     over cookies>> [ set-cookie-header ] unless-empty
  45     write-header ;
  46
  47 : write-request ( request -- )
  48     unparse-post-data
  49     write-request-line
  50     write-request-header
  51     binary encode-output
  52     write-post-data
  53     flush
  54     drop ;
  55
  56 : read-response-line ( response -- response )
  57     read-?crlf parse-response-line first3
  58     [ >>version ] [ >>code ] [ >>message ] tri* ;
  59
  60 : detect-encoding ( response -- encoding )
  61     [ content-charset>> name>encoding ]
  62     [ content-type>> mime-type-encoding ] bi
  63     or ;
  64
  65 : read-response-header ( response -- response )
  66     read-header >>header
  67     dup "set-cookie" header parse-set-cookie >>cookies
  68     dup "content-type" header [
  69         parse-content-type
  70         [ >>content-type ] [ >>content-charset ] bi*
  71         dup detect-encoding >>content-encoding
  72     ] when* ;
  73
  74 : read-response ( -- response )
  75     <response>
  76     read-response-line
  77     read-response-header ;
  78
  79 DEFER: (with-http-request)
  80
  81 SYMBOL: redirects
  82
  83 : redirect-url ( request url -- request )
  84     '[ _ >url derive-url ensure-port ] change-url ;
  85
  86 : redirect? ( response -- ? )
  87     code>> 300 399 between? ;
  88
  89 :: do-redirect ( quot: ( chunk -- ) response -- response )
  90     redirects inc
  91     redirects get request get redirects>> < [
  92         request get clone
  93         response "location" header redirect-url
  94         response code>> 307 = [ "GET" >>method ] unless
  95         quot (with-http-request)
  96     ] [ too-many-redirects ] if ; inline recursive
  97
  98 : read-chunk-size ( -- n )
  99     read-crlf ";" split1 drop [ blank? ] trim-tail
 100     hex> [ "Bad chunk size" throw ] unless* ;
 101
 102 : read-chunked ( quot: ( chunk -- ) -- )
 103     read-chunk-size dup zero?
 104     [ 2drop ] [
 105         read [ swap call ] [ drop ] 2bi
 106         read-crlf B{ } assert= read-chunked
 107     ] if ; inline recursive
 108
 109 : read-response-body ( quot: ( chunk -- ) response -- )
 110     binary decode-input
 111     "transfer-encoding" header "chunked" =
 112     [ read-chunked ] [ each-block ] if ; inline
 113
 114 : <request-socket> ( -- stream )
 115     request get url>> url-addr ascii <client> drop
 116     1 minutes over set-timeout ;
 117
 118 : (with-http-request) ( request quot: ( chunk -- ) -- response )
 119     swap
 120     request [
 121         <request-socket> [
 122             [
 123                 out>>
 124                 [ request get write-request ]
 125                 with-output-stream*
 126             ] [
 127                 in>> [
 128                     read-response dup redirect?
 129                     request get redirects>> 0 > and [ t ] [
 130                         [ nip response set ]
 131                         [ read-response-body ]
 132                         [ ]
 133                         2tri f
 134                     ] if
 135                 ] with-input-stream*
 136             ] bi
 137         ] with-disposal
 138         [ do-redirect ] [ nip ] if
 139     ] with-variable ; inline recursive
 140
 141 : request-url ( url -- url' )
 142     dup >url dup protocol>> [ nip ] [
 143         drop dup url? [ present ] when
 144         "http://" prepend >url
 145     ] if ensure-port ;
 146
 147 : <client-request> ( url method -- request )
 148     <request>
 149         swap >>method
 150         swap request-url >>url ; inline
 151
 152 PRIVATE>
 153
 154 : success? ( code -- ? ) 200 299 between? ;
 155
 156 ERROR: download-failed response ;
 157
 158 : check-response ( response -- response )
 159     dup code>> success? [ download-failed ] unless ;
 160
 161 : with-http-request* ( request quot: ( chunk -- ) -- response )
 162     [ (with-http-request) ] with-destructors ; inline
 163
 164 : with-http-request ( request quot: ( chunk -- ) -- response )
 165     with-http-request* check-response ; inline
 166
 167 : http-request* ( request -- response data )
 168     BV{ } clone [ '[ _ push-all ] with-http-request* ] keep
 169     B{ } like over content-encoding>> decode [ >>body ] keep ;
 170
 171 : http-request ( request -- response data )
 172     http-request* [ check-response ] dip ;
 173
 174 : <get-request> ( url -- request )
 175     "GET" <client-request> ;
 176
 177 : http-get ( url -- response data )
 178     <get-request> http-request ;
 179
 180 : http-get* ( url -- response data )
 181     <get-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 [
 188         <get-request> [ write ] with-http-request drop
 189     ] with-file-writer ;
 190
 191 : ?download-to ( url file -- )
 192     dup exists? [ 2drop ] [ download-to ] if ;
 193
 194 : download ( url -- )
 195     dup download-name download-to ;
 196
 197 : <post-request> ( post-data url -- request )
 198     "POST" <client-request>
 199         swap >>post-data ;
 200
 201 : http-post ( post-data url -- response data )
 202     <post-request> http-request ;
 203
 204 : http-post* ( post-data url -- response data )
 205     <post-request> http-request* ;
 206
 207 : <put-request> ( post-data url -- request )
 208     "PUT" <client-request>
 209         swap >>post-data ;
 210
 211 : http-put ( post-data url -- response data )
 212     <put-request> http-request ;
 213
 214 : http-put* ( post-data url -- response data )
 215     <put-request> http-request* ;
 216
 217 : <delete-request> ( url -- request )
 218     "DELETE" <client-request> ;
 219
 220 : http-delete ( url -- response data )
 221     <delete-request> http-request ;
 222
 223 : http-delete* ( url -- response data )
 224     <delete-request> http-request* ;
 225
 226 : <head-request> ( url -- request )
 227     "HEAD" <client-request> ;
 228
 229 : http-head ( url -- response data )
 230     <head-request> http-request ;
 231
 232 : http-head* ( url -- response data )
 233     <head-request> http-request* ;
 234
 235 : <options-request> ( url -- request )
 236     "OPTIONS" <client-request> ;
 237
 238 : http-options ( url -- response data )
 239     <options-request> http-request ;
 240
 241 : http-options* ( url -- response data )
 242     <options-request> http-request* ;
 243
 244 : <trace-request> ( url -- request )
 245     "TRACE" <client-request> ;
 246
 247 : http-trace ( url -- response data )
 248     <trace-request> http-request ;
 249
 250 : http-trace* ( url -- response data )
 251     <trace-request> http-request* ;
 252
 253 { "http.client" "debugger" } "http.client.debugger" require-when