From unknown Fri Jun 20 07:15:03 2025 Content-Disposition: inline Content-Transfer-Encoding: quoted-printable MIME-Version: 1.0 X-Mailer: MIME-tools 5.509 (Entity 5.509) Content-Type: text/plain; charset=utf-8 From: bug#24075 <24075@debbugs.gnu.org> To: bug#24075 <24075@debbugs.gnu.org> Subject: Status: tls/https support in Guile (through r6rs binary ports?) Reply-To: bug#24075 <24075@debbugs.gnu.org> Date: Fri, 20 Jun 2025 14:15:03 +0000 retitle 24075 tls/https support in Guile (through r6rs binary ports?) reassign 24075 guile submitter 24075 Christopher Allan Webber severity 24075 normal thanks From debbugs-submit-bounces@debbugs.gnu.org Tue Jul 26 11:56:13 2016 Received: (at submit) by debbugs.gnu.org; 26 Jul 2016 15:56:13 +0000 Received: from localhost ([127.0.0.1]:38311 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1bS4iL-0000Vc-58 for submit@debbugs.gnu.org; Tue, 26 Jul 2016 11:56:13 -0400 Received: from eggs.gnu.org ([208.118.235.92]:37531) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1bS4iK-0000VP-9S for submit@debbugs.gnu.org; Tue, 26 Jul 2016 11:56:12 -0400 Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1bS4iE-0003aT-Am for submit@debbugs.gnu.org; Tue, 26 Jul 2016 11:56:07 -0400 X-Spam-Checker-Version: SpamAssassin 3.3.2 (2011-06-06) on eggs.gnu.org X-Spam-Level: X-Spam-Status: No, score=-0.5 required=5.0 tests=BAYES_05 autolearn=disabled version=3.3.2 Received: from lists.gnu.org ([2001:4830:134:3::11]:53131) by eggs.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1bS4iE-0003a9-80 for submit@debbugs.gnu.org; Tue, 26 Jul 2016 11:56:06 -0400 Received: from eggs.gnu.org ([2001:4830:134:3::10]:56718) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1bS4iB-0006sM-UC for bug-guile@gnu.org; Tue, 26 Jul 2016 11:56:04 -0400 Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1bS4i7-0003Yy-Mh for bug-guile@gnu.org; Tue, 26 Jul 2016 11:56:02 -0400 Received: from dustycloud.org ([50.116.34.160]:53740) by eggs.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1bS4i7-0003XZ-IS for bug-guile@gnu.org; Tue, 26 Jul 2016 11:55:59 -0400 Received: from oolong (localhost [127.0.0.1]) by dustycloud.org (Postfix) with ESMTPS id 5E7AA2672A for ; Tue, 26 Jul 2016 11:55:47 -0400 (EDT) User-agent: mu4e 0.9.16; emacs 24.5.1 From: Christopher Allan Webber To: bug-guile@gnu.org Subject: tls/https support in Guile (through r6rs binary ports?) Date: Tue, 26 Jul 2016 10:55:46 -0500 Message-ID: <8760rss8al.fsf@dustycloud.org> MIME-Version: 1.0 Content-Type: text/plain X-detected-operating-system: by eggs.gnu.org: GNU/Linux 2.2.x-3.x [generic] X-detected-operating-system: by eggs.gnu.org: GNU/Linux 2.6.x X-Received-From: 2001:4830:134:3::11 X-Spam-Score: -4.0 (----) X-Debbugs-Envelope-To: submit X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: debbugs-submit-bounces@debbugs.gnu.org Sender: "Debbugs-submit" X-Spam-Score: -4.0 (----) Guile lacks https support by default, which is a really glaring omission in any modern language! I've submitted some code adapted from Guix previously as a step towards adding https support: https://lists.gnu.org/archive/html/guile-devel/2015-09/msg00031.html While it can be pulled off through some gnutls hacks, these have problems. Unfortunately, it seems that the file descriptor is leaked: http://debbugs.gnu.org/cgi/bugreport.cgi?bug=20145 I've been told on IRC that the "right solution" is to add r6rs style binary ports: http://www.r6rs.org/final/html/r6rs-lib/r6rs-lib-Z-H-9.html So maybe that's what should be done? Anyway, I think this is one of *the most important things* that Guile currently lacks. (It's held me back from considering Guile as a serious choice for at least one project, myself!) Hope it can be fixed! - Chris From debbugs-submit-bounces@debbugs.gnu.org Thu Aug 04 16:37:29 2016 Received: (at 24075) by debbugs.gnu.org; 4 Aug 2016 20:37:29 +0000 Received: from localhost ([127.0.0.1]:55891 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1bVPOT-0002p6-9I for submit@debbugs.gnu.org; Thu, 04 Aug 2016 16:37:29 -0400 Received: from pb-sasl2.pobox.com ([64.147.108.67]:63410 helo=sasl.smtp.pobox.com) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1bVPOR-0002oy-KR for 24075@debbugs.gnu.org; Thu, 04 Aug 2016 16:37:28 -0400 Received: from sasl.smtp.pobox.com (unknown [127.0.0.1]) by pb-sasl2.pobox.com (Postfix) with ESMTP id 156AB302DB; Thu, 4 Aug 2016 16:37:26 -0400 (EDT) DKIM-Signature: v=1; a=rsa-sha1; c=relaxed; d=pobox.com; h=from:to:cc :subject:references:date:in-reply-to:message-id:mime-version :content-type; s=sasl; bh=VhQDBCOtxIDqKJ9zmLrCgAm+zPg=; b=sXA84z AX4p3cADa2SAw/hQn7zbmN03OrgqFVMRCeMSxO27VWqVNN3AQwges4RGbSok6zcW 268hx42BBJZlK5aY6UG1Txe6VgayetldaeIig4Xt1Nu5Yh8BeVUM7ignUJN7624a kVAgtF8odX92lBt2quIKk7Y/1kT2pDZGp25RE= DomainKey-Signature: a=rsa-sha1; c=nofws; d=pobox.com; h=from:to:cc :subject:references:date:in-reply-to:message-id:mime-version :content-type; q=dns; s=sasl; b=eUmzonYPQEkkkEIBeG171Qn+pDIeyKRs qSEydiIjKC7NH/3R0CRGVKWFm1NyUMpHxanco1ZzCKcJp9sOHSkKZT3V2mXZjThP wWjmbgjaWTl1grv0yCAYR6STHlUKOYYGn/nY646p1Z+HO5IKuCZOmd53Jed5yrhI yzR+jnWTvDA= Received: from pb-sasl2.nyi.icgroup.com (unknown [127.0.0.1]) by pb-sasl2.pobox.com (Postfix) with ESMTP id 0DF1C302DA; Thu, 4 Aug 2016 16:37:26 -0400 (EDT) Received: from clucks (unknown [88.160.190.192]) (using TLSv1 with cipher ECDHE-RSA-AES256-SHA (256/256 bits)) (No client certificate requested) by pb-sasl2.pobox.com (Postfix) with ESMTPSA id 26B13302D9; Thu, 4 Aug 2016 16:37:25 -0400 (EDT) From: Andy Wingo To: Christopher Allan Webber Subject: Re: bug#24075: tls/https support in Guile (through r6rs binary ports?) References: <8760rss8al.fsf@dustycloud.org> Date: Thu, 04 Aug 2016 22:37:17 +0200 In-Reply-To: <8760rss8al.fsf@dustycloud.org> (Christopher Allan Webber's message of "Tue, 26 Jul 2016 10:55:46 -0500") Message-ID: <87a8gstgn6.fsf@pobox.com> User-Agent: Gnus/5.13 (Gnus v5.13) Emacs/24.5 (gnu/linux) MIME-Version: 1.0 Content-Type: text/plain X-Pobox-Relay-ID: 40B77E78-5A83-11E6-ABD8-28A6F1301B6D-02397024!pb-sasl2.pobox.com X-Spam-Score: -1.2 (-) X-Debbugs-Envelope-To: 24075 Cc: 24075@debbugs.gnu.org X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: debbugs-submit-bounces@debbugs.gnu.org Sender: "Debbugs-submit" X-Spam-Score: -1.2 (-) On Tue 26 Jul 2016 17:55, Christopher Allan Webber writes: > I've been told on IRC that the "right solution" is to add r6rs style > binary ports: > > http://www.r6rs.org/final/html/r6rs-lib/r6rs-lib-Z-H-9.html > > So maybe that's what should be done? I did this :) Missing some tests though and indeed completely untested. Please give it a go then we can see about implementing TLS ports on top of that. Andy From debbugs-submit-bounces@debbugs.gnu.org Sun Aug 21 11:58:34 2016 Received: (at 24075) by debbugs.gnu.org; 21 Aug 2016 15:58:34 +0000 Received: from localhost ([127.0.0.1]:35981 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1bbV8r-0000NF-VX for submit@debbugs.gnu.org; Sun, 21 Aug 2016 11:58:34 -0400 Received: from dustycloud.org ([50.116.34.160]:55634) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1bbV8p-0000N7-UN for 24075@debbugs.gnu.org; Sun, 21 Aug 2016 11:58:32 -0400 Received: from oolong (localhost [127.0.0.1]) by dustycloud.org (Postfix) with ESMTPS id 2A0B3266EB; Sun, 21 Aug 2016 11:58:30 -0400 (EDT) References: <8760rss8al.fsf@dustycloud.org> <87a8gstgn6.fsf@pobox.com> User-agent: mu4e 0.9.16; emacs 24.5.1 From: Christopher Allan Webber To: Andy Wingo Subject: Re: bug#24075: tls/https support in Guile (through r6rs binary ports?) In-reply-to: <87a8gstgn6.fsf@pobox.com> Date: Sun, 21 Aug 2016 10:58:29 -0500 Message-ID: <878tvqqfkq.fsf@dustycloud.org> MIME-Version: 1.0 Content-Type: multipart/mixed; boundary="=-=-=" X-Spam-Score: -0.2 (/) X-Debbugs-Envelope-To: 24075 Cc: 24075@debbugs.gnu.org X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: debbugs-submit-bounces@debbugs.gnu.org Sender: "Debbugs-submit" X-Spam-Score: -0.2 (/) --=-=-= Content-Type: text/plain Andy Wingo writes: > On Tue 26 Jul 2016 17:55, Christopher Allan Webber writes: > >> I've been told on IRC that the "right solution" is to add r6rs style >> binary ports: >> >> http://www.r6rs.org/final/html/r6rs-lib/r6rs-lib-Z-H-9.html >> >> So maybe that's what should be done? > > I did this :) Missing some tests though and indeed completely > untested. Please give it a go then we can see about implementing TLS > ports on top of that. > > Andy Here's two patches. The first fixes some of the section names in the r6rs-ports.test file, and can be applied to master immediately. The second patch is the tests. I ported tests in the most naive way possible: copy/pasting the custom-binary-input-port and custom-binary-output-port tests and adjusting for the custom-binary-input/output-port. It's not ideal, a bit spaghetti'ish, but maybe that's okay? I'm not sure. However, two are not working: one fails and one errors, with the following: FAIL: r6rs-ports.test: 8.2.13 Input/output ports: custom binary input/output port supports `port-position', not `set-port-position!' - arguments: (expected-value 42 actual-value #f) ERROR: r6rs-ports.test: 8.2.13 Input/output ports: custom binary input/output port unbuffered & 'port-position' - arguments: ((misc-error "seek" "port is not seekable" (#) #f)) I'm not sure if this is an error on my side, features not supported by the new ports, or legitimate test failures. I'll try to do more research, but if someone who's more knowledgable knows what's going on, maybe that would speed things up. - Chris --=-=-= Content-Type: text/x-patch Content-Disposition: inline; filename=0001-Correct-section-number-for-Input-Ports-tests.patch >From 1f9d6ea0ae18557789c39342d04aec33d2156207 Mon Sep 17 00:00:00 2001 From: Christopher Allan Webber Date: Thu, 11 Aug 2016 17:06:10 -0500 Subject: [PATCH 1/2] Correct section number for "Input Ports" tests. * test-suite/tests/r6rs-ports.test: Correct "Input Ports" section heading from "7.2.7" -> "8.2.7", "7.2.5" -> "8.2.5", "7.2.8" -> "8.2.8", and "7.2.11" -> "8.2.11". --- test-suite/tests/r6rs-ports.test | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/test-suite/tests/r6rs-ports.test b/test-suite/tests/r6rs-ports.test index b3f11bb..9aa605b 100644 --- a/test-suite/tests/r6rs-ports.test +++ b/test-suite/tests/r6rs-ports.test @@ -74,7 +74,7 @@ receiver)))) -(with-test-prefix "7.2.5 End-of-File Object" +(with-test-prefix "8.2.5 End-of-File Object" (pass-if "eof-object" (and (eqv? (eof-object) (eof-object)) @@ -84,7 +84,7 @@ (port-eof? (open-input-string "")))) -(with-test-prefix "7.2.8 Binary Input" +(with-test-prefix "8.2.8 Binary Input" (pass-if "get-u8" (let ((port (open-input-string "A"))) @@ -236,7 +236,7 @@ (lambda () #t)) ;; close-port "rw"))) -(with-test-prefix "7.2.11 Binary Output" +(with-test-prefix "8.2.11 Binary Output" (pass-if "put-u8" (let ((port (make-soft-output-port))) @@ -328,7 +328,7 @@ (delete-file filename)) -(with-test-prefix "7.2.7 Input Ports" +(with-test-prefix "8.2.7 Input Ports" (with-test-prefix "open-file-input-port" (test-input-file-opener open-file-input-port (test-file))) -- 2.9.2 --=-=-= Content-Type: text/x-patch; charset=utf-8 Content-Disposition: inline; filename=0002-Add-tests-for-make-custom-binary-input-output-port.patch Content-Transfer-Encoding: 8bit >From 297dc06f1bfbb49f636018944f0a1c114d6778ea Mon Sep 17 00:00:00 2001 From: Christopher Allan Webber Date: Sat, 20 Aug 2016 16:20:53 -0500 Subject: [PATCH 2/2] Add tests for make-custom-binary-input/output-port * test-suite/tests/r6rs-ports.test ("8.2.13 Input/output ports"): Add tests for custom binary input/output ports, copied from existing binary input and binary output tests. --- test-suite/tests/r6rs-ports.test | 383 ++++++++++++++++++++++++++++++++++++++- 1 file changed, 382 insertions(+), 1 deletion(-) diff --git a/test-suite/tests/r6rs-ports.test b/test-suite/tests/r6rs-ports.test index 9aa605b..94d9fc0 100644 --- a/test-suite/tests/r6rs-ports.test +++ b/test-suite/tests/r6rs-ports.test @@ -1059,11 +1059,392 @@ not `set-port-position!'" values)) (delete-file filename))) +;; Used for a lot of the make-custom-input/output tests to stub out +;; the read/write section for whatever part we're ignoring +(define dummy-write! (const 0)) +(define dummy-read! (const 0)) + (with-test-prefix "8.2.13 Input/output ports" (with-test-prefix "open-file-input/output-port [output]" (test-output-file-opener open-file-input/output-port (test-file))) (with-test-prefix "open-file-input/output-port [input]" - (test-input-file-opener open-file-input/output-port (test-file)))) + (test-input-file-opener open-file-input/output-port (test-file))) + + ;; Custom binary input/output tests. Most of these are simple + ;; ports of the custom-binary-input-port tests or custom-binary-ouput-port + ;; tests, simply ported to use a custom-binary-input/output port. + ;; The copy-pasta is strong here; a diet lighter in spaghetti may wish + ;; to make the previous tests more reusable. + (pass-if "make-custom-binary-input/output-port" + (let* ((source (make-bytevector 7777)) + (read! (let ((pos 0) + (len (bytevector-length source))) + (lambda (bv start count) + (let ((amount (min count (- len pos)))) + (if (> amount 0) + (bytevector-copy! source pos + bv start amount)) + (set! pos (+ pos amount)) + amount)))) + (write! (lambda (x y z) 0)) + (port (make-custom-binary-input/output-port + "the port" read! write! + #f #f #f))) + (and (binary-port? port) + (input-port? port) + (output-port? port) + (bytevector=? (get-bytevector-all port) source) + (not (port-has-port-position? port)) + (not (port-has-set-port-position!? port))))) + + (pass-if-equal "make-custom-binary-input/output-port uses ISO-8859-1 (Guile \ +extension) [input]" + "©©" + (with-fluids ((%default-port-encoding "UTF-8")) + (let* ((source #vu8(194 169 194 169)) + (read! (let ((pos 0) + (len (bytevector-length source))) + (lambda (bv start count) + (let ((amount (min count (- len pos)))) + (if (> amount 0) + (bytevector-copy! source pos + bv start amount)) + (set! pos (+ pos amount)) + amount)))) + (port (make-custom-binary-input/output-port + "the port" read! dummy-write! + #f #f #f))) + (get-string-all port)))) + + (pass-if "custom binary input/output port does not support `port-position'" + (let* ((str "Hello Port!") + (source (open-bytevector-input-port + (u8-list->bytevector + (map char->integer (string->list str))))) + (read! (lambda (bv start count) + (let ((r (get-bytevector-n! source bv start count))) + (if (eof-object? r) + 0 + r)))) + (port (make-custom-binary-input/output-port + "the port" read! dummy-write! + #f #f #f))) + (not (or (port-has-port-position? port) + (port-has-set-port-position!? port))))) + + (pass-if-exception "custom binary input/output port 'read!' returns too much" + exception:out-of-range + ;; In Guile <= 2.0.9 this would segfault. + (let* ((read! (lambda (bv start count) + (+ count 4242))) + (port (make-custom-binary-input/output-port + "the port" read! dummy-write! + #f #f #f))) + (get-bytevector-all port))) + + (pass-if-equal "custom binary input/output port supports `port-position', \ +not `set-port-position!'" + 42 + (let ((port (make-custom-binary-input/output-port + "the port" (const 0) dummy-write! + (const 42) #f #f))) + (and (port-has-port-position? port) + (not (port-has-set-port-position!? port)) + (port-position port)))) + + (pass-if "custom binary input/output port supports `port-position'" + (let* ((str "Hello Port!") + (source (open-bytevector-input-port + (u8-list->bytevector + (map char->integer (string->list str))))) + (read! (lambda (bv start count) + (let ((r (get-bytevector-n! source bv start count))) + (if (eof-object? r) + 0 + r)))) + (get-pos (lambda () + (port-position source))) + (set-pos! (lambda (pos) + (set-port-position! source pos))) + (port (make-custom-binary-input/output-port + "the port" read! dummy-write! + get-pos set-pos! #f))) + + (and (port-has-port-position? port) + (= 0 (port-position port)) + (port-has-set-port-position!? port) + (begin + (set-port-position! port 6) + (= 6 (port-position port))) + (bytevector=? (get-bytevector-all port) + (u8-list->bytevector + (map char->integer (string->list "Port!"))))))) + + (pass-if-equal "custom binary input/output port buffered partial reads" + "Hello Port!" + ;; Check what happens when READ! returns less than COUNT bytes. + (let* ((src (string->utf8 "Hello Port!")) + (chunks '(2 4 5)) ; provide 2 bytes, then 4, etc. + (offset 0) + (read! (lambda (bv start count) + (match chunks + ((count rest ...) + (bytevector-copy! src offset bv start count) + (set! chunks rest) + (set! offset (+ offset count)) + count) + (() + 0)))) + (port (make-custom-binary-input/output-port + "the port" read! dummy-write! + #f #f #f))) + (get-string-all port))) + + (pass-if-equal "custom binary input/output port unbuffered & 'port-position'" + '(0 2 5 11) + ;; Check that the value returned by 'port-position' is correct, and + ;; that each 'port-position' call leads one call to the + ;; 'get-position' method. + (let* ((str "Hello Port!") + (output (make-bytevector (string-length str))) + (source (with-fluids ((%default-port-encoding "UTF-8")) + (open-string-input-port str))) + (read! (lambda (bv start count) + (let ((r (get-bytevector-n! source bv start count))) + (if (eof-object? r) + 0 + r)))) + (pos '()) + (get-pos (lambda () + (let ((p (port-position source))) + (set! pos (cons p pos)) + p))) + (port (make-custom-binary-input/output-port + "the port" read! dummy-write! + get-pos #f #f))) + (setvbuf port 'none) + (and (= 0 (port-position port)) + (begin + (get-bytevector-n! port output 0 2) + (= 2 (port-position port))) + (begin + (get-bytevector-n! port output 2 3) + (= 5 (port-position port))) + (let ((bv (string->utf8 (get-string-all port)))) + (bytevector-copy! bv 0 output 5 (bytevector-length bv)) + (= (string-length str) (port-position port))) + (bytevector=? output (string->utf8 str)) + (reverse pos)))) + + (pass-if-equal "custom binary input/output port unbuffered & 'read!' calls" + `((2 "He") (3 "llo") (42 " Port!")) + (let* ((str "Hello Port!") + (source (with-fluids ((%default-port-encoding "UTF-8")) + (open-string-input-port str))) + (reads '()) + (read! (lambda (bv start count) + (set! reads (cons count reads)) + (let ((r (get-bytevector-n! source bv start count))) + (if (eof-object? r) + 0 + r)))) + (port (make-custom-binary-input/output-port + "the port" read! dummy-write! + #f #f #f))) + + (setvbuf port 'none) + (let ((ret (list (get-bytevector-n port 2) + (get-bytevector-n port 3) + (get-bytevector-n port 42)))) + (zip (reverse reads) + (map (lambda (obj) + (if (bytevector? obj) + (utf8->string obj) + obj)) + ret))))) + + (pass-if-equal "custom binary input/output port unbuffered & 'get-string-all'" + (make-string 1000 #\a) + ;; In Guile 2.0.11 this test would lead to a buffer overrun followed + ;; by an assertion failure. See . + (let* ((input (with-fluids ((%default-port-encoding #f)) + (open-input-string (make-string 1000 #\a)))) + (read! (lambda (bv index count) + (let ((n (get-bytevector-n! input bv index + count))) + (if (eof-object? n) 0 n)))) + (port (make-custom-binary-input/output-port + "foo" read! dummy-write! + #f #f #f))) + (setvbuf port 'none) + (get-string-all port))) + + (pass-if-equal "custom binary input/output port unbuffered UTF-8 & \ +'get-string-all'" + (make-string 1000 #\λ) + ;; In Guile 2.0.11 this test would lead to a buffer overrun followed + ;; by an assertion failure. See . + (let* ((input (with-fluids ((%default-port-encoding "UTF-8")) + (open-input-string (make-string 1000 #\λ)))) + (read! (lambda (bv index count) + (let ((n (get-bytevector-n! input bv index + count))) + (if (eof-object? n) 0 n)))) + (port (make-custom-binary-input/output-port + "foo" read! dummy-write! + #f #f #f))) + (setvbuf port 'none) + (set-port-encoding! port "UTF-8") + (get-string-all port))) + + (pass-if-equal "custom binary input/output port, unbuffered then buffered" + `((6 "Lorem ") (12 "ipsum dolor ") (777 "sit amet, consectetur…") + (777 ,(eof-object))) + (let* ((str "Lorem ipsum dolor sit amet, consectetur…") + (source (with-fluids ((%default-port-encoding "UTF-8")) + (open-string-input-port str))) + (reads '()) + (read! (lambda (bv start count) + (set! reads (cons count reads)) + (let ((r (get-bytevector-n! source bv start count))) + (if (eof-object? r) + 0 + r)))) + (port (make-custom-binary-input/output-port + "the port" read! dummy-write! + #f #f #f))) + + (setvbuf port 'none) + (let ((ret (list (get-bytevector-n port 6) + (get-bytevector-n port 12) + (begin + (setvbuf port 'block 777) + (get-bytevector-n port 42)) + (get-bytevector-n port 42)))) + (zip (reverse reads) + (map (lambda (obj) + (if (bytevector? obj) + (utf8->string obj) + obj)) + ret))))) + + (pass-if-equal "custom binary input/output port, buffered then unbuffered" + `((18 + 42 14 ; scm_c_read tries to fill the 42-byte buffer + 42) + ("Lorem " "ipsum dolor " "sit amet, consectetur bla…" ,(eof-object))) + (let* ((str "Lorem ipsum dolor sit amet, consectetur bla…") + (source (with-fluids ((%default-port-encoding "UTF-8")) + (open-string-input-port str))) + (reads '()) + (read! (lambda (bv start count) + (set! reads (cons count reads)) + (let ((r (get-bytevector-n! source bv start count))) + (if (eof-object? r) + 0 + r)))) + (port (make-custom-binary-input/output-port + "the port" read! dummy-write! + #f #f #f))) + + (setvbuf port 'block 18) + (let ((ret (list (get-bytevector-n port 6) + (get-bytevector-n port 12) + (begin + (setvbuf port 'none) + (get-bytevector-n port 42)) + (get-bytevector-n port 42)))) + (list (reverse reads) + (map (lambda (obj) + (if (bytevector? obj) + (utf8->string obj) + obj)) + ret))))) + + (pass-if "custom binary input/output port `close-proc' is called" + (let* ((closed? #f) + (read! (lambda (bv start count) 0)) + (get-pos (lambda () 0)) + (set-pos! (lambda (pos) #f)) + (close! (lambda () (set! closed? #t))) + (port (make-custom-binary-input/output-port + "the port" read! dummy-write! + get-pos set-pos! close!))) + + (close-port port) + (gc) ; Test for marking a closed port. + closed?)) + + (pass-if "make-custom-binary-input/output-port [partial writes]" + (let* ((source (uint-list->bytevector (iota 333) + (native-endianness) 2)) + (sink (make-bytevector (bytevector-length source))) + (sink-pos 0) + (eof? #f) + (write! (lambda (bv start count) + (if (= 0 count) + (begin + (set! eof? #t) + 0) + (let ((u8 (bytevector-u8-ref bv start))) + ;; Get one byte at a time. + (bytevector-u8-set! sink sink-pos u8) + (set! sink-pos (+ 1 sink-pos)) + 1)))) + (port (make-custom-binary-input/output-port + "cbop" dummy-read! write! + #f #f #f))) + (put-bytevector port source) + (force-output port) + (and (= sink-pos (bytevector-length source)) + (not eof?) + (bytevector=? sink source)))) + + (pass-if "make-custom-binary-input/output-port [full writes]" + (let* ((source (uint-list->bytevector (iota 333) + (native-endianness) 2)) + (sink (make-bytevector (bytevector-length source))) + (sink-pos 0) + (eof? #f) + (write! (lambda (bv start count) + (if (= 0 count) + (begin + (set! eof? #t) + 0) + (begin + (bytevector-copy! bv start + sink sink-pos + count) + (set! sink-pos (+ sink-pos count)) + count)))) + (port (make-custom-binary-input/output-port + "cbop" dummy-read! write! + #f #f #f))) + (put-bytevector port source) + (force-output port) + (and (= sink-pos (bytevector-length source)) + (not eof?) + (bytevector=? sink source)))) + + (pass-if-equal "custom-binary-output-port uses ISO-8859-1 (Guile extension)\ + [output]" + '(194 169 194 169) + (with-fluids ((%default-port-encoding "UTF-8")) + (let* ((sink '()) + (write! (lambda (bv start count) + (if (= 0 count) ; EOF + 0 + (let ((u8 (bytevector-u8-ref bv start))) + ;; Get one byte at a time. + (set! sink (cons u8 sink)) + 1)))) + (port (make-custom-binary-input/output-port + "cbop" dummy-read! write! + #f #f #f))) + (put-string port "©©") + (force-output port) + (reverse sink)))) + ) (define exception:encoding-error '(encoding-error . "")) -- 2.9.2 --=-=-=-- From debbugs-submit-bounces@debbugs.gnu.org Sat Nov 05 14:39:20 2016 Received: (at 24075) by debbugs.gnu.org; 5 Nov 2016 18:39:20 +0000 Received: from localhost ([127.0.0.1]:46124 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1c35s8-0002LC-6o for submit@debbugs.gnu.org; Sat, 05 Nov 2016 14:39:20 -0400 Received: from dustycloud.org ([50.116.34.160]:44584) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1c35s5-0002L4-Vi for 24075@debbugs.gnu.org; Sat, 05 Nov 2016 14:39:18 -0400 Received: from oolong (localhost [127.0.0.1]) by dustycloud.org (Postfix) with ESMTPS id 4D1BE265F2; Sat, 5 Nov 2016 14:39:17 -0400 (EDT) References: <8760rss8al.fsf@dustycloud.org> <87a8gstgn6.fsf@pobox.com> <878tvqqfkq.fsf@dustycloud.org> User-agent: mu4e 0.9.16; emacs 25.1.1 From: Christopher Allan Webber To: Andy Wingo Subject: Re: bug#24075: tls/https support in Guile (through r6rs binary ports?) In-reply-to: <878tvqqfkq.fsf@dustycloud.org> Date: Sat, 05 Nov 2016 13:39:16 -0500 Message-ID: <87r36p6aaz.fsf@dustycloud.org> MIME-Version: 1.0 Content-Type: multipart/mixed; boundary="=-=-=" X-Spam-Score: -2.4 (--) X-Debbugs-Envelope-To: 24075 Cc: 24075@debbugs.gnu.org X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: debbugs-submit-bounces@debbugs.gnu.org Sender: "Debbugs-submit" X-Spam-Score: -2.4 (--) --=-=-= Content-Type: text/plain Christopher Allan Webber writes: > Here's two patches. The first fixes some of the section names in the > r6rs-ports.test file, and can be applied to master immediately. I don't think it was captured, but these patches were applied to master. So the next thing is getting the gnutls support for https in Guile. And! I have a patch that does that! I think it's probably good enough to be merged probably at this point, but it could use review. --=-=-= Content-Type: text/x-patch Content-Disposition: inline; filename=0001-web-Add-https-support-through-gnutls.patch >From d4def07779c5532ffc6b7ee13820919bc23d1811 Mon Sep 17 00:00:00 2001 From: Christopher Allan Webber Date: Thu, 17 Sep 2015 15:14:54 -0500 Subject: [PATCH] web: Add https support through gnutls. Since importing gnutls directly would result in a dependency cycle, we load gnutls lazily. This uses code originally written for Guix by Ludovic * module/web/client.scm: (%http-receive-buffer-size) (warn-no-gnutls-return-false, gnutls-module, ensure-gnutls) (gnutls-ref, tls-wrap): New variables. (open-socket-for-uri): Wrap in tls when uri scheme is https. --- module/web/client.scm | 173 +++++++++++++++++++++++++++++++++++++++++++------- 1 file changed, 151 insertions(+), 22 deletions(-) diff --git a/module/web/client.scm b/module/web/client.scm index f24a4d7..f1a6bb5 100644 --- a/module/web/client.scm +++ b/module/web/client.scm @@ -1,6 +1,6 @@ ;;; Web client -;; Copyright (C) 2011, 2012, 2013, 2014 Free Software Foundation, Inc. +;; Copyright (C) 2011, 2012, 2013, 2014, 2015, 2016 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 @@ -43,8 +43,11 @@ #: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 + open-connection-for-uri http-get http-get* http-head @@ -54,11 +57,111 @@ http-trace http-options)) +(define %http-receive-buffer-size + ;; Size of the HTTP receive buffer. + 65536) + +;; Provide access to the gnutls-module, but fail gracefully if not available. +;; Why take this route and not just straight up import the module? +;; Guile can't depend on gnutls because gnutls includes Guile as a dependency. +;; There's some risk of dependency cycles, so lazily resolving things only +;; once needed helps! + +(define warn-no-gnutls-return-false + (lambda _ + (format (current-error-port) + "warning: (gnutls) module not available\n") + #f)) + +(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 + (warn-no-gnutls-return-false)))) + warn-no-gnutls-return-false))) + +(define (ensure-gnutls) + (if (not (force gnutls-module)) + (throw 'gnutls-not-available "(gnutls) module not available"))) + +(define (gnutls-ref symbol) + "Fetch method-symbol from the gnutls module" + (module-ref (force gnutls-module) symbol)) + (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 ((gnutls-ref 'make-session) + (gnutls-ref '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 + ;; for details. + (if (module-defined? (force gnutls-module) + 'set-session-server-name!) + ((gnutls-ref 'set-session-server-name!) + session (gnutls-ref 'server-name-type/dns) server) + (format (current-error-port) + "warning: TLS 'SERVER NAME' extension not supported~%")) + + ((gnutls-ref 'set-session-transport-fd!) session (fileno port)) + ((gnutls-ref 'set-session-default-priority!) session) + + ;; The "%COMPAT" bit allows us to work around firewall issues (info + ;; "(gnutls) Priority Strings"); see . + ;; Explicitly disable SSLv3, which is insecure: + ;; . + ((gnutls-ref 'set-session-priorities!) session "NORMAL:%COMPAT:-VERS-SSL3.0") + + ((gnutls-ref 'set-session-credentials!) session + ((gnutls-ref 'make-certificate-credentials))) + + ;; Uncomment the following lines in case of debugging emergency. + ;;(set-log-level! 10) + ;;(set-log-procedure! log) + + ((gnutls-ref 'handshake) session) + (let ((record ((gnutls-ref 'session-record-port) session))) + (define (read! bv start count) + (define read-bv (get-bytevector-n record count)) + (define read-bv-len (bytevector-length read-bv)) + (bytevector-copy! read-bv 0 bv 0 read-bv-len) + read-bv-len) + (define (write! bv start count) + (put-bytevector record bv start count) + 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))) + (make-custom-binary-input/output-port "gnutls wrapped port" read! write! + get-position set-position! + close)))) + (define (ensure-uri uri-or-string) (cond ((string? uri-or-string) (string->uri uri-or-string)) @@ -81,27 +184,53 @@ 0)) (lambda (ai1 ai2) (equal? (addrinfo:addr ai1) (addrinfo:addr ai2)))))) - - (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)))))))) + (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 _IOFBF %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) -- 2.10.2 --=-=-=-- From debbugs-submit-bounces@debbugs.gnu.org Sat Nov 05 15:02:46 2016 Received: (at 24075) by debbugs.gnu.org; 5 Nov 2016 19:02:46 +0000 Received: from localhost ([127.0.0.1]:46134 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1c36Eo-0002xi-5R for submit@debbugs.gnu.org; Sat, 05 Nov 2016 15:02:46 -0400 Received: from eggs.gnu.org ([208.118.235.92]:54170) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1c36Em-0002xU-IH for 24075@debbugs.gnu.org; Sat, 05 Nov 2016 15:02:44 -0400 Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1c36Ee-0004aY-99 for 24075@debbugs.gnu.org; Sat, 05 Nov 2016 15:02:39 -0400 X-Spam-Checker-Version: SpamAssassin 3.3.2 (2011-06-06) on eggs.gnu.org X-Spam-Level: X-Spam-Status: No, score=-1.2 required=5.0 tests=BAYES_50,RP_MATCHES_RCVD autolearn=disabled version=3.3.2 Received: from fencepost.gnu.org ([2001:4830:134:3::e]:34381) by eggs.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1c36Ee-0004aQ-69; Sat, 05 Nov 2016 15:02:36 -0400 Received: from reverse-83.fdn.fr ([80.67.176.83]:50300 helo=pluto) by fencepost.gnu.org with esmtpsa (TLS1.2:RSA_AES_256_CBC_SHA1:256) (Exim 4.82) (envelope-from ) id 1c36Ed-0001NT-DJ; Sat, 05 Nov 2016 15:02:35 -0400 From: ludo@gnu.org (Ludovic =?utf-8?Q?Court=C3=A8s?=) To: Christopher Allan Webber Subject: Re: bug#24075: tls/https support in Guile (through r6rs binary ports?) References: <8760rss8al.fsf@dustycloud.org> <87a8gstgn6.fsf@pobox.com> <878tvqqfkq.fsf@dustycloud.org> <87r36p6aaz.fsf@dustycloud.org> Date: Sat, 05 Nov 2016 20:02:32 +0100 In-Reply-To: <87r36p6aaz.fsf@dustycloud.org> (Christopher Allan Webber's message of "Sat, 05 Nov 2016 13:39:16 -0500") Message-ID: <87fun56987.fsf@gnu.org> User-Agent: Gnus/5.13 (Gnus v5.13) Emacs/25.1 (gnu/linux) MIME-Version: 1.0 Content-Type: text/plain; charset=utf-8 Content-Transfer-Encoding: quoted-printable X-detected-operating-system: by eggs.gnu.org: GNU/Linux 2.2.x-3.x [generic] X-Received-From: 2001:4830:134:3::e X-Spam-Score: -7.4 (-------) X-Debbugs-Envelope-To: 24075 Cc: Andy Wingo , 24075@debbugs.gnu.org X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: debbugs-submit-bounces@debbugs.gnu.org Sender: "Debbugs-submit" X-Spam-Score: -7.4 (-------) Hi! Christopher Allan Webber skribis: >>>From d4def07779c5532ffc6b7ee13820919bc23d1811 Mon Sep 17 00:00:00 2001 > From: Christopher Allan Webber > Date: Thu, 17 Sep 2015 15:14:54 -0500 > Subject: [PATCH] web: Add https support through gnutls. > > Since importing gnutls directly would result in a dependency cycle, > we load gnutls lazily. > > This uses code originally written for Guix by Ludovic > > * module/web/client.scm: (%http-receive-buffer-size) > (warn-no-gnutls-return-false, gnutls-module, ensure-gnutls) > (gnutls-ref, tls-wrap): New variables. > (open-socket-for-uri): Wrap in tls when uri scheme is https. Woohoo, cool! > +(define (ensure-gnutls) > + (if (not (force gnutls-module)) > + (throw 'gnutls-not-available "(gnutls) module not available"))) I wonder if this is the right exception, but I can=E2=80=99t think of anyth= ing better (there=E2=80=99s no generic =E2=80=9Cnot supported=E2=80=9D exceptio= n I think; (throw 'system-error =E2=80=A6 ENOSYS) would do that but it=E2=80=99s too vague.) > +(define (gnutls-ref symbol) > + "Fetch method-symbol from the gnutls module" > + (module-ref (force gnutls-module) symbol)) > + > (define current-http-proxy > (make-parameter (let ((proxy (getenv "http_proxy"))) > (and (not (equal? proxy "")) > proxy)))) >=20=20 > +(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 ((gnutls-ref 'make-session) > + (gnutls-ref 'connection-end/client)))) What about leaving the =E2=80=98ensure-gnutls=E2=80=99 call and then simply= use the GnuTLS symbols directly and rely on autoloading, as in (guix build download)? --8<---------------cut here---------------start------------->8--- ;; 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 . (module-autoload! (current-module) '(gnutls) '(make-session connection-end/client)) --8<---------------cut here---------------end--------------->8--- That would lead more concise and slightly more efficient code, and I think it would still work as expected in the absence of (gnutls). WDYT? > + (define (read! bv start count) > + (define read-bv (get-bytevector-n record count)) > + (define read-bv-len (bytevector-length read-bv)) > + (bytevector-copy! read-bv 0 bv 0 read-bv-len) > + read-bv-len) Beware: =E2=80=98get-bytevector-n=E2=80=99 can return the EOF object instea= d of a number, so you need to check for that. (Conversely, =E2=80=98read!=E2=80= =99 needs to return 0 to indicate EOF.) > + (define (open-socket) > + (let loop ((addresses addresses)) Or just =E2=80=9C(define sock =E2=80=A6=E2=80=9D. Otherwise works for me! Could you document HTTPS support in the doc of =E2=80=98open-socket-for-uri= =E2=80=99 (info "(guile) Web Client")? Probably with something like: @xref{Guile Preparations, how to install the GnuTLS bindings for Guile,, gnutls-guile, GnuTLS-Guile}, for more information. Thank you Chris! Ludo=E2=80=99. From debbugs-submit-bounces@debbugs.gnu.org Sun Nov 06 12:37:50 2016 Received: (at 24075) by debbugs.gnu.org; 6 Nov 2016 17:37:50 +0000 Received: from localhost ([127.0.0.1]:47102 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1c3RO9-0001Qj-U2 for submit@debbugs.gnu.org; Sun, 06 Nov 2016 12:37:50 -0500 Received: from dustycloud.org ([50.116.34.160]:46786) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1c3RO7-0001Qb-P8 for 24075@debbugs.gnu.org; Sun, 06 Nov 2016 12:37:48 -0500 Received: from oolong (localhost [127.0.0.1]) by dustycloud.org (Postfix) with ESMTPS id 25F96265F2; Sun, 6 Nov 2016 12:37:46 -0500 (EST) References: <8760rss8al.fsf@dustycloud.org> <87a8gstgn6.fsf@pobox.com> <878tvqqfkq.fsf@dustycloud.org> <87r36p6aaz.fsf@dustycloud.org> <87fun56987.fsf@gnu.org> User-agent: mu4e 0.9.16; emacs 25.1.1 From: Christopher Allan Webber To: Ludovic =?utf-8?Q?Court=C3=A8s?= Subject: Re: bug#24075: tls/https support in Guile (through r6rs binary ports?) In-reply-to: <87fun56987.fsf@gnu.org> Date: Sun, 06 Nov 2016 11:37:45 -0600 Message-ID: <87lgww5x1y.fsf@dustycloud.org> MIME-Version: 1.0 Content-Type: multipart/mixed; boundary="=-=-=" X-Spam-Score: -2.0 (--) X-Debbugs-Envelope-To: 24075 Cc: Andy Wingo , 24075@debbugs.gnu.org X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: debbugs-submit-bounces@debbugs.gnu.org Sender: "Debbugs-submit" X-Spam-Score: -2.0 (--) --=-=-= Content-Type: text/plain; charset=utf-8 Content-Transfer-Encoding: 8bit Ludovic Courtès writes: >> +(define (ensure-gnutls) >> + (if (not (force gnutls-module)) >> + (throw 'gnutls-not-available "(gnutls) module not available"))) > > I wonder if this is the right exception, but I can’t think of anything > better (there’s no generic “not supported” exception I think; (throw > 'system-error … ENOSYS) would do that but it’s too vague.) I don't know... it's hard for me to tell when to use what exception symbol in Guile! I prefer specific exceptions when a more general exception can't be found appropriately... at lest you'll catch the right one if you try to catch it in such a case. I also like that the above exception helps the user realize what isn't installed so they can resolve it. But if someone defines something concrete they'd prefer we can switch to that. >> +(define (gnutls-ref symbol) >> + "Fetch method-symbol from the gnutls module" >> + (module-ref (force gnutls-module) symbol)) >> + >> (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 ((gnutls-ref 'make-session) >> + (gnutls-ref 'connection-end/client)))) > > What about leaving the ‘ensure-gnutls’ call and then simply use the > GnuTLS symbols directly and rely on autoloading, as in (guix build > download)? > > --8<---------------cut here---------------start------------->8--- > ;; 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 . > (module-autoload! (current-module) > '(gnutls) '(make-session connection-end/client)) > --8<---------------cut here---------------end--------------->8--- > > That would lead more concise and slightly more efficient code, and I > think it would still work as expected in the absence of (gnutls). > > WDYT? So there was this converstaion on #guile: mark_weaver: the autoload hack fails gracelessly when GnuTLS is missing that's fine in the context of Guix, but maybe not in a more general context oh :) civodul: what approach would you suggest then? civodul: could we make it more graceful? yeah maybe with some explicit module hackery an explicit resolve-interface + module-ref something like that sounds doable So... that's what lead me to change it. Admittedly I'm not totally clear what was meant by "the autoload hack fails gracelessly", and what would be more graceful. Would it be because it's trying to utilize a symbol that's not bound to anything? Which leads to the next question: if I did the autoload hack, what would (ensure-gnutls) look like? I think it's not nice to throw an exception that the symbol is simply not in the current environment; that's not helpful for a user. (We'll still need to ensure that gnutls-version resolves to a procedure anyway, given the bug I added the comment about.) >> + (define (read! bv start count) >> + (define read-bv (get-bytevector-n record count)) >> + (define read-bv-len (bytevector-length read-bv)) >> + (bytevector-copy! read-bv 0 bv 0 read-bv-len) >> + read-bv-len) > > Beware: ‘get-bytevector-n’ can return the EOF object instead of a > number, so you need to check for that. (Conversely, ‘read!’ needs to > return 0 to indicate EOF.) So that would look like this? (define (read! bv start count) (define read-bv (get-bytevector-n record count)) (if (eof-object? read-bv) 0 (let ((read-bv-len (bytevector-length read-bv))) (bytevector-copy! read-bv 0 bv 0 read-bv-len) read-bv-len))) >> + (define (open-socket) >> + (let loop ((addresses addresses)) > > Or just “(define sock …”. Hm, is that a good idea? Does this need to happen before or within the with-https-proxy? > Otherwise works for me! > > Could you document HTTPS support in the doc of ‘open-socket-for-uri’ > (info "(guile) Web Client")? Probably with something like: > > @xref{Guile Preparations, > how to install the GnuTLS bindings for Guile,, gnutls-guile, > GnuTLS-Guile}, for more information. Done. > Thank you Chris! > > Ludo’. Updated patch attached. Still needs advisement on the exception and autoload bits though! - Chris --=-=-= Content-Type: text/x-patch Content-Disposition: inline; filename=0001-web-Add-https-support-through-gnutls.patch >From 91c0a4a728ca4bf2e9468cdc849c350dd3f7380f Mon Sep 17 00:00:00 2001 From: Christopher Allan Webber Date: Thu, 17 Sep 2015 15:14:54 -0500 Subject: [PATCH] web: Add https support through gnutls. Since importing gnutls directly would result in a dependency cycle, we load gnutls lazily. This uses code originally written for Guix by Ludovic * module/web/client.scm: (%http-receive-buffer-size) (warn-no-gnutls-return-false, gnutls-module, ensure-gnutls) (gnutls-ref, tls-wrap): New variables. (open-socket-for-uri): Wrap in tls when uri scheme is https. * doc/ref/web.texi (open-socket-for-uri): Document gnutls usage. --- doc/ref/web.texi | 6 +- module/web/client.scm | 175 +++++++++++++++++++++++++++++++++++++++++++------- 2 files changed, 158 insertions(+), 23 deletions(-) diff --git a/doc/ref/web.texi b/doc/ref/web.texi index becdc28..c2f3f61 100644 --- a/doc/ref/web.texi +++ b/doc/ref/web.texi @@ -1422,7 +1422,11 @@ the lower-level HTTP, request, and response modules. @end example @deffn {Scheme Procedure} open-socket-for-uri uri -Return an open input/output port for a connection to URI. +Return an open input/output port for a connection to URI. Guile +dynamically loads gnutls for https support; for more information, see +@xref{Guile Preparations, +how to install the GnuTLS bindings for Guile,, gnutls-guile, +GnuTLS-Guile}. @end deffn @deffn {Scheme Procedure} http-get uri arg... diff --git a/module/web/client.scm b/module/web/client.scm index f24a4d7..f0fba49 100644 --- a/module/web/client.scm +++ b/module/web/client.scm @@ -1,6 +1,6 @@ ;;; Web client -;; Copyright (C) 2011, 2012, 2013, 2014 Free Software Foundation, Inc. +;; Copyright (C) 2011, 2012, 2013, 2014, 2015, 2016 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 @@ -43,8 +43,11 @@ #: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 + open-connection-for-uri http-get http-get* http-head @@ -54,11 +57,113 @@ http-trace http-options)) +(define %http-receive-buffer-size + ;; Size of the HTTP receive buffer. + 65536) + +;; Provide access to the gnutls-module, but fail gracefully if not available. +;; Why take this route and not just straight up import the module? +;; Guile can't depend on gnutls because gnutls includes Guile as a dependency. +;; There's some risk of dependency cycles, so lazily resolving things only +;; once needed helps! + +(define warn-no-gnutls-return-false + (lambda _ + (format (current-error-port) + "warning: (gnutls) module not available\n") + #f)) + +(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 + (warn-no-gnutls-return-false)))) + warn-no-gnutls-return-false))) + +(define (ensure-gnutls) + (if (not (force gnutls-module)) + (throw 'gnutls-not-available "(gnutls) module not available"))) + +(define (gnutls-ref symbol) + "Fetch method-symbol from the gnutls module" + (module-ref (force gnutls-module) symbol)) + (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 ((gnutls-ref 'make-session) + (gnutls-ref '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 + ;; for details. + (if (module-defined? (force gnutls-module) + 'set-session-server-name!) + ((gnutls-ref 'set-session-server-name!) + session (gnutls-ref 'server-name-type/dns) server) + (format (current-error-port) + "warning: TLS 'SERVER NAME' extension not supported~%")) + + ((gnutls-ref 'set-session-transport-fd!) session (fileno port)) + ((gnutls-ref 'set-session-default-priority!) session) + + ;; The "%COMPAT" bit allows us to work around firewall issues (info + ;; "(gnutls) Priority Strings"); see . + ;; Explicitly disable SSLv3, which is insecure: + ;; . + ((gnutls-ref 'set-session-priorities!) session "NORMAL:%COMPAT:-VERS-SSL3.0") + + ((gnutls-ref 'set-session-credentials!) session + ((gnutls-ref 'make-certificate-credentials))) + + ;; Uncomment the following lines in case of debugging emergency. + ;;(set-log-level! 10) + ;;(set-log-procedure! log) + + ((gnutls-ref 'handshake) session) + (let ((record ((gnutls-ref 'session-record-port) session))) + (define (read! bv start count) + (define read-bv (get-bytevector-n record count)) + (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 0 read-bv-len) + read-bv-len))) + (define (write! bv start count) + (put-bytevector record bv start count) + 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))) + (make-custom-binary-input/output-port "gnutls wrapped port" read! write! + get-position set-position! + close)))) + (define (ensure-uri uri-or-string) (cond ((string? uri-or-string) (string->uri uri-or-string)) @@ -81,27 +186,53 @@ 0)) (lambda (ai1 ai2) (equal? (addrinfo:addr ai1) (addrinfo:addr ai2)))))) - - (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)))))))) + (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 _IOFBF %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) -- 2.10.2 --=-=-=-- From debbugs-submit-bounces@debbugs.gnu.org Sun Nov 06 13:32:50 2016 Received: (at 24075) by debbugs.gnu.org; 6 Nov 2016 18:32:50 +0000 Received: from localhost ([127.0.0.1]:47122 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1c3SFF-0002jG-KT for submit@debbugs.gnu.org; Sun, 06 Nov 2016 13:32:50 -0500 Received: from dustycloud.org ([50.116.34.160]:46874) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1c3SFD-0002j7-Jw for 24075@debbugs.gnu.org; Sun, 06 Nov 2016 13:32:40 -0500 Received: from oolong (localhost [127.0.0.1]) by dustycloud.org (Postfix) with ESMTPS id E2205265F2; Sun, 6 Nov 2016 13:32:38 -0500 (EST) References: <8760rss8al.fsf@dustycloud.org> <87a8gstgn6.fsf@pobox.com> <878tvqqfkq.fsf@dustycloud.org> <87r36p6aaz.fsf@dustycloud.org> <87fun56987.fsf@gnu.org> User-agent: mu4e 0.9.16; emacs 25.1.1 From: Christopher Allan Webber To: Ludovic =?utf-8?Q?Court=C3=A8s?= Subject: Re: bug#24075: tls/https support in Guile (through r6rs binary ports?) In-reply-to: <87fun56987.fsf@gnu.org> Date: Sun, 06 Nov 2016 12:32:38 -0600 Message-ID: <87k2cg5uih.fsf@dustycloud.org> MIME-Version: 1.0 Content-Type: multipart/mixed; boundary="=-=-=" X-Spam-Score: -2.0 (--) X-Debbugs-Envelope-To: 24075 Cc: Andy Wingo , 24075@debbugs.gnu.org X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: debbugs-submit-bounces@debbugs.gnu.org Sender: "Debbugs-submit" X-Spam-Score: -2.0 (--) --=-=-= Content-Type: text/plain Content-Transfer-Encoding: quoted-printable Some less good news: I found out that the https stuff is not working right for all sites. I tested though... the code works *before* I wrapped it in custom-binary-input/output-port. After being wrapped though, strange things happen. For some sites (eg "https://webmention.net/") things seem fine: scheme@(guile-user)> (http-get (string->uri "https://webmention.net/")) $7 =3D #< version: (1 . 1) code: 200 reason-phrase: "OK" headers:= ((server . "nginx/1.9.10") (date . #) (content-type tex= t/html (charset . "UTF-8")) (transfer-encoding (chunked)) (connection close= ) (x-powered-by . "PHP/5.6.21-1+donate.sury.org~trusty+4")) port: #> $8 =3D "\n\n\n Webmention\n \n\n\n\n
\n \n

