1;;; http-client.scm: http client library for uim. 2;;; 3;;; Copyright (c) 2009-2013 uim Project https://github.com/uim/uim 4;;; 5;;; All rights reserved. 6;;; 7;;; Redistribution and use in source and binary forms, with or without 8;;; modification, are permitted provided that the following conditions 9;;; are met: 10;;; 1. Redistributions of source code must retain the above copyright 11;;; notice, this list of conditions and the following disclaimer. 12;;; 2. Redistributions in binary form must reproduce the above copyright 13;;; notice, this list of conditions and the following disclaimer in the 14;;; documentation and/or other materials provided with the distribution. 15;;; 3. Neither the name of authors nor the names of its contributors 16;;; may be used to endorse or promote products derived from this software 17;;; without specific prior written permission. 18;;; 19;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ``AS IS'' AND 20;;; ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 21;;; IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 22;;; ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR CONTRIBUTORS BE LIABLE 23;;; FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 24;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 25;;; OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) 26;;; HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT 27;;; LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY 28;;; OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF 29;;; SUCH DAMAGE. 30;;;; 31 32(require-extension (srfi 1 2 9)) 33(require "i18n.scm") 34(require "socket.scm") 35(require "input-parse.scm") 36(require "openssl.scm") 37 38(define (http:encode-uri-string str) 39 (define hex '("0" "1" "2" "3" "4" "5" "6" "7" "8" "9" "A" "B" "C" "D" "E" "F")) 40 (define (hex-format2 x) 41 (string-append "%" 42 (list-ref hex (modulo (/ x 16) 256)) 43 (list-ref hex (modulo x 16)))) 44 (apply 45 string-append 46 (map (lambda (c) 47 (hex-format2 (char->integer c))) 48 (string->list str)))) 49 50(define (http:read-chunk port) 51 (define (hex-decode str) 52 (define hex-alist '((#\0 . 0) (#\1 . 1) (#\2 . 2) (#\3 . 3) (#\4 . 4) 53 (#\5 . 5) (#\6 . 6) (#\7 . 7) (#\8 . 8) (#\9 . 9) 54 (#\a . 10) (#\A . 10) (#\b . 11) (#\B . 11) 55 (#\c . 12) (#\C . 12) (#\d . 13) (#\D . 13) 56 (#\e . 14) (#\E . 14) (#\f . 15) (#\F . 15))) 57 (let ((n (reverse 58 (map (lambda (c) 59 (assq-cdr c hex-alist)) 60 (string->list str))))) 61 (let loop ((l n) 62 (sum 0)) 63 (if (null? l) 64 sum 65 (loop (map (lambda (x) (* 16 x)) (cdr l)) 66 (+ sum (car l))))))) 67 (define (http:drop-cr line) 68 (apply string-append (string-split line "\r"))) 69 (define (http:drop-space line) 70 (apply string-append (string-split line " "))) 71 72 (let loop ((len-str (http:drop-space (http:drop-cr (file-read-line port)))) 73 (rest '())) 74 (let ((len (guard (err 75 (else #f)) 76 (hex-decode len-str)))) 77 (if (or (not len) (= len 0)) 78 (apply string-append (reverse rest)) 79 (let ((buf (file-read-buffer port len))) 80 (file-read-line port) ;; blank 81 (loop (http:drop-cr (file-read-line port)) (cons buf rest))))))) 82 83(define (http:header-field-search l h) 84 (find (lambda (x) 85 (and (string? (car x)) 86 (string-ci=? (car x) h))) l)) 87 88(define (http:chunked? l) 89 (and-let* ((f (http:header-field-search l "transfer-encoding")) 90 (l (string-split (cdr f) ";")) 91 (ent (find (lambda (ent) 92 (string=? "chunked" ent)) 93 l))) 94 #t)) 95(define (http:content-length? l) 96 (and-let* ((ret (http:header-field-search l "content-length"))) 97 (guard (err 98 (else #f)) 99 (string->number (cdr ret))))) 100 101(define (http:parse-header lines) 102 (let loop ((lines lines) 103 (state '(status header)) 104 (rest '())) 105 (if (null? lines) 106 (reverse rest) 107 (call-with-input-string 108 (car lines) 109 (lambda (port) 110 (cond ((eq? 'status (car state)) 111 (let ((version 112 (find-string-from-port? 113 "HTTP/" 114 port)) 115 (version-number 116 (next-token '(#\space #\.) '(#\space) (N_ "Invalid header") 117 port)) 118 (status-code 119 (next-token '(#\space) '(#\space) (N_ "Invalid header") port)) 120 (reason-phrase 121 (next-token '(#\space) '(#\return *eof*) (N_ "Invalid header") port))) 122 (loop (cdr lines) 123 (cdr state) 124 (cons (cons 'header 125 (list (cons 'version-number version-number) 126 (cons 'status-code status-code) 127 (cons 'reason-phrase reason-phrase))) 128 rest)))) 129 ((eq? 'header (car state)) 130 (let ((field-name 131 (next-token '(#\space #\tab) '(#\:) (N_ "Invalid header") port)) 132 (field-value 133 (next-token '(#\: #\space #\tab) '(#\return *eof*) (N_ "Invalid header") port))) 134 (loop (cdr lines) 135 state 136 (cons (cons field-name field-value) rest)))))))))) 137 138(define (http:read-header port) 139 (let loop ((str (file-read-line port)) 140 (rest '())) 141 (if (or (eof-object? str) 142 (null? str) 143 (string=? "\r" str)) 144 (reverse rest) 145 (loop (file-read-line port) (cons str rest))))) 146 147(define (http:make-request-string request-alist) 148 (string-append 149 (apply 150 string-append 151 (map (lambda (ent) 152 (string-append (car ent) ": " (cdr ent) "\n")) 153 (append request-alist))) 154 "\n")) 155 156(define-record-type http-proxy 157 (make-http-proxy hostname port) http-proxy? 158 (hostname hostname? hostname!) 159 (port port? port!)) 160 161(define (make-http-proxy-from-custom) 162 (and (eq? http-proxy-setting 'user) 163 (make-http-proxy http-proxy-hostname http-proxy-port))) 164 165(define-record-type http-ssl 166 (make-http-ssl method port) http-ssl? 167 (method method? method!) 168 (port port? port!)) 169 170(define (http:make-proxy-request-string hostname port) 171 (string-append 172 (format "CONNECT ~a:~d HTTP/1.1\n\n" hostname port))) 173 174(define (http:make-get-request-string hostname path servname proxy request-alist) 175 (string-append 176 (if proxy 177 (http:make-proxy-request-string hostname servname) 178 "") 179 (format "GET ~a HTTP/1.1\n" path) 180 (format "Host: ~a\n" hostname) 181 (format "User-Agent: uim/~a\n" (uim-version)) 182 (http:make-request-string request-alist))) 183 184(define (http:get hostname path . args) 185 (let-optionals* args ((servname 80) 186 (proxy #f) 187 (ssl #f) 188 (request-alist '())) 189 (let* ((with-ssl? (and (provided? "openssl") 190 (http-ssl? ssl) 191 (method? ssl))) 192 (call-with-open-file-port-function 193 (if with-ssl? 194 ;; cut 195 (lambda (file thunk) 196 (call-with-open-openssl-file-port file (method? ssl) thunk)) 197 call-with-open-file-port)) 198 (file (if (http-proxy? proxy) 199 (tcp-connect (hostname? proxy) (port? proxy)) 200 (if with-ssl? 201 (tcp-connect hostname (port? ssl)) 202 (tcp-connect hostname servname))))) 203 (if (not file) 204 (uim-notify-fatal (N_ "cannot connect server"))) 205 (call-with-open-file-port-function 206 file 207 (lambda (port) 208 (and-let* ((request (http:make-get-request-string hostname path servname proxy request-alist)) 209 (nr (file-display request port)) 210 (ready? (file-ready? (list (fd? port)) http-timeout)) 211 (proxy-header (if proxy 212 (http:read-header port) 213 '())) 214 (header (http:read-header port)) 215 (parsed-header (http:parse-header header))) 216 (let ((content-length (http:content-length? parsed-header))) 217 (cond (content-length 218 (file-read-buffer port content-length)) 219 ((http:chunked? parsed-header) 220 (http:read-chunk port)) 221 (else 222 (file-get-buffer port)))))))))) 223 224