1;;; -*- mode:scheme;coding:utf-8 -*-
2;;;
3;;; net/http-client/http1.scm - HTTP/1.1 engine for HTTP client
4;;;
5;;;   Copyright (c) 2021  Takashi Kato  <ktakashi@ymail.com>
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;;;
11;;;   1. Redistributions of source code must retain the above copyright
12;;;      notice, this list of conditions and the following disclaimer.
13;;;
14;;;   2. Redistributions in binary form must reproduce the above copyright
15;;;      notice, this list of conditions and the following disclaimer in the
16;;;      documentation and/or other materials provided with the distribution.
17;;;
18;;;   THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
19;;;   "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
20;;;   LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
21;;;   A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
22;;;   OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
23;;;   SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED
24;;;   TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
25;;;   PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
26;;;   LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
27;;;   NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
28;;;   SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
29;;;
30
31#!nounbound
32#!read-macro=sagittarius/bv-string
33#!read-macro=sagittarius/regex
34(library (net http-client http1)
35    (export http1-connection-context?
36	    socket->http1-connection)
37    (import (rnrs)
38	    (net http-client connection)
39	    (net http-client request)
40	    (net uri)
41	    (sagittarius regex)
42	    (rfc :5322)
43	    (srfi :13 strings)
44	    (prefix (binary io) binary:)
45	    (util bytevector))
46
47(define-record-type http1-connection-context
48  (parent <http-connection-context>)
49  (fields requests
50	  buffer)
51  (protocol (lambda (n)
52	      (lambda ()
53		((n) (make-eq-hashtable) (make-bytevector 4096))))))
54
55(define (make-http1-connection socket socket-option node service)
56  (make-http-connection node service socket-option socket
57			http1-request http1-response
58			(make-http1-connection-context)))
59
60(define (socket->http1-connection socket socket-option node service)
61  (make-http1-connection socket socket-option node service))
62
63(define (http1-request connection request header-handler data-handler)
64  (define context (http-connection-context-data connection))
65  ;; here we only push the request
66  (hashtable-set! (http1-connection-context-requests context)
67		  request (list header-handler data-handler)))
68
69(define (http1-response connection)
70  (define context (http-connection-context-data connection))
71  (define requests (http1-connection-context-requests context))
72  (define (handle-requests connection requests)
73    (let-values (((keys values) (hashtable-entries requests)))
74      (vector-map (lambda (request handlers)
75		    (apply http1-resquest/response connection request handlers))
76		  keys values)))
77  (let ((results (handle-requests connection requests)))
78    (hashtable-clear! requests)
79    ;; TODO check reconnectability
80    (fold-left (lambda (acc conn) (and acc conn)) #t (vector->list results))))
81
82(define (http1-resquest/response connection request header-handler data-handler)
83  ;; 1. ensure connection (some bad server may not allow us to reuse
84  ;;    the connection (i.e. no content-length or no
85  ;;    transfer-encoding, or keep-alive closed specified)
86  ;; 2. send request
87  ;; 3. receive response
88  ;; 4. close connection if needed
89  (http-connection-open! connection)
90  (send-request! connection request)
91  (let ((keep? (receive-response! connection request
92				  header-handler data-handler)))
93    (cond (keep? connection)
94	  (else (http-connection-close! connection) #f))))
95
96(define (read-one-line in)
97  ;; \r\n would be \r for binary:get-line so trim it
98  (bytevector-trim-right (binary:get-line in) '(#x0d)))
99(define (parse-status-line line)
100  (cond ((eof-object? line)
101	 ;; TODO proper condition
102	 (error 'parse-status-line "http reply contains no data"))
103	((#/[\w\/.]+\s+(\d\d\d)\s+(.*)/ line)
104	 => (lambda (m) (values (m 1) (m 2))))
105	(else (error 'parse-status-line "bad reply from server" line))))
106
107(define (ensure-read in size)
108  (define buf (make-bytevector size))
109  (let loop ((s 0) (size size))
110    (let ((r (get-bytevector-n! in buf s size)))
111      (if (= r size)
112	  buf
113	  (loop (+ s r) (- size r))))))
114(define (receive-response! connection request header-handler data-handler)
115  (define in (http-connection-input connection))
116  (define (check-connection headers)
117    ;; TODO we need to tell connection manager how long we can
118    ;; let it alive...
119    (cond ((rfc5322-header-ref headers "connection") =>
120	   (lambda (v) (string-contains v "keep-alive")))
121	  (else #f)))
122  (let-values (((code reason) (parse-status-line
123			       (utf8->string (read-one-line in)))))
124    (let ((headers (rfc5322-read-headers in)))
125      (header-handler code headers)
126      (cond ((rfc5322-header-ref headers "content-length") =>
127	     (lambda (len)
128	       (data-handler (ensure-read in (string->number len)) #t)
129	       (check-connection headers)))
130	    ((rfc5322-header-ref headers "transfer-encoding") =>
131	     (lambda (v)
132	       (cond ((string-contains v "chunked")
133		      (read-chunked data-handler in)
134		      (check-connection headers))
135		     (else
136		      (data-handler (get-bytevector-all in) #t)
137		      #f))))
138	    ;; no body, so it's okay
139	    ((or (eq? 'HEAD (http:request-method request))
140		 ;; 204 (no content) 304 (not modified)
141		 (and code (memq (string->number code) '(204 304)))))
142	    ;; very bad behaving server...
143	    (else (data-handler (get-bytevector-all in) #t) #f)))))
144
145(define (read-chunked data-handler in)
146  (let ((line (read-one-line in)))
147    (when (eof-object? line)
148      ;; TODO proper condition
149      (error 'read-chunked "Chunked body ended prematurely"))
150    (cond ((#/^([0-9a-fA-F]+)/ line) =>
151	   (lambda (m)
152	     (let ((size (string->number (utf8->string (m 1)) 16)))
153	       (if (zero? size)
154		   (data-handler #vu8() #t)
155		   (data-handler (ensure-read in size) #f))
156	       (ensure-read in 2) ;; drop \r\n
157	       (unless (zero? size)
158		 (read-chunked data-handler in)))))
159	  (else (error 'read-chunked "bad line in chunked data" line)))))
160
161(define (send-request! connection request)
162  (define context (http-connection-context-data connection))
163  (define out (http-connection-output connection))
164  (define method (http:request-method request))
165  (define body (http:request-body request))
166  (define (send-first-line out request)
167    (http-connection-write-log connection
168     (string-append
169      "[Request-Line] "
170      (symbol->string method) " "
171      (http:request->request-uri request)
172      "HTTP/1.1"))
173    (put-bytevector out (string->utf8 (symbol->string method)))
174    (put-bytevector out #*" ")
175    (put-bytevector out (string->utf8 (http:request->request-uri request)))
176    (put-bytevector out #*" HTTP/1.1\r\n"))
177
178  (define (send-headers out request)
179    (define headers (http:request-headers request))
180    (define uri (http:request-uri request))
181    (define (write-header out name value)
182      (http-connection-write-header-log connection name value)
183      (put-bytevector out (string->utf8 name))
184      (put-bytevector out #*": ")
185      (put-bytevector out (string->utf8 value))
186      (put-bytevector out #*"\r\n"))
187
188    (unless (http:no-body-method? method)
189      (when body
190	(write-header out "Content-Type"
191		      (http:request-content-type request)))
192      (cond ((bytevector? body)
193	     (write-header out
194			   "Content-Length"
195			   (number->string (bytevector-length body))))
196	    ((port? body)
197	     (write-header out "Transfer-Encoding" "chunked"))))
198
199    (write-header out "Host"
200		  (or (http:headers-ref headers "Host")
201		      (uri-host uri)
202		      (http-connection-node connection)))
203    (write-header out "Connection" "keep-alive")
204
205    (for-each (lambda (name)
206		(let ((small (string-downcase name)))
207		  (unless (memp (lambda (n) (string=? small n))
208				+http:managed-headers+)
209		    (for-each (lambda (value) (write-header out name value))
210			      (http:headers-ref* headers name)))))
211	      (http:headers-names headers))
212    (put-bytevector out #*"\r\n")
213    (flush-output-port out))
214
215  (define (send-body out request)
216    (define (send-chunked out in)
217      (define buffer (http1-connection-context-buffer context))
218      (define buffer-size (bytevector-length buffer))
219      (let loop ((n (get-bytevector-n! in buffer 0 buffer-size)))
220	(cond ((zero? n)
221	       (put-bytevector out #*"0\r\n\r\n"))
222	      (else
223	       (put-bytevector out (string->utf8 (number->string n)))
224	       (put-bytevector out #*"\r\n")
225	       (put-bytevector out buffer 0 n)
226	       (put-bytevector out #*"\r\n")
227	       (if (< n buffer-size)
228		   (put-bytevector out #*"0\r\n\r\n")
229		   (loop (get-bytevector-n! in buffer 0 buffer-size)))))))
230
231    (unless (http:no-body-method? method)
232      (cond ((bytevector? body) (put-bytevector out body))
233	    ((port? body) (send-chunked out body)))
234      (flush-output-port out)))
235  (send-first-line out request)
236  (send-headers out request)
237  (send-body out request)
238  )
239)
240