Commit | Line | Data |
---|---|---|
79ef79ee AW |
1 | ;;; Web I/O: HTTP |
2 | ||
3 | ;; Copyright (C) 2010 Free Software Foundation, Inc. | |
4 | ||
5 | ;; This library is free software; you can redistribute it and/or | |
6 | ;; modify it under the terms of the GNU Lesser General Public | |
7 | ;; License as published by the Free Software Foundation; either | |
8 | ;; version 3 of the License, or (at your option) any later version. | |
9 | ;; | |
10 | ;; This library is distributed in the hope that it will be useful, | |
11 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
12 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU | |
13 | ;; Lesser General Public License for more details. | |
14 | ;; | |
15 | ;; You should have received a copy of the GNU Lesser General Public | |
16 | ;; License along with this library; if not, write to the Free Software | |
17 | ;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA | |
18 | ;; 02110-1301 USA | |
19 | ||
e8c44a04 AW |
20 | ;;; Commentary: |
21 | ;;; | |
22 | ;;; This is the HTTP implementation of the (web server) interface. | |
23 | ;;; | |
24 | ;;; `read-request' sets the character encoding on the new port to | |
25 | ;;; latin-1. See the note in request.scm regarding character sets, | |
26 | ;;; strings, and bytevectors for more information. | |
27 | ;;; | |
79ef79ee AW |
28 | ;;; Code: |
29 | ||
30 | (define-module (web server http) | |
31 | #:use-module ((srfi srfi-1) #:select (fold)) | |
462a1a04 | 32 | #:use-module (srfi srfi-9) |
79ef79ee AW |
33 | #:use-module (rnrs bytevectors) |
34 | #:use-module (web request) | |
35 | #:use-module (web response) | |
36 | #:use-module (web server) | |
35b97af9 | 37 | #:use-module (ice-9 poll)) |
79ef79ee AW |
38 | |
39 | ||
40 | (define (make-default-socket family addr port) | |
41 | (let ((sock (socket PF_INET SOCK_STREAM 0))) | |
42 | (setsockopt sock SOL_SOCKET SO_REUSEADDR 1) | |
43 | (bind sock family addr port) | |
44 | sock)) | |
45 | ||
462a1a04 AW |
46 | (define-record-type <http-server> |
47 | (make-http-server socket poll-idx poll-set) | |
48 | http-server? | |
49 | (socket http-socket) | |
50 | (poll-idx http-poll-idx set-http-poll-idx!) | |
51 | (poll-set http-poll-set)) | |
52 | ||
53 | (define *error-events* (logior POLLHUP POLLERR)) | |
54 | (define *read-events* POLLIN) | |
55 | (define *events* (logior *error-events* *read-events*)) | |
56 | ||
79ef79ee AW |
57 | ;; -> server |
58 | (define* (http-open #:key | |
462a1a04 AW |
59 | (host #f) |
60 | (family AF_INET) | |
61 | (addr (if host | |
62 | (inet-pton family host) | |
63 | INADDR_LOOPBACK)) | |
64 | (port 8080) | |
65 | (socket (make-default-socket family addr port))) | |
e6ae3173 | 66 | (listen socket 128) |
a0ad8ad1 | 67 | (sigaction SIGPIPE SIG_IGN) |
462a1a04 AW |
68 | (let ((poll-set (make-empty-poll-set))) |
69 | (poll-set-add! poll-set socket *events*) | |
0baead3f | 70 | (make-http-server socket 0 poll-set))) |
79ef79ee | 71 | |
462a1a04 AW |
72 | ;; -> (client request body | #f #f #f) |
73 | (define (http-read server) | |
74 | (let* ((poll-set (http-poll-set server))) | |
75 | (let lp ((idx (http-poll-idx server))) | |
0baead3f AW |
76 | (let ((revents (poll-set-revents poll-set idx))) |
77 | (cond | |
78 | ((zero? idx) | |
79 | ;; The server socket, and the end of our downward loop. | |
462a1a04 AW |
80 | (cond |
81 | ((zero? revents) | |
0baead3f AW |
82 | ;; No client ready, and no error; poll and loop. |
83 | (poll poll-set) | |
84 | (lp (1- (poll-set-nfds poll-set)))) | |
85 | ((not (zero? (logand revents *error-events*))) | |
86 | ;; An error. | |
ec3c7570 | 87 | (set-http-poll-idx! server idx) |
0baead3f | 88 | (throw 'interrupt)) |
462a1a04 | 89 | (else |
0baead3f AW |
90 | ;; A new client. Add to set, poll, and loop. |
91 | ;; | |
92 | ;; FIXME: preserve meta-info. | |
93 | (let ((client (accept (poll-set-port poll-set idx)))) | |
4595600a AW |
94 | ;; Buffer input and output on this port. |
95 | (setvbuf (car client) _IOFBF) | |
e6ae3173 AW |
96 | ;; From "HOP, A Fast Server for the Diffuse Web", Serrano. |
97 | (setsockopt (car client) SOL_SOCKET SO_SNDBUF (* 12 1024)) | |
0baead3f AW |
98 | (poll-set-add! poll-set (car client) *events*) |
99 | (poll poll-set) | |
100 | (lp (1- (poll-set-nfds poll-set))))))) | |
101 | ((zero? revents) | |
102 | ;; Nothing on this port. | |
103 | (lp (1- idx))) | |
104 | ;; Otherwise, a client socket with some activity on | |
105 | ;; it. Remove it from the poll set. | |
106 | (else | |
107 | (let ((port (poll-set-remove! poll-set idx))) | |
ec3c7570 AW |
108 | ;; Record the next index in all cases, in case the EOF check |
109 | ;; throws an error. | |
110 | (set-http-poll-idx! server (1- idx)) | |
0baead3f AW |
111 | (cond |
112 | ((eof-object? (peek-char port)) | |
113 | ;; EOF. | |
114 | (close-port port) | |
115 | (lp (1- idx))) | |
116 | (else | |
117 | ;; Otherwise, try to read a request from this port. | |
b500ced6 AW |
118 | (with-throw-handler |
119 | #t | |
120 | (lambda () | |
121 | (let ((req (read-request port))) | |
b500ced6 AW |
122 | (values port |
123 | req | |
124 | (read-request-body/bytevector req)))) | |
125 | (lambda (k . args) | |
126 | (false-if-exception (close-port port))))))))))))) | |
79ef79ee AW |
127 | |
128 | (define (keep-alive? response) | |
c6371902 | 129 | (let ((v (response-version response))) |
4164be30 AW |
130 | (and (or (< (response-code response) 400) |
131 | (= (response-code response) 404)) | |
132 | (case (car v) | |
133 | ((1) | |
134 | (case (cdr v) | |
135 | ((1) (not (memq 'close (response-connection response)))) | |
136 | ((0) (memq 'keep-alive (response-connection response))))) | |
137 | (else #f))))) | |
79ef79ee | 138 | |
462a1a04 | 139 | ;; -> 0 values |
79ef79ee | 140 | (define (http-write server client response body) |
462a1a04 AW |
141 | (let* ((response (write-response response client)) |
142 | (port (response-port response))) | |
79ef79ee AW |
143 | (cond |
144 | ((not body)) ; pass | |
145 | ((string? body) | |
146 | (write-response-body/latin-1 response body)) | |
147 | ((bytevector? body) | |
148 | (write-response-body/bytevector response body)) | |
149 | (else | |
150 | (error "Expected a string or bytevector for body" body))) | |
462a1a04 AW |
151 | (cond |
152 | ((keep-alive? response) | |
153 | (force-output port) | |
462a1a04 AW |
154 | (poll-set-add! (http-poll-set server) port *events*)) |
155 | (else | |
156 | (close-port port))) | |
157 | (values))) | |
79ef79ee AW |
158 | |
159 | ;; -> unspecified values | |
160 | (define (http-close server) | |
462a1a04 AW |
161 | (let ((poll-set (http-poll-set server))) |
162 | (let lp ((n (poll-set-nfds poll-set))) | |
163 | (if (positive? n) | |
164 | (begin | |
165 | (close-port (poll-set-remove! poll-set (1- n))) | |
166 | (lp (1- n))))))) | |
79ef79ee AW |
167 | |
168 | (define-server-impl http | |
169 | http-open | |
170 | http-read | |
171 | http-write | |
172 | http-close) |