Webmention

\n \n
Webmention is a simple way to notify any URL when you link to it from your= site.
\n \n \n \n
\n\n\n" For other sites, especially ones where the pages are larger, things are broken. For example, let's try to pull down the site of friend Joey Hess: scheme@(guile-user)> (http-get (string->uri "https://joeyh.name/")) $9 =3D #< version: (1 . 1) code: 200 reason-phrase: "OK" headers:= ((date . #) (server . "Apache/2.4.10 (Debian)") (last-m= odified . #) (etag "195c-53f9d4af683f3" . #t) (accept-r= anges bytes) (content-length . 6492) (vary accept-encoding) (cache-control = (max-age . 0)) (expires . #) (connection close) (content= -type text/html)) port: #> $10 =3D "moz-background-size: cover;\n -o-background-size: cover;\n b= ackground-size: cover;\n}\n.sidebar {\n background: none;\n border: n= one;\n}\ninput#searchbox {\n display: none;\n}\n#pageinfo {\n display= : none;\n}\n.pageheader .actions ul {\n border-bottom: none;\n}\n#pagebo= dy {\n margin-left: 20%;\n}\n.archivepagedate {\n font-size: 0.5em;\n= }\n.actions {\n display: none;\n}\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n

interviews

\n\n

2012: The Setup

