LilyPond-Ruby 0.1.1 → 0.1.2

data/share/guile/2.2/web/server/http.scm

@@ -0,0 +1,183 @@
+;;; Web I/O: HTTP
+
+;; Copyright (C)  2010, 2011, 2012, 2015 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
+
+;;; Commentary:
+;;;
+;;; This is the HTTP implementation of the (web server) interface.
+;;;
+;;; `read-request' sets the character encoding on the new port to
+;;; latin-1.  See the note in request.scm regarding character sets,
+;;; strings, and bytevectors for more information.
+;;;
+;;; Code:
+
+(define-module (web server http)
+  #:use-module ((srfi srfi-1) #:select (fold))
+  #:use-module (srfi srfi-9)
+  #:use-module (rnrs bytevectors)
+  #:use-module (web request)
+  #:use-module (web response)
+  #:use-module (web server)
+  #:use-module (ice-9 poll)
+  #:export (http))
+
+
+(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-record-type <http-server>
+  (make-http-server socket poll-idx poll-set)
+  http-server?
+  (socket http-socket)
+  (poll-idx http-poll-idx set-http-poll-idx!)
+  (poll-set http-poll-set))
+
+(define *error-events* (logior POLLHUP POLLERR))
+(define *read-events* POLLIN)
+(define *events* (logior *error-events* *read-events*))
+
+;; -> 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 128)
+  (sigaction SIGPIPE SIG_IGN)
+  (let ((poll-set (make-empty-poll-set)))
+    (poll-set-add! poll-set socket *events*)
+    (make-http-server socket 0 poll-set)))
+
+(define (bad-request port)
+  (write-response (build-response #:version '(1 . 0) #:code 400
+                                  #:headers '((content-length . 0)))
+                  port))
+
+;; -> (client request body | #f #f #f)
+(define (http-read server)
+  (let* ((poll-set (http-poll-set server)))
+    (let lp ((idx (http-poll-idx server)))
+      (let ((revents (poll-set-revents poll-set idx)))
+        (cond
+         ((zero? idx)
+          ;; The server socket, and the end of our downward loop.
+          (cond
+           ((zero? revents)
+            ;; No client ready, and no error; poll and loop.
+            (poll poll-set)
+            (lp (1- (poll-set-nfds poll-set))))
+           ((not (zero? (logand revents *error-events*)))
+            ;; An error.
+            (set-http-poll-idx! server idx)
+            (throw 'interrupt))
+           (else
+            ;; A new client. Add to set, poll, and loop.
+            ;;
+            ;; FIXME: preserve meta-info.
+            (let ((client (accept (poll-set-port poll-set idx))))
+              ;; Buffer input and output on this port.
+              (setvbuf (car client) 'block)
+              ;; From "HOP, A Fast Server for the Diffuse Web", Serrano.
+              (setsockopt (car client) SOL_SOCKET SO_SNDBUF (* 12 1024))
+              (poll-set-add! poll-set (car client) *events*)
+              (poll poll-set)
+              (lp (1- (poll-set-nfds poll-set)))))))
+         ((zero? revents)
+          ;; Nothing on this port.
+          (lp (1- idx)))
+         ;; Otherwise, a client socket with some activity on
+         ;; it. Remove it from the poll set.
+         (else
+          (let ((port (poll-set-remove! poll-set idx)))
+            ;; Record the next index in all cases, in case the EOF check
+            ;; throws an error.
+            (set-http-poll-idx! server (1- idx))
+            (cond
+             ((eof-object? (peek-char port))
+              ;; EOF.
+              (close-port port)
+              (lp (1- idx)))
+             (else
+              ;; Otherwise, try to read a request from this port.
+              (with-throw-handler
+               #t
+               (lambda ()
+                 (let ((req (read-request port)))
+                   (values port
+                           req
+                           (read-request-body req))))
+               (lambda (k . args)
+                 (define-syntax-rule (cleanup-catch statement)
+                   (catch #t
+                     (lambda () statement)
+                     (lambda (k . args)
+                       (format (current-error-port) "In ~a:\n" 'statement)
+                       (print-exception (current-error-port) #f k args))))
+                 (cleanup-catch (bad-request port))
+                 (cleanup-catch (close-port port)))))))))))))
+
+(define (keep-alive? response)
+  (let ((v (response-version response)))
+    (and (or (< (response-code response) 400)
+             (= (response-code response) 404))
+         (case (car v)
+           ((1)
+            (case (cdr v)
+              ((1) (not (memq 'close (response-connection response))))
+              ((0) (memq 'keep-alive (response-connection response)))))
+           (else #f)))))
+
+;; -> 0 values
+(define (http-write server client response body)
+  (let* ((response (write-response response client))
+         (port (response-port response)))
+    (cond
+     ((not body))                       ; pass
+     ((bytevector? body)
+      (write-response-body response body))
+     (else
+      (error "Expected a bytevector for body" body)))
+    (cond
+     ((keep-alive? response)
+      (force-output port)
+      (poll-set-add! (http-poll-set server) port *events*))
+     (else
+      (close-port port)))
+    (values)))
+
+;; -> unspecified values
+(define (http-close server)
+  (let ((poll-set (http-poll-set server)))
+    (let lp ((n (poll-set-nfds poll-set)))
+      (if (positive? n)
+          (begin
+            (close-port (poll-set-remove! poll-set (1- n)))
+            (lp (1- n)))))))
+
+(define-server-impl http
+  http-open
+  http-read
+  http-write
+  http-close)

data/share/guile/2.2/web/server.scm

@@ -0,0 +1,397 @@
+;;; Web server
+
+;; Copyright (C)  2010, 2011, 2012, 2013, 2015 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
+
+;;; Commentary:
+;;;
+;;; (web server) is a generic web server interface, along with a main
+;;; loop implementation for web servers controlled by Guile.
+;;;
+;;; The lowest layer is the <server-impl> object, which defines a set of
+;;; hooks to open a server, read a request from a client, write a
+;;; response to a client, and close a server.  These hooks -- open,
+;;; read, write, and close, respectively -- are bound together in a
+;;; <server-impl> object.  Procedures in this module take a
+;;; <server-impl> object, if needed.
+;;;
+;;; A <server-impl> may also be looked up by name.  If you pass the
+;;; `http' symbol to `run-server', Guile looks for a variable named
+;;; `http' in the `(web server http)' module, which should be bound to a
+;;; <server-impl> object.  Such a binding is made by instantiation of
+;;; the `define-server-impl' syntax.  In this way the run-server loop can
+;;; automatically load other backends if available.
+;;;
+;;; The life cycle of a server goes as follows:
+;;;
+;;;   * The `open' hook is called, to open the server. `open' takes 0 or
+;;;     more arguments, depending on the backend, and returns an opaque
+;;;     server socket object, or signals an error.
+;;;
+;;;   * The `read' hook is called, to read a request from a new client.
+;;;     The `read' hook takes one arguments, the server socket.  It
+;;;     should return three values: an opaque client socket, the
+;;;     request, and the request body. The request should be a
+;;;     `<request>' object, from `(web request)'.  The body should be a
+;;;     string or a bytevector, or `#f' if there is no body.
+;;;
+;;;     If the read failed, the `read' hook may return #f for the client
+;;;     socket, request, and body.
+;;;
+;;;   * A user-provided handler procedure is called, with the request
+;;;     and body as its arguments.  The handler should return two
+;;;     values: the response, as a `<response>' record from `(web
+;;;     response)', and the response body as a string, bytevector, or
+;;;     `#f' if not present.  We also allow the reponse to be simply an
+;;;     alist of headers, in which case a default response object is
+;;;     constructed with those headers.
+;;;
+;;;   * The `write' hook is called with three arguments: the client
+;;;     socket, the response, and the body.  The `write' hook returns no
+;;;     values.
+;;;
+;;;   * At this point the request handling is complete. For a loop, we
+;;;     loop back and try to read a new request.
+;;;
+;;;   * If the user interrupts the loop, the `close' hook is called on
+;;;     the server socket.
+;;;
+;;; Code:
+
+(define-module (web server)
+  #:use-module (srfi srfi-9)
+  #:use-module (srfi srfi-9 gnu)
+  #:use-module (rnrs bytevectors)
+  #:use-module (ice-9 binary-ports)
+  #:use-module (web request)
+  #:use-module (web response)
+  #:use-module (system repl error-handling)
+  #:use-module (ice-9 control)
+  #:use-module (ice-9 iconv)
+  #:export (define-server-impl
+            lookup-server-impl
+
+            make-server-impl
+            server-impl?
+            server-impl-name
+            server-impl-open
+            server-impl-read
+            server-impl-write
+            server-impl-close
+
+            open-server
+            read-client
+            handle-request
+            sanitize-response
+            write-client
+            close-server
+            serve-one-client
+            run-server))
+
+(define *timer* (gettimeofday))
+(define (print-elapsed who)
+  (let ((t (gettimeofday)))
+    (pk who (+ (* (- (car t) (car *timer*)) 1000000)
+               (- (cdr t) (cdr *timer*))))
+    (set! *timer* t)))
+
+(eval-when (expand)
+  (define *time-debug?* #f))
+
+(define-syntax debug-elapsed
+  (lambda (x)
+    (syntax-case x ()
+      ((_ who)
+       (if *time-debug?*
+           #'(print-elapsed who)
+           #'*unspecified*)))))
+
+(define-record-type server-impl
+  (make-server-impl name open read write close)
+  server-impl?
+  (name server-impl-name)
+  (open server-impl-open)
+  (read server-impl-read)
+  (write server-impl-write)
+  (close server-impl-close))
+
+(define-syntax-rule (define-server-impl name open read write close)
+  (define name
+    (make-server-impl 'name open read write close)))
+
+(define (lookup-server-impl impl)
+  "Look up a server implementation.  If IMPL is a server
+implementation already, it is returned directly.  If it is a symbol, the
+binding named IMPL in the ‘(web server IMPL)’ module is
+looked up.  Otherwise an error is signaled.
+
+Currently a server implementation is a somewhat opaque type, useful only
+for passing to other procedures in this module, like
+‘read-client’."
+  (cond
+   ((server-impl? impl) impl)
+   ((symbol? impl)
+    (let ((impl (module-ref (resolve-module `(web server ,impl)) impl)))
+      (if (server-impl? impl)
+          impl
+          (error "expected a server impl in module" `(web server ,impl)))))
+   (else
+    (error "expected a server-impl or a symbol" impl))))
+
+;; -> server
+(define (open-server impl open-params)
+  "Open a server for the given implementation.  Return one value, the
+new server object.  The implementation's ‘open’ procedure is
+applied to OPEN-PARAMS, which should be a list."
+  (apply (server-impl-open impl) open-params))
+
+;; -> (client request body | #f #f #f)
+(define (read-client impl server)
+  "Read a new client from SERVER, by applying the implementation's
+‘read’ procedure to the server.  If successful, return three
+values: an object corresponding to the client, a request object, and the
+request body.  If any exception occurs, return ‘#f’ for all three
+values."
+  (call-with-error-handling
+   (lambda ()
+     ((server-impl-read impl) server))
+   #:pass-keys '(quit interrupt)
+   #:on-error (if (batch-mode?) 'backtrace 'debug)
+   #:post-error (lambda _ (values #f #f #f))))
+
+(define (extend-response r k v . additional)
+  (define (extend-alist alist k v)
+    (let ((pair (assq k alist)))
+      (acons k v (if pair (delq pair alist) alist))))
+  (let ((r (set-field r (response-headers)
+                      (extend-alist (response-headers r) k v))))
+    (if (null? additional)
+        r
+        (apply extend-response r additional))))
+
+;; -> response body
+(define (sanitize-response request response body)
+  "\"Sanitize\" the given response and body, making them appropriate for
+the given request.
+
+As a convenience to web handler authors, RESPONSE may be given as
+an alist of headers, in which case it is used to construct a default
+response.  Ensures that the response version corresponds to the request
+version.  If BODY is a string, encodes the string to a bytevector,
+in an encoding appropriate for RESPONSE.  Adds a
+‘content-length’ and ‘content-type’ header, as necessary.
+
+If BODY is a procedure, it is called with a port as an argument,
+and the output collected as a bytevector.  In the future we might try to
+instead use a compressing, chunk-encoded port, and call this procedure
+later, in the write-client procedure.  Authors are advised not to rely
+on the procedure being called at any particular time."
+  (cond
+   ((list? response)
+    (sanitize-response request
+                       (build-response #:version (request-version request)
+                                       #:headers response)
+                       body))
+   ((not (equal? (request-version request) (response-version response)))
+    (sanitize-response request
+                       (adapt-response-version response
+                                               (request-version request))
+                       body))
+   ((not body)
+    (values response #vu8()))
+   ((string? body)
+    (let* ((type (response-content-type response
+                                        '(text/plain)))
+           (declared-charset (assq-ref (cdr type) 'charset))
+           (charset (or declared-charset "utf-8")))
+      (sanitize-response
+       request
+       (if declared-charset
+           response
+           (extend-response response 'content-type
+                            `(,@type (charset . ,charset))))
+       (string->bytevector body charset))))
+   ((procedure? body)
+    (let* ((type (response-content-type response
+                                        '(text/plain)))
+           (declared-charset (assq-ref (cdr type) 'charset))
+           (charset (or declared-charset "utf-8")))
+      (sanitize-response
+       request
+       (if declared-charset
+           response
+           (extend-response response 'content-type
+                            `(,@type (charset . ,charset))))
+       (call-with-encoded-output-string charset body))))
+   ((not (bytevector? body))
+    (error "unexpected body type"))
+   ((and (response-must-not-include-body? response)
+         body
+         ;; FIXME make this stricter: even an empty body should be prohibited.
+         (not (zero? (bytevector-length body))))
+    (error "response with this status code must not include body" response))
+   (else
+    ;; check length; assert type; add other required fields?
+    (values (let ((rlen (response-content-length response))
+                  (blen (bytevector-length body)))
+              (cond
+               (rlen (if (= rlen blen)
+                         response
+                         (error "bad content-length" rlen blen)))
+               (else (extend-response response 'content-length blen))))
+            (if (eq? (request-method request) 'HEAD)
+                ;; Responses to HEAD requests must not include bodies.
+                ;; We could raise an error here, but it seems more
+                ;; appropriate to just do something sensible.
+                #f
+                body)))))
+
+;; -> response body state
+(define (handle-request handler request body state)
+  "Handle a given request, returning the response and body.
+
+The response and response body are produced by calling the given
+HANDLER with REQUEST and BODY as arguments.
+
+The elements of STATE are also passed to HANDLER as
+arguments, and may be returned as additional values.  The new
+STATE, collected from the HANDLER's return values, is then
+returned as a list.  The idea is that a server loop receives a handler
+from the user, along with whatever state values the user is interested
+in, allowing the user's handler to explicitly manage its state."
+  (call-with-error-handling
+   (lambda ()
+     (call-with-values (lambda ()
+                         (with-stack-and-prompt
+                          (lambda ()
+                            (apply handler request body state))))
+       (lambda (response body . state)
+         (call-with-values (lambda ()
+                             (debug-elapsed 'handler)
+                             (sanitize-response request response body))
+           (lambda (response body)
+             (debug-elapsed 'sanitize)
+             (values response body state))))))
+   #:pass-keys '(quit interrupt)
+   #:on-error (if (batch-mode?) 'backtrace 'debug)
+   #:post-error (lambda _
+                  (values (build-response #:code 500) #f state))))
+
+;; -> unspecified values
+(define (write-client impl server client response body)
+  "Write an HTTP response and body to CLIENT.  If the server and
+client support persistent connections, it is the implementation's
+responsibility to keep track of the client thereafter, presumably by
+attaching it to the SERVER argument somehow."
+  (call-with-error-handling
+   (lambda ()
+     ((server-impl-write impl) server client response body))
+   #:pass-keys '(quit interrupt)
+   #:on-error (if (batch-mode?) 'backtrace 'debug)
+   #:post-error (lambda _ (values))))
+
+;; -> unspecified values
+(define (close-server impl server)
+  "Release resources allocated by a previous invocation of
+‘open-server’."
+  ((server-impl-close impl) server))
+
+(define call-with-sigint
+  (if (not (provided? 'posix))
+      (lambda (thunk handler-thunk) (thunk))
+      (lambda (thunk handler-thunk)
+        (let ((handler #f))
+          (catch 'interrupt
+            (lambda ()
+              (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)))))
+            (lambda (k . _) (handler-thunk)))))))
+
+(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))))))
+  
+;; -> new-state
+(define (serve-one-client handler impl server state)
+  "Read one request from SERVER, call HANDLER on the request
+and body, and write the response to the client.  Return the new state
+produced by the handler procedure."
+  (debug-elapsed 'serve-again)
+  (call-with-values
+      (lambda ()
+        (read-client impl server))
+    (lambda (client request body)
+      (debug-elapsed 'read-client)
+      (if client
+          (call-with-values
+              (lambda ()
+                (handle-request handler request body state))
+            (lambda (response body state)
+              (debug-elapsed 'handle-request)
+              (write-client impl server client response body)
+              (debug-elapsed 'write-client)
+              state))
+          state))))
+
+(define* (run-server handler #:optional (impl 'http) (open-params '())
+                     . state)
+  "Run Guile's built-in web server.
+
+HANDLER should be a procedure that takes two or more arguments,
+the HTTP request and request body, and returns two or more values, the
+response and response body.
+
+For example, here is a simple \"Hello, World!\" server:
+
+@example
+ (define (handler request body)
+   (values '((content-type . (text/plain)))
+           \"Hello, World!\"))
+ (run-server handler)
+@end example
+
+The response and body will be run through ‘sanitize-response’
+before sending back to the client.
+
+Additional arguments to HANDLER are taken from
+STATE.  Additional return values are accumulated into a new
+STATE, which will be used for subsequent requests.  In this way a
+handler can explicitly manage its state.
+
+The default server implementation is ‘http’, which accepts
+OPEN-PARAMS like ‘(#:port 8081)’, among others.  See \"Web
+Server\" in the manual, for more information."
+  (let* ((impl (lookup-server-impl impl))
+         (server (open-server impl open-params)))
+    (call-with-sigint
+     (lambda ()
+       (let lp ((state state))
+         (lp (serve-one-client handler impl server state))))
+     (lambda ()
+       (close-server impl server)
+       (values)))))