LilyPond-Ruby 0.1.1 → 0.1.2

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

@@ -0,0 +1,326 @@
+;;; HTTP request objects
+
+;; Copyright (C)  2010, 2011, 2012 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 request)
+  #:use-module (rnrs bytevectors)
+  #:use-module (ice-9 binary-ports)
+  #:use-module (ice-9 textual-ports)
+  #:use-module (ice-9 rdelim)
+  #:use-module (srfi srfi-9)
+  #:use-module (web uri)
+  #:use-module (web http)
+  #:export (request?
+            request-method
+            request-uri
+            request-version
+            request-headers
+            request-meta
+            request-port
+            
+            read-request
+            build-request
+            write-request
+
+            read-request-body
+            write-request-body
+
+            ;; General headers
+            ;;
+            request-cache-control
+            request-connection
+            request-date
+            request-pragma
+            request-trailer
+            request-transfer-encoding
+            request-upgrade
+            request-via
+            request-warning
+            
+            ;; Entity headers
+            ;;
+            request-allow
+            request-content-encoding
+            request-content-language
+            request-content-length
+            request-content-location
+            request-content-md5
+            request-content-range
+            request-content-type
+            request-expires
+            request-last-modified
+            
+            ;; Request headers
+            ;;
+            request-accept
+            request-accept-charset
+            request-accept-encoding
+            request-accept-language
+            request-authorization
+            request-expect
+            request-from
+            request-host
+            request-if-match
+            request-if-modified-since
+            request-if-none-match
+            request-if-range
+            request-if-unmodified-since
+            request-max-forwards
+            request-proxy-authorization
+            request-range
+            request-referer
+            request-te
+            request-user-agent
+
+            ;; Misc
+            request-absolute-uri))
+
+
+;;; {Character Encodings, Strings, and Bytevectors}
+;;; 
+;;; Requests are read from over the wire, and as such have to be treated
+;;; very carefully.
+;;;
+;;; The header portion of the message is defined to be in a subset of
+;;; ASCII, and may be processed either byte-wise (using bytevectors and
+;;; binary I/O) or as characters in a single-byte ASCII-compatible
+;;; encoding.
+;;;
+;;; We choose the latter, processing as strings in the latin-1
+;;; encoding. This allows us to use all the read-delimited machinery,
+;;; character sets, and regular expressions, shared substrings, etc.
+;;;
+;;; The characters in the header values may themselves encode other
+;;; bytes or characters -- basically each header has its own parser. We
+;;; leave that as a header-specific topic.
+;;;
+;;; The body is present if the content-length header is present. Its
+;;; format and, if textual, encoding is determined by the headers, but
+;;; its length is encoded in bytes. So we just slurp that number of
+;;; characters in latin-1, knowing that the number of characters
+;;; corresponds to the number of bytes, and then convert to a
+;;; bytevector, perhaps for later decoding.
+;;;
+
+(define-record-type <request>
+  (make-request method uri version headers meta port)
+  request?
+  (method request-method)
+  (uri request-uri)
+  (version request-version)
+  (headers request-headers)
+  (meta request-meta)
+  (port request-port))
+
+(define (bad-request message . args)
+  (throw 'bad-request message args))
+
+(define (bad-request-printer port key args default-printer)
+  (apply (case-lambda
+           ((msg args)
+            (display "Bad request: " port)
+            (apply format port msg args)
+            (newline port))
+           (_ (default-printer)))
+         args))
+
+(set-exception-printer! 'bad-request bad-request-printer)
+
+(define (non-negative-integer? n)
+  (and (number? n) (>= n 0) (exact? n) (integer? n)))
+                                    
+(define (validate-headers headers)
+  (if (pair? headers)
+      (let ((h (car headers)))
+        (if (pair? h)
+            (let ((k (car h)) (v (cdr h)))
+              (if (valid-header? k v)
+                  (validate-headers (cdr headers))
+                  (bad-request "Bad value for header ~a: ~s" k v)))
+            (bad-request "Header not a pair: ~a" h)))
+      (if (not (null? headers))
+          (bad-request "Headers not a list: ~a" headers))))
+
+(define* (build-request uri #:key (method 'GET) (version '(1 . 1))
+                        (headers '()) port (meta '())
+                        (validate-headers? #t))
+  "Construct an HTTP request object. If VALIDATE-HEADERS? is true,
+the headers are each run through their respective validators."
+  (let ((needs-host? (and (equal? version '(1 . 1))
+                          (not (assq-ref headers 'host)))))
+    (cond
+     ((not (and (pair? version)
+                (non-negative-integer? (car version))
+                (non-negative-integer? (cdr version))))
+      (bad-request "Bad version: ~a" version))
+     ((not (uri-reference? uri))
+      (bad-request "Bad uri: ~a" uri))
+     ((and (not port) (memq method '(POST PUT)))
+      (bad-request "Missing port for message ~a" method))
+     ((not (list? meta))
+      (bad-request "Bad metadata alist" meta))
+     ((and needs-host? (not (uri-host uri)))
+      (bad-request "HTTP/1.1 request without Host header and no host in URI: ~a"
+                   uri))
+     (else
+      (if validate-headers?
+          (validate-headers headers))))
+    (make-request method uri version
+                  (if needs-host?
+                      (acons 'host (cons (uri-host uri) (uri-port uri))
+                             headers)
+                      headers)
+                  meta port)))
+
+(define* (read-request port #:optional (meta '()))
+  "Read an HTTP request from PORT, optionally attaching the given
+metadata, META.
+
+As a side effect, sets the encoding on PORT to
+ISO-8859-1 (latin-1), so that reading one character reads one byte.  See
+the discussion of character sets in \"HTTP Requests\" in the manual, for
+more information.
+
+Note that the body is not part of the request.  Once you have read a
+request, you may read the body separately, and likewise for writing
+requests."
+  (set-port-encoding! port "ISO-8859-1")
+  (call-with-values (lambda () (read-request-line port))
+    (lambda (method uri version)
+      (make-request method uri version (read-headers port) meta port))))
+
+;; FIXME: really return a new request?
+(define (write-request r port)
+  "Write the given HTTP request to PORT.
+
+Return a new request, whose ‘request-port’ will continue writing
+on PORT, perhaps using some transfer encoding."
+  (write-request-line (request-method r) (request-uri r)
+                      (request-version r) port)
+  (write-headers (request-headers r) port)
+  (put-string port "\r\n")
+  (if (eq? port (request-port r))
+      r
+      (make-request (request-method r) (request-uri r) (request-version r)
+                    (request-headers r) (request-meta r) port)))
+
+(define (read-request-body r)
+  "Reads the request body from R, as a bytevector.  Return ‘#f’
+if there was no request body."
+  (let ((nbytes (request-content-length r)))
+    (and nbytes
+         (let ((bv (get-bytevector-n (request-port r) nbytes)))
+           (if (= (bytevector-length bv) nbytes)
+               bv
+               (bad-request "EOF while reading request body: ~a bytes of ~a"
+                            (bytevector-length bv) nbytes))))))
+
+(define (write-request-body r bv)
+  "Write BV, a bytevector, to the port corresponding to the HTTP
+request R."
+  (put-bytevector (request-port r) bv))
+
+(define-syntax define-request-accessor
+  (lambda (x)
+    (syntax-case x ()
+      ((_ field)
+       #'(define-request-accessor field #f))
+      ((_ field def) (identifier? #'field)
+       #`(define* (#,(datum->syntax
+                      #'field
+                      (symbol-append 'request- (syntax->datum #'field)))
+                   request
+                   #:optional (default def))
+           (cond
+            ((assq 'field (request-headers request)) => cdr)
+            (else default)))))))
+
+;; General headers
+;;
+(define-request-accessor cache-control '())
+(define-request-accessor connection '())
+(define-request-accessor date #f)
+(define-request-accessor pragma '())
+(define-request-accessor trailer '())
+(define-request-accessor transfer-encoding '())
+(define-request-accessor upgrade '())
+(define-request-accessor via '())
+(define-request-accessor warning '())
+
+;; Entity headers
+;;
+(define-request-accessor allow '())
+(define-request-accessor content-encoding '())
+(define-request-accessor content-language '())
+(define-request-accessor content-length #f)
+(define-request-accessor content-location #f)
+(define-request-accessor content-md5 #f)
+(define-request-accessor content-range #f)
+(define-request-accessor content-type #f)
+(define-request-accessor expires #f)
+(define-request-accessor last-modified #f)
+
+;; Request headers
+;;
+(define-request-accessor accept '())
+(define-request-accessor accept-charset '())
+(define-request-accessor accept-encoding '())
+(define-request-accessor accept-language '())
+(define-request-accessor authorization #f)
+(define-request-accessor expect '())
+(define-request-accessor from #f)
+(define-request-accessor host #f)
+;; Absence of an if-directive appears to be different from `*'.
+(define-request-accessor if-match #f)
+(define-request-accessor if-modified-since #f)
+(define-request-accessor if-none-match #f)
+(define-request-accessor if-range #f)
+(define-request-accessor if-unmodified-since #f)
+(define-request-accessor max-forwards #f)
+(define-request-accessor proxy-authorization #f)
+(define-request-accessor range #f)
+(define-request-accessor referer #f)
+(define-request-accessor te '())
+(define-request-accessor user-agent #f)
+
+;; Misc accessors
+(define* (request-absolute-uri r #:optional default-host default-port
+                               default-scheme)
+  "A helper routine to determine the absolute URI of a request, using the
+‘host’ header and the default host and port."
+  (let ((uri (request-uri r)))
+    (if (uri-host uri)
+        uri
+        (let ((host
+               (or (request-host r)
+                   (if default-host
+                       (cons default-host default-port)
+                       (bad-request
+                        "URI not absolute, no Host header, and no default: ~s"
+                        uri)))))
+          (build-uri (or (uri-scheme uri)
+                         default-scheme
+                         (bad-request "URI not absolute and no default-port"
+                                      uri))
+                     #:host (car host)
+                     #:port (cdr host)
+                     #:path (uri-path uri)
+                     #:query (uri-query uri)
+                     #:fragment (uri-fragment uri))))))

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

@@ -0,0 +1,379 @@
+;;; HTTP response objects
+
+;; Copyright (C) 2010, 2011, 2012, 2013, 2014, 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
+
+;;; Code:
+
+(define-module (web response)
+  #:use-module (rnrs bytevectors)
+  #:use-module (ice-9 binary-ports)
+  #:use-module (ice-9 textual-ports)
+  #:use-module (ice-9 rdelim)
+  #:use-module (ice-9 match)
+  #:use-module (srfi srfi-9)
+  #:use-module (web http)
+  #:export (response?
+            response-version
+            response-code
+            response-reason-phrase
+            response-headers
+            response-port
+            read-response
+            build-response
+            adapt-response-version
+            write-response
+
+            response-must-not-include-body?
+            response-body-port
+            read-response-body
+            write-response-body
+
+            ;; General headers
+            ;;
+            response-cache-control
+            response-connection
+            response-date
+            response-pragma
+            response-trailer
+            response-transfer-encoding
+            response-upgrade
+            response-via
+            response-warning
+
+            ;; Entity headers
+            ;;
+            response-allow
+            response-content-encoding
+            response-content-language
+            response-content-length
+            response-content-location
+            response-content-md5
+            response-content-range
+            response-content-type
+            text-content-type?
+            response-expires
+            response-last-modified
+
+            ;; Response headers
+            ;;
+            response-accept-ranges
+            response-age
+            response-etag
+            response-location
+            response-proxy-authenticate
+            response-retry-after
+            response-server
+            response-vary
+            response-www-authenticate))
+
+
+(define-record-type <response>
+  (make-response version code reason-phrase headers port)
+  response?
+  (version response-version)
+  (code response-code)
+  (reason-phrase %response-reason-phrase)
+  (headers response-headers)
+  (port response-port))
+
+(define (bad-response message . args)
+  (throw 'bad-response message args))
+
+(define (non-negative-integer? n)
+  (and (number? n) (>= n 0) (exact? n) (integer? n)))
+                                    
+(define (validate-headers headers)
+  (if (pair? headers)
+      (let ((h (car headers)))
+        (if (pair? h)
+            (let ((k (car h)) (v (cdr h)))
+              (if (valid-header? k v)
+                  (validate-headers (cdr headers))
+                  (bad-response "Bad value for header ~a: ~s" k v)))
+            (bad-response "Header not a pair: ~a" h)))
+      (if (not (null? headers))
+          (bad-response "Headers not a list: ~a" headers))))
+
+(define* (build-response #:key (version '(1 . 1)) (code 200) reason-phrase
+                         (headers '()) port (validate-headers? #t))
+  "Construct an HTTP response object. If VALIDATE-HEADERS? is true,
+the headers are each run through their respective validators."
+  (cond
+   ((not (and (pair? version)
+              (non-negative-integer? (car version))
+              (non-negative-integer? (cdr version))))
+    (bad-response "Bad version: ~a" version))
+   ((not (and (non-negative-integer? code) (< code 600)))
+    (bad-response "Bad code: ~a" code))
+   ((and reason-phrase (not (string? reason-phrase)))
+    (bad-response "Bad reason phrase" reason-phrase))
+   (else
+    (if validate-headers?
+        (validate-headers headers))))
+  (make-response version code reason-phrase headers port))
+
+(define *reason-phrases*
+  '((100 . "Continue")
+    (101 . "Switching Protocols")
+    (200 . "OK")
+    (201 . "Created")
+    (202 . "Accepted")
+    (203 . "Non-Authoritative Information")
+    (204 . "No Content")
+    (205 . "Reset Content")
+    (206 . "Partial Content")
+    (300 . "Multiple Choices")
+    (301 . "Moved Permanently")
+    (302 . "Found")
+    (303 . "See Other")
+    (304 . "Not Modified")
+    (305 . "Use Proxy")
+    (307 . "Temporary Redirect")
+    (400 . "Bad Request")
+    (401 . "Unauthorized")
+    (402 . "Payment Required")
+    (403 . "Forbidden")
+    (404 . "Not Found")
+    (405 . "Method Not Allowed")
+    (406 . "Not Acceptable")
+    (407 . "Proxy Authentication Required")
+    (408 . "Request Timeout")
+    (409 . "Conflict")
+    (410 . "Gone")
+    (411 . "Length Required")
+    (412 . "Precondition Failed")
+    (413 . "Request Entity Too Large")
+    (414 . "Request-URI Too Long")
+    (415 . "Unsupported Media Type")
+    (416 . "Requested Range Not Satisfiable")
+    (417 . "Expectation Failed")
+    (500 . "Internal Server Error")
+    (501 . "Not Implemented")
+    (502 . "Bad Gateway")
+    (503 . "Service Unavailable")
+    (504 . "Gateway Timeout")
+    (505 . "HTTP Version Not Supported")))
+
+(define (code->reason-phrase code)
+  (or (assv-ref *reason-phrases* code)
+      "(Unknown)"))
+
+(define (response-reason-phrase response)
+  "Return the reason phrase given in RESPONSE, or the standard
+reason phrase for the response's code."
+  (or (%response-reason-phrase response)
+      (code->reason-phrase (response-code response))))
+
+(define (text-content-type? type)
+  "Return #t if TYPE, a symbol as returned by `response-content-type',
+represents a textual type such as `text/plain'."
+  (let ((type (symbol->string type)))
+    (or (string-prefix? "text/" type)
+        (string-suffix? "/xml" type)
+        (string-suffix? "+xml" type))))
+
+(define (read-response port)
+  "Read an HTTP response from PORT.
+
+As a side effect, sets the encoding on PORT to
+ISO-8859-1 (latin-1), so that reading one character reads one byte.  See
+the discussion of character sets in \"HTTP Responses\" in the manual,
+for more information."
+  (set-port-encoding! port "ISO-8859-1")
+  (call-with-values (lambda () (read-response-line port))
+    (lambda (version code reason-phrase)
+      (make-response version code reason-phrase (read-headers port) port))))
+
+(define (adapt-response-version response version)
+  "Adapt the given response to a different HTTP version.  Returns a new
+HTTP response.
+
+The idea is that many applications might just build a response for the
+default HTTP version, and this method could handle a number of
+programmatic transformations to respond to older HTTP versions (0.9 and
+1.0).  But currently this function is a bit heavy-handed, just updating
+the version field."
+  (build-response #:code (response-code response)
+                  #:version version
+                  #:headers (response-headers response)
+                  #:port (response-port response)))
+
+(define (write-response r port)
+  "Write the given HTTP response to PORT.
+
+Returns a new response, whose ‘response-port’ will continue writing
+on PORT, perhaps using some transfer encoding."
+  (write-response-line (response-version r) (response-code r)
+                       (response-reason-phrase r) port)
+  (write-headers (response-headers r) port)
+  (put-string port "\r\n")
+  (if (eq? port (response-port r))
+      r
+      (make-response (response-version r) (response-code r)
+                     (response-reason-phrase r) (response-headers r) port)))
+
+(define (response-must-not-include-body? r)
+  "Returns ‘#t’ if the response R is not permitted to have a body.
+
+This is true for some response types, like those with code 304."
+  ;; RFC 2616, section 4.3.
+  (or (<= 100 (response-code r) 199)
+      (= (response-code r) 204)
+      (= (response-code r) 304)))
+
+(define (make-delimited-input-port port len keep-alive?)
+  "Return an input port that reads from PORT, and makes sure that
+exactly LEN bytes are available from PORT.  Closing the returned port
+closes PORT, unless KEEP-ALIVE? is true."
+  (define bytes-read 0)
+
+  (define (fail)
+    (bad-response "EOF while reading response body: ~a bytes of ~a"
+                  bytes-read len))
+
+  (define (read! bv start count)
+    ;; Read at most LEN bytes in total.  HTTP/1.1 doesn't say what to do
+    ;; when a server provides more than the Content-Length, but it seems
+    ;; wise to just stop reading at LEN.
+    (let ((count (min count (- len bytes-read))))
+      (let loop ((ret (get-bytevector-n! port bv start count)))
+        (cond ((eof-object? ret)
+               (if (= bytes-read len)
+                   0                              ; EOF
+                   (fail)))
+              ((and (zero? ret) (> count 0))
+               ;; Do not return zero since zero means EOF, so try again.
+               (loop (get-bytevector-n! port bv start count)))
+              (else
+               (set! bytes-read (+ bytes-read ret))
+               ret)))))
+
+  (define close
+    (and (not keep-alive?)
+         (lambda ()
+           (close-port port))))
+
+  (make-custom-binary-input-port "delimited input port" read! #f #f close))
+
+(define* (response-body-port r #:key (decode? #t) (keep-alive? #t))
+  "Return an input port from which the body of R can be read.  The
+encoding of the returned port is set according to R's ‘content-type’
+header, when it's textual, except if DECODE? is ‘#f’.  Return #f when
+no body is available.
+
+When KEEP-ALIVE? is ‘#f’, closing the returned port also closes R's
+response port."
+  (define port
+    (cond
+     ((member '(chunked) (response-transfer-encoding r))
+      (make-chunked-input-port (response-port r)
+                               #:keep-alive? keep-alive?))
+     ((response-content-length r)
+      => (lambda (len)
+           (make-delimited-input-port (response-port r)
+                                      len keep-alive?)))
+     ((response-must-not-include-body? r)
+      #f)
+     ((or (memq 'close (response-connection r))
+          (and (equal? (response-version r) '(1 . 0))
+               (not (memq 'keep-alive (response-connection r)))))
+      (response-port r))
+     (else
+      ;; Here we have a message with no transfer encoding, no
+      ;; content-length, and a response that won't necessarily be closed
+      ;; by the server.  Not much we can do; assume that the client
+      ;; knows how to handle it.
+      (response-port r))))
+
+  (when (and decode? port)
+    (match (response-content-type r)
+      (((? text-content-type?) . props)
+       (set-port-encoding! port
+                           (or (assq-ref props 'charset)
+                               "ISO-8859-1")))
+      (_ #f)))
+
+  port)
+
+(define (read-response-body r)
+  "Reads the response body from R, as a bytevector.  Returns
+‘#f’ if there was no response body."
+  (let ((body (and=> (response-body-port r #:decode? #f)
+                     get-bytevector-all)))
+    ;; Reading a body of length 0 will result in get-bytevector-all
+    ;; returning the EOF object.
+    (if (eof-object? body)
+        #vu8()
+        body)))
+
+(define (write-response-body r bv)
+  "Write BV, a bytevector, to the port corresponding to the HTTP
+response R."
+  (put-bytevector (response-port r) bv))
+
+(define-syntax define-response-accessor
+  (lambda (x)
+    (syntax-case x ()
+      ((_ field)
+       #'(define-response-accessor field #f))
+      ((_ field def) (identifier? #'field)
+       #`(define* (#,(datum->syntax
+                      #'field
+                      (symbol-append 'response- (syntax->datum #'field)))
+                   response
+                   #:optional (default def))
+           (cond
+            ((assq 'field (response-headers response)) => cdr)
+            (else default)))))))
+
+;; General headers
+;;
+(define-response-accessor cache-control '())
+(define-response-accessor connection '())
+(define-response-accessor date #f)
+(define-response-accessor pragma '())
+(define-response-accessor trailer '())
+(define-response-accessor transfer-encoding '())
+(define-response-accessor upgrade '())
+(define-response-accessor via '())
+(define-response-accessor warning '())
+
+;; Entity headers
+;;
+(define-response-accessor allow '())
+(define-response-accessor content-encoding '())
+(define-response-accessor content-language '())
+(define-response-accessor content-length #f)
+(define-response-accessor content-location #f)
+(define-response-accessor content-md5 #f)
+(define-response-accessor content-range #f)
+(define-response-accessor content-type #f)
+(define-response-accessor expires #f)
+(define-response-accessor last-modified #f)
+
+;; Response headers
+;;
+(define-response-accessor accept-ranges #f)
+(define-response-accessor age #f)
+(define-response-accessor etag #f)
+(define-response-accessor location #f)
+(define-response-accessor proxy-authenticate #f)
+(define-response-accessor retry-after #f)
+(define-response-accessor server #f)
+(define-response-accessor vary '())
+(define-response-accessor www-authenticate #f)