mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-05-23 04:50:28 +02:00
79ef79ee34
* module/web/server.scm: New generic web server module, with support for different backends. An HTTP-over-TCP backend is the only one included with Guile, though one can imagine FastCGI, mod-lisp, mongrel2/0mq etc backends as well. * module/web/server/http.scm: The aforementioned HTTP backend.
123 lines
4.1 KiB
Scheme
123 lines
4.1 KiB
Scheme
;;; Web I/O: HTTP
|
|
|
|
;; Copyright (C) 2010 Free Software Foundation, Inc.
|
|
|
|
;; This library is free software; you can redistribute it and/or
|
|
;; modify it under the terms of the GNU Lesser General Public
|
|
;; License as published by the Free Software Foundation; either
|
|
;; version 3 of the License, or (at your option) any later version.
|
|
;;
|
|
;; This library is distributed in the hope that it will be useful,
|
|
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
|
;; Lesser General Public License for more details.
|
|
;;
|
|
;; You should have received a copy of the GNU Lesser General Public
|
|
;; License along with this library; if not, write to the Free Software
|
|
;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
|
|
;; 02110-1301 USA
|
|
|
|
;;; Code:
|
|
|
|
(define-module (web server http)
|
|
#:use-module ((srfi srfi-1) #:select (fold))
|
|
#:use-module (rnrs bytevectors)
|
|
#:use-module (web request)
|
|
#:use-module (web response)
|
|
#:use-module (web server)
|
|
#:use-module (system repl error-handling))
|
|
|
|
|
|
(define (make-default-socket family addr port)
|
|
(let ((sock (socket PF_INET SOCK_STREAM 0)))
|
|
(setsockopt sock SOL_SOCKET SO_REUSEADDR 1)
|
|
(bind sock family addr port)
|
|
sock))
|
|
|
|
;; -> server
|
|
(define* (http-open #:key
|
|
(host #f)
|
|
(family AF_INET)
|
|
(addr (if host
|
|
(inet-pton family host)
|
|
INADDR_LOOPBACK))
|
|
(port 8080)
|
|
(socket (make-default-socket family addr port)))
|
|
(listen socket 5)
|
|
socket)
|
|
|
|
;; -> (keep-alive client request body | keep-alive #f #f #f)
|
|
(define (http-read server keep-alive)
|
|
(call-with-values (lambda ()
|
|
(let ((ports (cons server keep-alive)))
|
|
(apply values (select ports '() ports))))
|
|
(lambda (readable writable except)
|
|
(cond
|
|
((pair? except)
|
|
(values (fold (lambda (p keep-alive)
|
|
(close-port p)
|
|
(if (eq? p server)
|
|
(throw 'interrupt)
|
|
(delq p keep-alive)))
|
|
keep-alive
|
|
except)
|
|
#f #f #f))
|
|
((memq server readable)
|
|
;; FIXME: meta to read-request
|
|
(let* ((client (accept server))
|
|
(req (read-request (car client)))
|
|
(body-str (read-request-body/latin-1 req)))
|
|
(values keep-alive (car client) req body-str)))
|
|
((pair? readable)
|
|
;; FIXME: preserve meta for keep-alive
|
|
(let* ((p (car readable))
|
|
(keep-alive (delq p keep-alive)))
|
|
(if (eof-object? (peek-char p))
|
|
(begin
|
|
(close-port p)
|
|
(values keep-alive #f #f #f))
|
|
(call-with-error-handling
|
|
(lambda ()
|
|
(let* ((req (read-request p))
|
|
(body-str (read-request-body/latin-1 req)))
|
|
(values keep-alive p req body-str)))
|
|
#:pass-keys '(quit interrupt)
|
|
#:on-error (if (batch-mode?) 'pass 'debug)
|
|
#:post-error
|
|
(lambda (k . args)
|
|
(warn "Error while reading request" k args)
|
|
(values keep-alive #f #f #f #f))))))
|
|
(else
|
|
(values keep-alive #f #f #f))))))
|
|
|
|
(define (keep-alive? response)
|
|
#t)
|
|
|
|
;; -> (#f | client)
|
|
(define (http-write server client response body)
|
|
(let ((response (write-response response client)))
|
|
(cond
|
|
((not body)) ; pass
|
|
((string? body)
|
|
(write-response-body/latin-1 response body))
|
|
((bytevector? body)
|
|
(write-response-body/bytevector response body))
|
|
(else
|
|
(error "Expected a string or bytevector for body" body)))
|
|
(force-output (response-port response))
|
|
(if (keep-alive? response)
|
|
(response-port response)
|
|
(begin
|
|
(close-port (response-port response))
|
|
#f))))
|
|
|
|
;; -> unspecified values
|
|
(define (http-close server)
|
|
(shutdown server 2)
|
|
(close-port server))
|
|
|
|
(define-server-impl http
|
|
http-open
|
|
http-read
|
|
http-write
|
|
http-close)
|