extra/http/client/client.factor

   1 ! Copyright (C) 2005, 2008 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: assocs http kernel math math.parser namespaces sequences
   4 io io.sockets io.streams.string io.files io.timeouts strings
   5 splitting calendar continuations accessors vectors math.order
   6 io.encodings
   7 io.encodings.string
   8 io.encodings.ascii
   9 io.encodings.8-bit
  10 io.encodings.binary
  11 io.streams.duplex
  12 fry debugger summary ascii urls present ;
  13 IN: http.client
  14
  15 : max-redirects 10 ;
  16
  17 ERROR: too-many-redirects ;
  18
  19 M: too-many-redirects summary
  20     drop
  21     [ "Redirection limit of " % max-redirects # " exceeded" % ] "" make ;
  22
  23 DEFER: (http-request)
  24
  25 <PRIVATE
  26
  27 SYMBOL: redirects
  28
  29 : redirect-url ( request url -- request )
  30     '[ , >url ensure-port derive-url ensure-port ] change-url ;
  31
  32 : do-redirect ( response data -- response data )
  33     over code>> 300 399 between? [
  34         drop
  35         redirects inc
  36         redirects get max-redirects < [
  37             request get
  38             swap "location" header redirect-url
  39             "GET" >>method (http-request)
  40         ] [
  41             too-many-redirects
  42         ] if
  43     ] when ;
  44
  45 PRIVATE>
  46
  47 : read-chunk-size ( -- n )
  48     read-crlf ";" split1 drop [ blank? ] right-trim
  49     hex> [ "Bad chunk size" throw ] unless* ;
  50
  51 : read-chunks ( -- )
  52     read-chunk-size dup zero?
  53     [ drop ] [ read % read-crlf B{ } assert= read-chunks ] if ;
  54
  55 : read-response-body ( response -- response data )
  56     dup "transfer-encoding" header "chunked" = [
  57         binary decode-input
  58         [ read-chunks ] B{ } make
  59         over content-charset>> decode
  60     ] [
  61         dup content-charset>> decode-input
  62         input-stream get contents
  63     ] if ;
  64
  65 : (http-request) ( request -- response data )
  66     dup request [
  67         dup url>> url-addr ascii [
  68             1 minutes timeouts
  69             write-request
  70             read-response
  71             read-response-body
  72         ] with-client
  73         do-redirect
  74     ] with-variable ;
  75
  76 : success? ( code -- ? ) 200 = ;
  77
  78 ERROR: download-failed response body ;
  79
  80 M: download-failed error.
  81     "HTTP download failed:" print nl
  82     [ response>> write-response-line nl drop ]
  83     [ body>> write ]
  84     bi ;
  85
  86 : check-response ( response data -- response data )
  87     over code>> success? [ download-failed ] unless ;
  88
  89 : http-request ( request -- response data )
  90     (http-request) check-response ;
  91
  92 : <get-request> ( url -- request )
  93     <request>
  94         "GET" >>method
  95         swap >url ensure-port >>url ;
  96
  97 : http-get ( url -- response data )
  98     <get-request> http-request ;
  99
 100 : download-name ( url -- name )
 101     present file-name "?" split1 drop "/" ?tail drop ;
 102
 103 : download-to ( url file -- )
 104     #! Downloads the contents of a URL to a file.
 105     swap http-get
 106     [ content-charset>> ] [ '[ , write ] ] bi*
 107     with-file-writer ;
 108
 109 : download ( url -- )
 110     dup download-name download-to ;
 111
 112 : <post-request> ( post-data url -- request )
 113     <request>
 114         "POST" >>method
 115         swap >url ensure-port >>url
 116         swap >>post-data ;
 117
 118 : http-post ( post-data url -- response data )
 119     <post-request> http-request ;