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