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
   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 prettyprint
   7 io.encodings
   8 io.encodings.string
   9 io.encodings.ascii
  10 io.encodings.8-bit
  11 io.encodings.binary
  12 io.streams.duplex
  13 fry debugger summary ascii urls present
  14 http http.parsers ;
  15 IN: http.client
  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 : write-request-header ( request -- request )
  29     dup header>> >hashtable
  30     over url>> host>> [ over url>> url-host "host" pick set-at ] when
  31     over post-data>> [
  32         [ raw>> length "content-length" pick set-at ]
  33         [ content-type>> "content-type" pick set-at ]
  34         bi
  35     ] when*
  36     over cookies>> f like [ unparse-cookie "cookie" pick set-at ] when*
  37     write-header ;
  38
  39 GENERIC: >post-data ( object -- post-data )
  40
  41 M: post-data >post-data ;
  42
  43 M: string >post-data "application/octet-stream" <post-data> ;
  44
  45 M: byte-array >post-data "application/octet-stream" <post-data> ;
  46
  47 M: assoc >post-data assoc>query "application/x-www-form-urlencoded" <post-data> ;
  48
  49 M: f >post-data ;
  50
  51 : unparse-post-data ( request -- request )
  52     [ >post-data ] change-post-data ;
  53
  54 : write-post-data ( request -- request )
  55     dup method>> "POST" = [ dup post-data>> raw>> write ] when ;
  56
  57 : write-request ( request -- )
  58     unparse-post-data
  59     write-request-line
  60     write-request-header
  61     write-post-data
  62     flush
  63     drop ;
  64
  65 : read-response-line ( response -- response )
  66     read-crlf parse-response-line first3
  67     [ >>version ] [ >>code ] [ >>message ] tri* ;
  68
  69 : read-response-header ( response -- response )
  70     read-header >>header
  71     dup "set-cookie" header parse-set-cookie >>cookies
  72     dup "content-type" header [
  73         parse-content-type
  74         [ >>content-type ]
  75         [ >>content-charset ] bi*
  76     ] when* ;
  77
  78 : read-response ( -- response )
  79     <response>
  80     read-response-line
  81     read-response-header ;
  82
  83 : max-redirects 10 ;
  84
  85 ERROR: too-many-redirects ;
  86
  87 M: too-many-redirects summary
  88     drop
  89     [ "Redirection limit of " % max-redirects # " exceeded" % ] "" make ;
  90
  91 DEFER: (http-request)
  92
  93 <PRIVATE
  94
  95 SYMBOL: redirects
  96
  97 : redirect-url ( request url -- request )
  98     '[ , >url derive-url ensure-port ] change-url ;
  99
 100 : do-redirect ( response data -- response data )
 101     over code>> 300 399 between? [
 102         drop
 103         redirects inc
 104         redirects get max-redirects < [
 105             request get
 106             swap "location" header redirect-url
 107             "GET" >>method (http-request)
 108         ] [
 109             too-many-redirects
 110         ] if
 111     ] when ;
 112
 113 PRIVATE>
 114
 115 : read-chunk-size ( -- n )
 116     read-crlf ";" split1 drop [ blank? ] trim-right
 117     hex> [ "Bad chunk size" throw ] unless* ;
 118
 119 : read-chunks ( -- )
 120     read-chunk-size dup zero?
 121     [ drop ] [ read % read-crlf B{ } assert= read-chunks ] if ;
 122
 123 : read-response-body ( response -- response data )
 124     dup "transfer-encoding" header "chunked" = [
 125         binary decode-input
 126         [ read-chunks ] B{ } make
 127         over content-charset>> decode
 128     ] [
 129         dup content-charset>> decode-input
 130         input-stream get contents
 131     ] if ;
 132
 133 : (http-request) ( request -- response data )
 134     dup request [
 135         dup url>> url-addr ascii [
 136             1 minutes timeouts
 137             write-request
 138             read-response
 139             read-response-body
 140         ] with-client
 141         do-redirect
 142     ] with-variable ;
 143
 144 : success? ( code -- ? ) 200 = ;
 145
 146 ERROR: download-failed response body ;
 147
 148 M: download-failed error.
 149     "HTTP download failed:" print nl
 150     [ response>> . nl ] [ body>> write ] bi ;
 151
 152 : check-response ( response data -- response data )
 153     over code>> success? [ download-failed ] unless ;
 154
 155 : http-request ( request -- response data )
 156     (http-request) check-response ;
 157
 158 : <get-request> ( url -- request )
 159     <request>
 160         "GET" >>method
 161         swap >url ensure-port >>url ;
 162
 163 : http-get ( url -- response data )
 164     <get-request> http-request ;
 165
 166 : download-name ( url -- name )
 167     present file-name "?" split1 drop "/" ?tail drop ;
 168
 169 : download-to ( url file -- )
 170     #! Downloads the contents of a URL to a file.
 171     swap http-get
 172     [ content-charset>> ] [ '[ , write ] ] bi*
 173     with-file-writer ;
 174
 175 : download ( url -- )
 176     dup download-name download-to ;
 177
 178 : <post-request> ( post-data url -- request )
 179     <request>
 180         "POST" >>method
 181         swap >url ensure-port >>url
 182         swap >>post-data ;
 183
 184 : http-post ( post-data url -- response data )
 185     <post-request> http-request ;