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