* 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-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 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: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
* 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
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).