\n\n

\"When power is low, I = often hack in the evenings by lantern light.\"

\n\n

2015: Life after Debian

\n\n

\"I want = to build worthwhile things that might last.\"

\n\n

2016: Linux Weekly News

\n\n=

\"I still see myself as a beginner, and certainly not an exe= mplar.\"

\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n=
\n\n<= nav id=3D\"pageinfo\">\n\n\n\n\n\n\n\n\n\n\n\n
\nL= ast edited \n\n
\n\n\= n\n\n\n
\n\n\n\n\n\n\" ti= tle=3D\"Thu, 22 Sep 2016 16:13:21 -0400\">at teatime on Thursday, September= 22nd, 2016\n\n\n\n
\n\nPoW bucket bloom: throttling anon= ymous clients with proof of work, token buckets, and bloom filters
\n\n\nPosted \n
\n
\n\nlate summer
\n\n\nPosted \n\n\n
\n\n\n\n\n\n<= /aside>\n\n\n\n
\n\n
\n\n\n
\n

personal

\n\n

blog
\npics
\ncontact me
\ntodo

\n\n\n\n\n

technical

\n\n

code
\nvcshome
\ntalks
\nscreencasts
\ntermcasts
\n= rfcs
\nboxen

\n\n\n\n

fun

\n\n

Joe= y Learns to Fly
\noldusenet\nlanguages
\nyu= rt
\ncaving
\ngrep
\nmeta

\n\n\n\n