From 347ba27e4bd7861e61e90b7b7eac6b892411ce8b Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 12 Nov 2010 12:16:26 +0100 Subject: [PATCH] remove (web toy-server) * module/Makefile.am * module/web/toy-server.scm: Remove. It's not so much that the new (web server) stuff is not a toy, it's that users are expected to use the new backends (mod-lisp, etc) in "production". --- module/Makefile.am | 1 - module/web/toy-server.scm | 157 -------------------------------------- 2 files changed, 158 deletions(-) delete mode 100644 module/web/toy-server.scm diff --git a/module/Makefile.am b/module/Makefile.am index 5ee3a46e5..d2a44b8a9 100644 --- a/module/Makefile.am +++ b/module/Makefile.am @@ -354,7 +354,6 @@ WEB_SOURCES = \ web/response.scm \ web/server.scm \ web/server/http.scm \ - web/toy-server.scm \ web/uri.scm EXTRA_DIST += oop/ChangeLog-2008 diff --git a/module/web/toy-server.scm b/module/web/toy-server.scm deleted file mode 100644 index bf182fe72..000000000 --- a/module/web/toy-server.scm +++ /dev/null @@ -1,157 +0,0 @@ -;;; Toy web server - -;; 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 toy-server) - #:use-module (rnrs bytevectors) - #:use-module (web request) - #:use-module (web response) - #:use-module (system repl error-handling) - #:use-module (ice-9 control) - #:export (run-server simple-get-handler)) - -(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)) - -(define call-with-sigint - (if (not (provided? 'posix)) - (lambda (thunk) (thunk)) - (lambda (thunk) - (let ((handler #f)) - (dynamic-wind - (lambda () - (set! handler - (sigaction SIGINT (lambda (sig) (throw 'interrupt))))) - thunk - (lambda () - (if handler - ;; restore Scheme handler, SIG_IGN or SIG_DFL. - (sigaction SIGINT (car handler) (cdr handler)) - ;; restore original C handler. - (sigaction SIGINT #f)))))))) - -(define (accept-new-client server-socket) - (catch #t - (lambda () (call-with-sigint (lambda () (accept server-socket)))) - (lambda (k . args) - (cond - ((port-closed? server-socket) - ;; Shutting down. - #f) - ((eq? k 'interrupt) - ;; Interrupt. - (close-port server-socket) - #f) - (else - (warn "Error accepting client" k args) - ;; Retry after a timeout. - (sleep 1) - (accept-new-client server-socket)))))) - -(define* (simple-get-handler handler #:optional (content-type '("text" "plain"))) - (lambda (request request-body) - (if (eq? (request-method request) 'GET) - (let* ((x (handler (request-absolute-uri request))) - (bv (cond ((bytevector? x) x) - ((string? x) (string->utf8 x)) - (else - (error "unexpected val from simple get handler" x))))) - (values (build-response - #:headers `((content-type . ,content-type) - (content-length . ,(bytevector-length bv)))) - bv)) - (build-response #:code 405)))) - -(define (with-stack-and-prompt thunk) - (call-with-prompt (default-prompt-tag) - (lambda () (start-stack #t (thunk))) - (lambda (k proc) - (with-stack-and-prompt (lambda () (proc k)))))) - -(define (serve-client handler sock addr) - (define *on-toy-server-error* (if (batch-mode?) 'pass 'debug)) - (define *on-handler-error* (if (batch-mode?) 'pass 'debug)) - - (call-with-values - (lambda () - (call-with-error-handling - (lambda () - (let* ((req (read-request sock)) - (body-str (read-request-body/latin-1 req))) - (call-with-error-handling - (lambda () - (with-stack-and-prompt - (lambda () - (handler req body-str)))) - #:pass-keys '(quit interrupt) - #:on-error *on-handler-error* - #:post-error - (lambda (k . args) - (warn "Error while serving client" k args) - (build-response #:code 500))))) - #:pass-keys '(quit interrupt) - #:on-error *on-toy-server-error* - #:post-error - (lambda (k . args) - (warn "Error reading request" k args) - (build-response #:code 400)))) - (lambda* (response #:optional body) - (call-with-error-handling - (lambda () - (let ((response (write-response response sock))) - (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))))) - #:on-error *on-toy-server-error* - #:pass-keys '(quit interrupt)))) - (close-port sock)) ; FIXME: keep socket alive. requires select? - -(define* (run-server handler - #:key - (host #f) - (family AF_INET) - (addr (if host - (inet-pton family host) - INADDR_LOOPBACK)) - (port 8080) - (server-socket (make-default-socket family addr port))) - (listen server-socket 5) - (let lp ((client (accept-new-client server-socket))) - ;; If client is false, we are shutting down. - (if client - (let ((client-socket (car client)) - (client-addr (cdr client))) - (catch 'interrupt - (lambda () - (call-with-sigint - (lambda () - (serve-client handler client-socket client-addr)))) - (lambda (k . args) - (warn "Interrupt while serving client") - (close-port client-socket))) - (lp (accept-new-client server-socket)))))) -- 2.20.1