summaryrefslogtreecommitdiff
path: root/module/web/client.scm
diff options
context:
space:
mode:
Diffstat (limited to 'module/web/client.scm')
-rw-r--r--module/web/client.scm494
1 files changed, 494 insertions, 0 deletions
diff --git a/module/web/client.scm b/module/web/client.scm
new file mode 100644
index 000000000..75719e1d1
--- /dev/null
+++ b/module/web/client.scm
@@ -0,0 +1,494 @@
+;;; Web client
+
+;; Copyright (C) 2011, 2012, 2013, 2014, 2015, 2016, 2017, 2018 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 client) is a simple HTTP URL fetcher for Guile.
+;;;
+;;; In its current incarnation, (web client) is synchronous. If you
+;;; want to fetch a number of URLs at once, probably the best thing to
+;;; do is to write an event-driven URL fetcher, similar in structure to
+;;; the web server.
+;;;
+;;; Another option, good but not as performant, would be to use threads,
+;;; possibly via a thread pool.
+;;;
+;;; Code:
+
+(define-module (web client)
+ #:use-module (rnrs bytevectors)
+ #:use-module (ice-9 binary-ports)
+ #:use-module (ice-9 iconv)
+ #:use-module (ice-9 rdelim)
+ #:use-module (web request)
+ #:use-module (web response)
+ #:use-module (web uri)
+ #:use-module (web http)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-9)
+ #:use-module (srfi srfi-9 gnu)
+ #:use-module ((rnrs io ports)
+ #:prefix rnrs-ports:)
+ #:export (current-http-proxy
+ open-socket-for-uri
+ http-request
+ http-get
+ http-head
+ http-post
+ http-put
+ http-delete
+ http-trace
+ http-options))
+
+(define %http-receive-buffer-size
+ ;; Size of the HTTP receive buffer.
+ 65536)
+
+;; Autoload GnuTLS so that this module can be used even when GnuTLS is
+;; not available. At compile time, this yields "possibly unbound
+;; variable" warnings, but these are OK: we know that the variables will
+;; be bound if we need them, because (guix download) adds GnuTLS as an
+;; input in that case.
+
+;; XXX: Use this hack instead of #:autoload to avoid compilation errors.
+;; See <http://bugs.gnu.org/12202>.
+(module-autoload! (current-module)
+ '(gnutls) '(make-session connection-end/client))
+
+(define gnutls-module
+ (delay
+ (catch 'misc-error
+ (lambda ()
+ (let ((module (resolve-interface '(gnutls))))
+ ;; In some 2.1/2.2 installations installed alongside Guile 2.0, gnutls
+ ;; can be imported but the bindings are broken as "unknown type".
+ ;; Here we check that gnutls-version is the right type (a procedure)
+ ;; to make sure the bindings are ok.
+ (if (procedure? (module-ref module 'gnutls-version))
+ module
+ #f)))
+ (const #f))))
+
+(define (ensure-gnutls)
+ (if (not (force gnutls-module))
+ (throw 'gnutls-not-available "(gnutls) module not available")))
+
+(define current-http-proxy
+ (make-parameter (let ((proxy (getenv "http_proxy")))
+ (and (not (equal? proxy ""))
+ proxy))))
+
+(define (tls-wrap port server)
+ "Return PORT wrapped in a TLS connection to SERVER. SERVER must be a DNS
+host name without trailing dot."
+ (define (log level str)
+ (format (current-error-port)
+ "gnutls: [~a|~a] ~a" (getpid) level str))
+
+ (ensure-gnutls)
+
+ (let ((session (make-session connection-end/client)))
+ ;; Some servers such as 'cloud.github.com' require the client to support
+ ;; the 'SERVER NAME' extension. However, 'set-session-server-name!' is
+ ;; not available in older GnuTLS releases. See
+ ;; <http://bugs.gnu.org/18526> for details.
+ (if (module-defined? (force gnutls-module)
+ 'set-session-server-name!)
+ (set-session-server-name! session server-name-type/dns server)
+ (format (current-error-port)
+ "warning: TLS 'SERVER NAME' extension not supported~%"))
+
+ (set-session-transport-fd! session (fileno port))
+ (set-session-default-priority! session)
+
+ ;; The "%COMPAT" bit allows us to work around firewall issues (info
+ ;; "(gnutls) Priority Strings"); see <http://bugs.gnu.org/23311>.
+ ;; Explicitly disable SSLv3, which is insecure:
+ ;; <https://tools.ietf.org/html/rfc7568>.
+ (set-session-priorities! session "NORMAL:%COMPAT:-VERS-SSL3.0")
+
+ (set-session-credentials! session (make-certificate-credentials))
+
+ ;; Uncomment the following lines in case of debugging emergency.
+ ;;(set-log-level! 10)
+ ;;(set-log-procedure! log)
+
+ (handshake session)
+ ;; FIXME: It appears that session-record-port is entirely
+ ;; sufficient; it's already a port. The only value of this code is
+ ;; to keep a reference on "port", to keep it alive! To fix this we
+ ;; need to arrange to either hand GnuTLS its own fd to close, or to
+ ;; arrange a reference from the session-record-port to the
+ ;; underlying socket.
+ (let ((record (session-record-port session)))
+ (define (read! bv start count)
+ (define read-bv (get-bytevector-some record))
+ (if (eof-object? read-bv)
+ 0 ; read! returns 0 on eof-object
+ (let ((read-bv-len (bytevector-length read-bv)))
+ (bytevector-copy! read-bv 0 bv start (min read-bv-len count))
+ (when (< count read-bv-len)
+ (unget-bytevector record bv count (- read-bv-len count)))
+ read-bv-len)))
+ (define (write! bv start count)
+ (put-bytevector record bv start count)
+ (force-output record)
+ count)
+ (define (get-position)
+ (rnrs-ports:port-position record))
+ (define (set-position! new-position)
+ (rnrs-ports:set-port-position! record new-position))
+ (define (close)
+ (unless (port-closed? port)
+ (close-port port))
+ (unless (port-closed? record)
+ (close-port record)))
+ (setvbuf record 'block)
+ (make-custom-binary-input/output-port "gnutls wrapped port" read! write!
+ get-position set-position!
+ close))))
+
+(define (ensure-uri-reference uri-or-string)
+ (cond
+ ((string? uri-or-string) (string->uri-reference uri-or-string))
+ ((uri-reference? uri-or-string) uri-or-string)
+ (else (error "Invalid URI-reference" uri-or-string))))
+
+(define (open-socket-for-uri uri-or-string)
+ "Return an open input/output port for a connection to URI."
+ (define http-proxy (current-http-proxy))
+ (define uri (ensure-uri-reference (or http-proxy uri-or-string)))
+ (define addresses
+ (let ((port (uri-port uri)))
+ (delete-duplicates
+ (getaddrinfo (uri-host uri)
+ (cond (port => number->string)
+ ((uri-scheme uri) => symbol->string)
+ (else (error "Not an absolute URI" uri)))
+ (if port
+ AI_NUMERICSERV
+ 0))
+ (lambda (ai1 ai2)
+ (equal? (addrinfo:addr ai1) (addrinfo:addr ai2))))))
+ (define https?
+ (eq? 'https (uri-scheme uri)))
+ (define (open-socket)
+ (let loop ((addresses addresses))
+ (let* ((ai (car addresses))
+ (s (with-fluids ((%default-port-encoding #f))
+ ;; Restrict ourselves to TCP.
+ (socket (addrinfo:fam ai) SOCK_STREAM IPPROTO_IP))))
+ (catch 'system-error
+ (lambda ()
+ (connect s (addrinfo:addr ai))
+
+ ;; Buffer input and output on this port.
+ (setvbuf s 'block)
+ ;; If we're using a proxy, make a note of that.
+ (when http-proxy (set-http-proxy-port?! s #t))
+ s)
+ (lambda args
+ ;; Connection failed, so try one of the other addresses.
+ (close s)
+ (if (null? (cdr addresses))
+ (apply throw args)
+ (loop (cdr addresses))))))))
+
+ (let-syntax ((with-https-proxy
+ (syntax-rules ()
+ ((_ exp)
+ ;; For HTTPS URIs, honor 'https_proxy', not 'http_proxy'.
+ ;; FIXME: Proxying is not supported for https.
+ (let ((thunk (lambda () exp)))
+ (if (and https?
+ current-http-proxy)
+ (parameterize ((current-http-proxy #f))
+ (when (and=> (getenv "https_proxy")
+ (negate string-null?))
+ (format (current-error-port)
+ "warning: 'https_proxy' is ignored~%"))
+ (thunk))
+ (thunk)))))))
+ (with-https-proxy
+ (let ((s (open-socket)))
+ ;; Buffer input and output on this port.
+ (setvbuf s 'block %http-receive-buffer-size)
+
+ (if https?
+ (tls-wrap s (uri-host uri))
+ s)))))
+
+(define (extend-request r k v . additional)
+ (let ((r (set-field r (request-headers)
+ (assoc-set! (copy-tree (request-headers r))
+ k v))))
+ (if (null? additional)
+ r
+ (apply extend-request r additional))))
+
+;; -> request body
+(define (sanitize-request request body)
+ "\"Sanitize\" the given request and body, ensuring that they are
+complete and coherent. This method is most useful for methods that send
+data to the server, like POST, but can be used for any method. Return
+two values: a request and a bytevector, possibly the same ones that were
+passed as arguments.
+
+If BODY is a string, encodes the string to a bytevector, in an encoding
+appropriate for REQUEST. 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.
+Authors are advised not to rely on the procedure being called at any
+particular time.
+
+Note that we rely on the request itself already having been validated,
+as is the case by default with a request returned by `build-request'."
+ (cond
+ ((not body)
+ (let ((length (request-content-length request)))
+ (if length
+ ;; FIXME make this stricter: content-length header should be
+ ;; prohibited if there's no body, even if the content-length
+ ;; is 0.
+ (unless (zero? length)
+ (error "content-length, but no body"))
+ (when (assq 'transfer-encoding (request-headers request))
+ (error "transfer-encoding not allowed with no body")))
+ (values request #vu8())))
+ ((string? body)
+ (let* ((type (request-content-type request '(text/plain)))
+ (declared-charset (assq-ref (cdr type) 'charset))
+ (charset (or declared-charset "utf-8")))
+ (sanitize-request
+ (if declared-charset
+ request
+ (extend-request request 'content-type
+ `(,@type (charset . ,charset))))
+ (string->bytevector body charset))))
+ ((procedure? body)
+ (let* ((type (request-content-type request
+ '(text/plain)))
+ (declared-charset (assq-ref (cdr type) 'charset))
+ (charset (or declared-charset "utf-8")))
+ (sanitize-request
+ (if declared-charset
+ request
+ (extend-request request 'content-type
+ `(,@type (charset . ,charset))))
+ (call-with-encoded-output-string charset body))))
+ ((not (bytevector? body))
+ (error "unexpected body type"))
+ (else
+ (values (let ((rlen (request-content-length request))
+ (blen (bytevector-length body)))
+ (cond
+ (rlen (if (= rlen blen)
+ request
+ (error "bad content-length" rlen blen)))
+ (else (extend-request request 'content-length blen))))
+ body))))
+
+(define (decode-response-body response body)
+ ;; `body' is either #f or a bytevector.
+ (cond
+ ((not body) body)
+ ((bytevector? body)
+ (let ((rlen (response-content-length response))
+ (blen (bytevector-length body)))
+ (cond
+ ((and rlen (not (= rlen blen)))
+ (error "bad content-length" rlen blen))
+ ((response-content-type response)
+ => (lambda (type)
+ (cond
+ ((text-content-type? (car type))
+ ;; RFC 2616 3.7.1: "When no explicit charset parameter is
+ ;; provided by the sender, media subtypes of the "text"
+ ;; type are defined to have a default charset value of
+ ;; "ISO-8859-1" when received via HTTP."
+ (bytevector->string body (or (assq-ref (cdr type) 'charset)
+ "iso-8859-1")))
+ (else body))))
+ (else body))))
+ (else
+ (error "unexpected body type" body))))
+
+(define* (http-request uri #:key
+ (body #f)
+ (port (open-socket-for-uri uri))
+ (method 'GET)
+ (version '(1 . 1))
+ (keep-alive? #f)
+ (headers '())
+ (decode-body? #t)
+ (streaming? #f)
+ (request
+ (build-request
+ (ensure-uri-reference uri)
+ #:method method
+ #:version version
+ #:headers (if keep-alive?
+ headers
+ (cons '(connection close) headers))
+ #:port port)))
+ "Connect to the server corresponding to URI and ask for the resource,
+using METHOD, defaulting to ‘GET’. If you already have a port open,
+pass it as PORT. The port will be closed at the end of the request
+unless KEEP-ALIVE? is true. Any extra headers in the alist HEADERS will
+be added to the request.
+
+If BODY is not ‘#f’, a message body will also be sent with the HTTP
+request. If BODY is a string, it is encoded according to the
+content-type in HEADERS, defaulting to UTF-8. Otherwise BODY should be
+a bytevector, or ‘#f’ for no body. Although it's allowed to send a
+message body along with any request, usually only POST and PUT requests
+have bodies. See ‘http-put’ and ‘http-post’ documentation, for more.
+
+If DECODE-BODY? is true, as is the default, the body of the
+response will be decoded to string, if it is a textual content-type.
+Otherwise it will be returned as a bytevector.
+
+However, if STREAMING? is true, instead of eagerly reading the response
+body from the server, this function only reads off the headers. The
+response body will be returned as a port on which the data may be read.
+Unless KEEP-ALIVE? is true, the port will be closed after the full
+response body has been read.
+
+Returns two values: the response read from the server, and the response
+body as a string, bytevector, #f value, or as a port (if STREAMING? is
+true)."
+ (call-with-values (lambda () (sanitize-request request body))
+ (lambda (request body)
+ (let ((request (write-request request port)))
+ (when body
+ (write-request-body request body))
+ (force-output (request-port request))
+ (let ((response (read-response port)))
+ (cond
+ ((eq? (request-method request) 'HEAD)
+ (unless keep-alive?
+ (close-port port))
+ (values response #f))
+ (streaming?
+ (values response
+ (response-body-port response
+ #:keep-alive? keep-alive?
+ #:decode? decode-body?)))
+ (else
+ (let ((body (read-response-body response)))
+ (unless keep-alive?
+ (close-port port))
+ (values response
+ (if decode-body?
+ (decode-response-body response body)
+ body))))))))))
+
+(define-syntax-rule (define-http-verb http-verb method doc)
+ (define* (http-verb uri #:key
+ (body #f)
+ (port (open-socket-for-uri uri))
+ (version '(1 . 1))
+ (keep-alive? #f)
+ (headers '())
+ (decode-body? #t)
+ (streaming? #f))
+ doc
+ (http-request uri
+ #:body body #:method method
+ #:port port #:version version #:keep-alive? keep-alive?
+ #:headers headers #:decode-body? decode-body?
+ #:streaming? streaming?)))
+
+(define-http-verb http-get
+ 'GET
+ "Fetch message headers for the given URI using the HTTP \"GET\"
+method.
+
+This function invokes ‘http-request’, with the \"GET\" method. See
+‘http-request’ for full documentation on the various keyword arguments
+that are accepted by this function.
+
+Returns two values: the resulting response, and the response body.")
+
+(define-http-verb http-head
+ 'HEAD
+ "Fetch message headers for the given URI using the HTTP \"HEAD\"
+method.
+
+This function invokes ‘http-request’, with the \"HEAD\" method. See
+‘http-request’ for full documentation on the various keyword arguments
+that are accepted by this function.
+
+Returns two values: the resulting response, and ‘#f’. Responses to HEAD
+requests do not have a body. The second value is only returned so that
+other procedures can treat all of the http-foo verbs identically.")
+
+(define-http-verb http-post
+ 'POST
+ "Post data to the given URI using the HTTP \"POST\" method.
+
+This function invokes ‘http-request’, with the \"POST\" method. See
+‘http-request’ for full documentation on the various keyword arguments
+that are accepted by this function.
+
+Returns two values: the resulting response, and the response body.")
+
+(define-http-verb http-put
+ 'PUT
+ "Put data at the given URI using the HTTP \"PUT\" method.
+
+This function invokes ‘http-request’, with the \"PUT\" method. See
+‘http-request’ for full documentation on the various keyword arguments
+that are accepted by this function.
+
+Returns two values: the resulting response, and the response body.")
+
+(define-http-verb http-delete
+ 'DELETE
+ "Delete data at the given URI using the HTTP \"DELETE\" method.
+
+This function invokes ‘http-request’, with the \"DELETE\" method. See
+‘http-request’ for full documentation on the various keyword arguments
+that are accepted by this function.
+
+Returns two values: the resulting response, and the response body.")
+
+(define-http-verb http-trace
+ 'TRACE
+ "Send an HTTP \"TRACE\" request.
+
+This function invokes ‘http-request’, with the \"TRACE\" method. See
+‘http-request’ for full documentation on the various keyword arguments
+that are accepted by this function.
+
+Returns two values: the resulting response, and the response body.")
+
+(define-http-verb http-options
+ 'OPTIONS
+ "Query characteristics of an HTTP resource using the HTTP \"OPTIONS\"
+method.
+
+This function invokes ‘http-request’, with the \"OPTIONS\" method. See
+‘http-request’ for full documentation on the various keyword arguments
+that are accepted by this function.
+
+Returns two values: the resulting response, and the response body.")