* bug#24075: tls/https support in Guile (through r6rs binary ports?) @ 2016-07-26 15:55 Christopher Allan Webber 2016-08-04 20:37 ` Andy Wingo 0 siblings, 1 reply; 12+ messages in thread From: Christopher Allan Webber @ 2016-07-26 15:55 UTC (permalink / raw) To: 24075 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 ^ permalink raw reply [flat|nested] 12+ messages in thread
* bug#24075: tls/https support in Guile (through r6rs binary ports?) 2016-07-26 15:55 bug#24075: tls/https support in Guile (through r6rs binary ports?) Christopher Allan Webber @ 2016-08-04 20:37 ` Andy Wingo 2016-08-21 15:58 ` Christopher Allan Webber 0 siblings, 1 reply; 12+ messages in thread From: Andy Wingo @ 2016-08-04 20:37 UTC (permalink / raw) To: Christopher Allan Webber; +Cc: 24075 On Tue 26 Jul 2016 17:55, Christopher Allan Webber <cwebber@dustycloud.org> 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 ^ permalink raw reply [flat|nested] 12+ messages in thread
* bug#24075: tls/https support in Guile (through r6rs binary ports?) 2016-08-04 20:37 ` Andy Wingo @ 2016-08-21 15:58 ` Christopher Allan Webber 2016-11-05 18:39 ` Christopher Allan Webber 0 siblings, 1 reply; 12+ messages in thread From: Christopher Allan Webber @ 2016-08-21 15:58 UTC (permalink / raw) To: Andy Wingo; +Cc: 24075 [-- Attachment #1: Type: text/plain, Size: 1623 bytes --] Andy Wingo writes: > On Tue 26 Jul 2016 17:55, Christopher Allan Webber <cwebber@dustycloud.org> 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" (#<input-output: file 10c0620>) #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 [-- Warning: decoded text below may be mangled, UTF-8 assumed --] [-- Attachment #2: 0001-Correct-section-number-for-Input-Ports-tests.patch --] [-- Type: text/x-patch, Size: 1594 bytes --] From 1f9d6ea0ae18557789c39342d04aec33d2156207 Mon Sep 17 00:00:00 2001 From: Christopher Allan Webber <cwebber@dustycloud.org> 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)))) \f -(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 "")))) \f -(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 [-- Attachment #3: 0002-Add-tests-for-make-custom-binary-input-output-port.patch --] [-- Type: text/x-patch, Size: 18055 bytes --] From 297dc06f1bfbb49f636018944f0a1c114d6778ea Mon Sep 17 00:00:00 2001 From: Christopher Allan Webber <cwebber@dustycloud.org> 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 <http://bugs.gnu.org/19621>. + (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 <http://bugs.gnu.org/19621>. + (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 ^ permalink raw reply related [flat|nested] 12+ messages in thread
* bug#24075: tls/https support in Guile (through r6rs binary ports?) 2016-08-21 15:58 ` Christopher Allan Webber @ 2016-11-05 18:39 ` Christopher Allan Webber 2016-11-05 19:02 ` Ludovic Courtès 0 siblings, 1 reply; 12+ messages in thread From: Christopher Allan Webber @ 2016-11-05 18:39 UTC (permalink / raw) To: Andy Wingo; +Cc: 24075 [-- Attachment #1: Type: text/plain, Size: 450 bytes --] 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. [-- Warning: decoded text below may be mangled, UTF-8 assumed --] [-- Attachment #2: 0001-web-Add-https-support-through-gnutls.patch --] [-- Type: text/x-patch, Size: 8917 bytes --] From d4def07779c5532ffc6b7ee13820919bc23d1811 Mon Sep 17 00:00:00 2001 From: Christopher Allan Webber <cwebber@dustycloud.org> 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 + ;; <http://bugs.gnu.org/18526> 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 <http://bugs.gnu.org/23311>. + ;; Explicitly disable SSLv3, which is insecure: + ;; <https://tools.ietf.org/html/rfc7568>. + ((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 ^ permalink raw reply related [flat|nested] 12+ messages in thread
* bug#24075: tls/https support in Guile (through r6rs binary ports?) 2016-11-05 18:39 ` Christopher Allan Webber @ 2016-11-05 19:02 ` Ludovic Courtès 2016-11-06 17:37 ` Christopher Allan Webber 2016-11-06 18:32 ` Christopher Allan Webber 0 siblings, 2 replies; 12+ messages in thread From: Ludovic Courtès @ 2016-11-05 19:02 UTC (permalink / raw) To: Christopher Allan Webber; +Cc: 24075 Hi! Christopher Allan Webber <cwebber@dustycloud.org> skribis: >>From d4def07779c5532ffc6b7ee13820919bc23d1811 Mon Sep 17 00:00:00 2001 > From: Christopher Allan Webber <cwebber@dustycloud.org> > 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’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.) > +(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 <http://bugs.gnu.org/12202>. (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: ‘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.) > + (define (open-socket) > + (let loop ((addresses addresses)) Or just “(define sock …”. 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. Thank you Chris! Ludo’. ^ permalink raw reply [flat|nested] 12+ messages in thread
* bug#24075: tls/https support in Guile (through r6rs binary ports?) 2016-11-05 19:02 ` Ludovic Courtès @ 2016-11-06 17:37 ` Christopher Allan Webber 2016-11-06 21:13 ` Ludovic Courtès 2016-11-06 18:32 ` Christopher Allan Webber 1 sibling, 1 reply; 12+ messages in thread From: Christopher Allan Webber @ 2016-11-06 17:37 UTC (permalink / raw) To: Ludovic Courtès; +Cc: 24075 [-- Attachment #1: Type: text/plain, Size: 5118 bytes --] 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 <http://bugs.gnu.org/12202>. > (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: <civodul> mark_weaver: the autoload hack fails gracelessly when GnuTLS is missing <civodul> that's fine in the context of Guix, but maybe not in a more general context <paron_remote> oh :) <paron_remote> civodul: what approach would you suggest then? <mark_weaver> civodul: could we make it more graceful? <civodul> yeah maybe with some explicit module hackery <civodul> an explicit resolve-interface + module-ref <civodul> something like that <mark_weaver> 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 [-- Warning: decoded text below may be mangled, UTF-8 assumed --] [-- Attachment #2: 0001-web-Add-https-support-through-gnutls.patch --] [-- Type: text/x-patch, Size: 9746 bytes --] From 91c0a4a728ca4bf2e9468cdc849c350dd3f7380f Mon Sep 17 00:00:00 2001 From: Christopher Allan Webber <cwebber@dustycloud.org> 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 + ;; <http://bugs.gnu.org/18526> 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 <http://bugs.gnu.org/23311>. + ;; Explicitly disable SSLv3, which is insecure: + ;; <https://tools.ietf.org/html/rfc7568>. + ((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 ^ permalink raw reply related [flat|nested] 12+ messages in thread
* bug#24075: tls/https support in Guile (through r6rs binary ports?) 2016-11-06 17:37 ` Christopher Allan Webber @ 2016-11-06 21:13 ` Ludovic Courtès 2016-11-07 18:14 ` Christopher Allan Webber 0 siblings, 1 reply; 12+ messages in thread From: Ludovic Courtès @ 2016-11-06 21:13 UTC (permalink / raw) To: Christopher Allan Webber; +Cc: 24075 Christopher Allan Webber <cwebber@dustycloud.org> skribis: > 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 Yes, I agree. I was just wondering out loud whether there might be another exception. Anyway, this one’s fine! >> 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 <http://bugs.gnu.org/12202>. >> (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: > > <civodul> mark_weaver: the autoload hack fails gracelessly when GnuTLS is > missing > <civodul> that's fine in the context of Guix, but maybe not in a more general > context > <paron_remote> oh :) > <paron_remote> civodul: what approach would you suggest then? > <mark_weaver> civodul: could we make it more graceful? > <civodul> yeah maybe with some explicit module hackery > <civodul> an explicit resolve-interface + module-ref > <civodul> something like that > <mark_weaver> 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? Sorry for the confusing statements. :-) I think ‘ensure-gnutls’ would be exactly as in this patch, and the autoload hack would be exactly as shown above. Here it would fail “gracefully” in the sense that ‘ensure-gnutls’ would catch a potential problem early on and raise the ‘gnutls-not-available’ exception (you’d have to double-check that this is indeed the behavior we get, but I’m quite confident ;-)). In (guix build download) there’s no such protection so when (gnutls) is missing, users get an unbound variable right in the middle of the code. >>> + (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))) Exactly. >>> + (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? Oh you’re right, sorry. > From 91c0a4a728ca4bf2e9468cdc849c350dd3f7380f Mon Sep 17 00:00:00 2001 > From: Christopher Allan Webber <cwebber@dustycloud.org> > 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. [...] > @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}. @xref generates a “See” for the beginning of a sentence, so it should be: … support. @xref{…}, for more information. Also, “HTTPS” and “GnuTLS”. :-) The rest is all good for me, so the only remaining bits are the autoload thing and maybe the bug you observed? Thanks! Ludo’. ^ permalink raw reply [flat|nested] 12+ messages in thread
* bug#24075: tls/https support in Guile (through r6rs binary ports?) 2016-11-06 21:13 ` Ludovic Courtès @ 2016-11-07 18:14 ` Christopher Allan Webber 2016-11-07 20:13 ` Ludovic Courtès 0 siblings, 1 reply; 12+ messages in thread From: Christopher Allan Webber @ 2016-11-07 18:14 UTC (permalink / raw) To: Ludovic Courtès; +Cc: 24075-done Ludovic Courtès writes: > I think ‘ensure-gnutls’ would be exactly as in this patch, and the > autoload hack would be exactly as shown above. Got it! Done... > @xref generates a “See” for the beginning of a sentence, so it should > be: > > … support. @xref{…}, for more information. ... and done! > Also, “HTTPS” and “GnuTLS”. :-) Ooops, misssed that bit in the first commit which I had pushed, so I made two commits. :) > The rest is all good for me, so the only remaining bits are the autoload > thing and maybe the bug you observed? Yep! It's now done... as of 8f1db9f we now have HTTPS support out-of-the-box in Guile! Party time! ^ permalink raw reply [flat|nested] 12+ messages in thread
* bug#24075: tls/https support in Guile (through r6rs binary ports?) 2016-11-07 18:14 ` Christopher Allan Webber @ 2016-11-07 20:13 ` Ludovic Courtès 0 siblings, 0 replies; 12+ messages in thread From: Ludovic Courtès @ 2016-11-07 20:13 UTC (permalink / raw) To: Christopher Allan Webber; +Cc: 24075-done Christopher Allan Webber <cwebber@dustycloud.org> skribis: > Yep! It's now done... as of 8f1db9f we now have HTTPS support > out-of-the-box in Guile! Party time! Yoohoo, thank you for persevering! :-) Ludo’. ^ permalink raw reply [flat|nested] 12+ messages in thread
* bug#24075: tls/https support in Guile (through r6rs binary ports?) 2016-11-05 19:02 ` Ludovic Courtès 2016-11-06 17:37 ` Christopher Allan Webber @ 2016-11-06 18:32 ` Christopher Allan Webber 2016-11-06 21:06 ` Ludovic Courtès 1 sibling, 1 reply; 12+ messages in thread From: Christopher Allan Webber @ 2016-11-06 18:32 UTC (permalink / raw) To: Ludovic Courtès; +Cc: 24075 [-- Attachment #1: Type: text/plain, Size: 9101 bytes --] 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 = #<<response> version: (1 . 1) code: 200 reason-phrase: "OK" headers: ((server . "nginx/1.9.10") (date . #<date nanosecond: 0 second: 46 minute: 15 hour: 18 day: 6 month: 11 year: 2016 zone-offset: 0>) (content-type text/html (charset . "UTF-8")) (transfer-encoding (chunked)) (connection close) (x-powered-by . "PHP/5.6.21-1+donate.sury.org~trusty+4")) port: #<closed: file f25310>> $8 = "<!DOCTYPE html>\n<html>\n<head>\n <title>Webmention</title>\n <link rel=\"stylesheet\" href=\"/styles.css\">\n</head>\n<body>\n\n<div class=\"page\">\n \n <h1>Webmention</h1>\n \n <div class=\"subtitle\">Webmention is a simple way to notify any URL when you link to it from your site.</div>\n \n <ul class=\"links\">\n <li>The Webmention specification is being developed under the <a href=\"https://www.w3.org/wiki/Socialwg\">W3C Social Web Working Group</a>.</li>\n <li class=\"main\"><a href=\"https://www.w3.org/TR/webmention/\">Latest published version</a></li>\n <li class=\"main\"><a href=\"http://webmention.net/draft/\">Latest editor's draft</a></li>\n <li class=\"main\"><a href=\"http://webmention.net/implementations/\">Implementations</a></li>\n <li>The specification was contributed to the W3C by the IndieWeb community. More information and history of the spec can be found on the <a href=\"https://indieweb.org/webmention\">IndieWeb wiki</a>.</li>\n </ul>\n \n</div>\n\n</body>\n</html>" 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 = #<<response> version: (1 . 1) code: 200 reason-phrase: "OK" headers: ((date . #<date nanosecond: 0 second: 58 minute: 15 hour: 18 day: 6 month: 11 year: 2016 zone-offset: 0>) (server . "Apache/2.4.10 (Debian)") (last-modified . #<date nanosecond: 0 second: 43 minute: 34 hour: 14 day: 24 month: 10 year: 2016 zone-offset: 0>) (etag "195c-53f9d4af683f3" . #t) (accept-ranges bytes) (content-length . 6492) (vary accept-encoding) (cache-control (max-age . 0)) (expires . #<date nanosecond: 0 second: 58 minute: 15 hour: 18 day: 6 month: 11 year: 2016 zone-offset: 0>) (connection close) (content-type text/html)) port: #<closed: file f4c070>> $10 = "moz-background-size: cover;\n -o-background-size: cover;\n background-size: cover;\n}\n.sidebar {\n background: none;\n border: none;\n}\ninput#searchbox {\n display: none;\n}\n#pageinfo {\n display: none;\n}\n.pageheader .actions ul {\n border-bottom: none;\n}\n#pagebody {\n margin-left: 20%;\n}\n.archivepagedate {\n font-size: 0.5em;\n}\n.actions {\n display: none;\n}\n</style>\n</div>\n\n\n\n\n<table>\n<tr>\n<td width=\"33%\" valign=top><h3>personal</h3>\n\n<p><a href=\"./blog/\">blog</a><br/>\n<a href=\"./pics/\">pics</a><br/>\n<a href=\"./contact/\">contact me</a><br/>\n<a href=\"./todo/\">todo</a></p>\n\n\n\n</td>\n<td width=\"33%\" valign=top><h3>technical</h3>\n\n<p><a href=\"./code/\">code</a><br/>\n<a href=\"./vcshome/\">vcshome</a><br/>\n<a href=\"./talks/\">talks</a><br/>\n<a href=\"./screencasts/\">screencasts</a><br/>\n<a href=\"./termcast/\">termcasts</a><br/>\n<a href=\"./rfc/\">rfcs</a><br/>\n<a href=\"./boxen/\">boxen</a></p>\n\n\n\n</td>\n<td width=\"33%\" valign=top><h3>fun</h3>\n\n<p><a href=\"./learnstofly/\">Joey Learns to Fly</a><br/>\n<a href=\"http://olduse.net/\">oldusenet</a><br/>\n<a href=\"./languages/\">languages</a><br/>\n<a href=\"./yurt/\">yurt</a><br/>\n<a href=\"./caving/\">caving</a><br/>\n<a href=\"./grep/\">grep</a><br/>\n<a href=\"./meta/\">meta</a></p>\n\n\n\n</td>\n</tr>\n</table>\n\n\n\n\n<h3>interviews</h3>\n\n<p><a href=\"http://joey.hess.usesthis.com\">2012: The Setup</a></p>\n\n<blockquote><p>\"When power is low, I often hack in the evenings by lantern light.\"</p></blockquote>\n\n<p><a href=\"http://zgrimshell.github.io/posts/interviews-with-floss-developers-joey-hess.html\">2015: Life after Debian</a></p>\n\n<blockquote><p>\"I want to build worthwhile things that might last.\"</p></blockquote>\n\n<p><a href=\"http://lwn.net/Articles/672352/\">2016: Linux Weekly News</a></p>\n\n<blockquote><p>\"I still see myself as a beginner, and certainly not an exemplar.\"</p></blockquote>\n\n\n\n\n\n\n</section>\n\n\n\n\n\n\n\n</div>\n\n<footer id=\"footer\" class=\"pagefooter\" role=\"contentinfo\">\n\n<nav id=\"pageinfo\">\n\n\n\n\n\n\n\n\n\n\n\n<div class=\"pagedate\">\nLast edited <time datetime=\"2015-03-02T15:14:09Z\" class=\"relativedate\" title=\"Mon, 02 Mar 2015 10:14:09 -0500\">mid-morning Monday, March 2nd, 2015</time>\n<!-- Created <time datetime=\"2006-03-19T23:58:19Z\" pubdate=\"pubdate\" class=\"relativedate\" title=\"Sun, 19 Mar 2006 18:58:19 -0500\">Sunday evening, March 19th, 2006</time> -->\n</div>\n\n</nav>\n\n\n<!-- from joey -->\n</footer>\n\n</article>\n\n</body>\n</html>\n\" title=\"Thu, 22 Sep 2016 16:13:21 -0400\">at teatime on Thursday, September 22nd, 2016</time>\n\n</span>\n</div>\n<div class=\"archivepage\">\n\n<a href=\"./blog/entry/PoW_bucket_bloom/\">PoW bucket bloom: throttling anonymous clients with proof of work, token buckets, and bloom filters</a><br />\n\n<span class=\"archivepagedate\">\nPosted <time datetime=\"2016-09-13T05:14:47Z\" pubdate=\"pubdate\" class=\"relativedate\" title=\"Tue, 13 Sep 2016 01:14:47 -0400\">late Monday night, September 13th, 2016</time>\n\n</span>\n</div>\n<div class=\"archivepage\">\n\n<a href=\"./blog/entry/late_summer/\">late summer</a><br />\n\n<span class=\"archivepagedate\">\nPosted <time datetime=\"2016-08-31T01:15:40Z\" pubdate=\"pubdate\" class=\"relativedate\" title=\"Tue, 30 Aug 2016 21:15:40 -0400\">late Tuesday evening, August 30th, 2016</time>\n\n</span>\n</div>\n\n\n\n\n\n</aside>\n\n\n\n<div id=\"pagebody\">\n\n<section id=\"content\" role=\"main\">\n\n\n<div>\n<style>\nhtml { \n background: url(joeykite.jpg) no-repeat center center fixed; \n -webkit-background-size: cover;\n -\x00r\x00\x00\x00e\x00\x00\x00t\x00\x00\x00u\x00\x00\x00r\x00\x00\x00n\x00\x00\x00e\x00\x00\x00d\x00\x00\x00 \x00\x00\x00a\x00\x00\x00s\x00\x00\x00 \x00\x00\x00a\x00\x00\x00 \x00\x00\x00b\x00\x00\x00y\x00\x00\x00t\x00\x00\x00e\x00\x00\x00v\x00\x00\x00e\x00\x00\x00c\x00\x00\x00t\x00\x00\x00o\x00\x00\x00r\x00\x00\x00.\x00\x00\x00\n\x00\x00\x00\n\x00\x00\x00H\x00\x00\x00o\x00\x00\x00w\x00\x00\x00e\x00\x00\x00v\x00\x00\x00e\x00\x00\x00r\x00\x00\x00,\x00\x00\x00 \x00\x00\x00i\x00\x00\x00f\x00\x00\x00 \x00\x00\x00S\x00\x00\x00T\x00\x00\x00R\x00\x00\x00E\x00\x00\x00A\x00\x00\x00M\x00\x00\x00I\x00\x00\x00N\x00\x00\x00G\x00\x00\x00?\x00\x00\x00 \x00\x00\x00i\x00\x00\x00s\x00\x00\x00 \x00\x00\x00t\x00\x00\x00r\x00\x00\x00u\x00\x00\x00e\x00\x00\x00,\x00\x00\x00 \x00\x00\x00i\x00\x00\x00n\x00\x00\x00s\x00\x00\x00t\x00\x00\x00e\x00\x00\x00a\x00\x00\x00d\x00\x00\x00 \x00\x00\x00o\x00\x00\x00f\x00\x00\x00 \x00\x00\x00e\x00\x00\x00a\x00\x00\x00g\x00\x00\x00e\x00\x00\x00r\x00\x00\x00l\x00\x00\x00y\x00\x00\x00 \x00\x00\x00r\x00\x00\x00e\x00\x00\x00a\x00\x00\x00d\x00\x00\x00i\x00\x00\x00n\x00\x00\x00g\x00\x00\x00 \x00\x00\x00t\x00\x00\x00h\x00\x00\x00e\x00\x00\x00 \x00\x00\x00r\x00\x00\x00e\x00\x00\x00s\x00\x00\x00p\x00\x00\x00o\x00\x00\x00n\x00\x00\x00s\x00\x00\x00e\x00\x00\x00\n\x00\x00\x00b\x00\x00\x00o\x00\x00\x00d\x00\x00\x00y\x00\x00\x00 \x00\x00\x00f\x00\x00\x00r\x00\x00\x00o\x00\x00\x00m\x00\x00\x00 \x00\x00\x00t\x00\x00\x00h\x00\x00\x00e\x00\x00\x00 \x00\x00\x00s\x00\x00\x00e\x00\x00\x00r\x00\x00\x00v\x00\x00\x00e\x00\x00\x00r\x00\x00\x00,\x00\x00\x00 \x00\x00\x00t\x00\x00\x00h\x00\x00\x00i\x00\x00\x00s\x00\x00" (truncated a bit) First of all, the response body starts in the wrong place... it should start with "<!DOCTYPE html>". Then, somewhere in the middle it switches to garbage output. I'm not sure why. Again, it's fine before being wrapped in the custom-binary-input/output-port. So either it's my fault (could well be) or there's a bug in the custom-binary-input/output-port implementation. I feel like I don't know enough to be sure. I would assume it's on my end, but since I think this is the first major use of that interface, a bug seems hardly impossible. Anyway, to test this bug you'll need to have gnutls compiled with a newer Guile. I've attached the hacky guix package I'm using to test this. Then you'll want to do: $ guix environment --ad-hoc gnutls-with-guile-next guile-next (You need guile-next even if doing gnutls-with-guile-next in the environment to enable the Guile 2.2 paths.) I could use some help on this... I'm afraid that if I've done something wrong, I'm not knowledgeable enough to know how to get out of the problem. [-- Warning: decoded text below may be mangled, UTF-8 assumed --] [-- Attachment #2: 0001-web-Add-https-support-through-gnutls.patch --] [-- Type: text/x-patch, Size: 9746 bytes --] From 91c0a4a728ca4bf2e9468cdc849c350dd3f7380f Mon Sep 17 00:00:00 2001 From: Christopher Allan Webber <cwebber@dustycloud.org> 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 + ;; <http://bugs.gnu.org/18526> 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 <http://bugs.gnu.org/23311>. + ;; Explicitly disable SSLv3, which is insecure: + ;; <https://tools.ietf.org/html/rfc7568>. + ((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 ^ permalink raw reply related [flat|nested] 12+ messages in thread
* bug#24075: tls/https support in Guile (through r6rs binary ports?) 2016-11-06 18:32 ` Christopher Allan Webber @ 2016-11-06 21:06 ` Ludovic Courtès 2016-11-07 4:40 ` Christopher Allan Webber 0 siblings, 1 reply; 12+ messages in thread From: Ludovic Courtès @ 2016-11-06 21:06 UTC (permalink / raw) To: Christopher Allan Webber; +Cc: 24075 Christopher Allan Webber <cwebber@dustycloud.org> skribis: > First of all, the response body starts in the wrong place... it should > start with "<!DOCTYPE html>". Then, somewhere in the middle it switches > to garbage output. I'm not sure why. [...] > + (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))) Looks like ‘start’ is ignored here. Could that be the reason? Ludo’. ^ permalink raw reply [flat|nested] 12+ messages in thread
* bug#24075: tls/https support in Guile (through r6rs binary ports?) 2016-11-06 21:06 ` Ludovic Courtès @ 2016-11-07 4:40 ` Christopher Allan Webber 0 siblings, 0 replies; 12+ messages in thread From: Christopher Allan Webber @ 2016-11-07 4:40 UTC (permalink / raw) To: Ludovic Courtès; +Cc: 24075 Ludovic Courtès writes: > Christopher Allan Webber <cwebber@dustycloud.org> skribis: > >> First of all, the response body starts in the wrong place... it should >> start with "<!DOCTYPE html>". Then, somewhere in the middle it switches >> to garbage output. I'm not sure why. > > [...] > >> + (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))) > > Looks like ‘start’ is ignored here. Could that be the reason? > > Ludo’. ... that was absolutely it. What an omission on my part! Thanks for catching it. :) ^ permalink raw reply [flat|nested] 12+ messages in thread
end of thread, other threads:[~2016-11-07 20:13 UTC | newest] Thread overview: 12+ messages (download: mbox.gz / follow: Atom feed) -- links below jump to the message on this page -- 2016-07-26 15:55 bug#24075: tls/https support in Guile (through r6rs binary ports?) Christopher Allan Webber 2016-08-04 20:37 ` Andy Wingo 2016-08-21 15:58 ` Christopher Allan Webber 2016-11-05 18:39 ` Christopher Allan Webber 2016-11-05 19:02 ` Ludovic Courtès 2016-11-06 17:37 ` Christopher Allan Webber 2016-11-06 21:13 ` Ludovic Courtès 2016-11-07 18:14 ` Christopher Allan Webber 2016-11-07 20:13 ` Ludovic Courtès 2016-11-06 18:32 ` Christopher Allan Webber 2016-11-06 21:06 ` Ludovic Courtès 2016-11-07 4:40 ` Christopher Allan Webber
This is a public inbox, see mirroring instructions for how to clone and mirror all data and code used for this inbox; as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).