mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-04-30 03:40:34 +02:00
web: Adjust (gnutls) loading to new module autoload semantics.
Prior to commitcb14fd2143
(Guile 2.9.7), autoloading a module would give you access to all its bindings. In future versions, autoloading a module gives access only to the listed bindings, as per #:select (see <https://bugs.gnu.org/38895>). This commit adjusts autoloads to the new semantics, fixing a regression introduced incb14fd2143
. * module/web/client.scm <top level>: Remove 'module-autoload!' call. (gnutls-module, ensure-gnutls): Remove. (load-gnutls): New procedure. (tls-wrap): Call it instead of 'ensure-gnutls'. Replace reference to GNUTLS-MODULE by a call to 'resolve-interface'.
This commit is contained in:
parent
287d513ef1
commit
c9b83a27c7
1 changed files with 16 additions and 27 deletions
|
@ -1,6 +1,6 @@
|
||||||
;;; Web client
|
;;; Web client
|
||||||
|
|
||||||
;; Copyright (C) 2011, 2012, 2013, 2014, 2015, 2016, 2017, 2018 Free Software Foundation, Inc.
|
;; Copyright (C) 2011, 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2020 Free Software Foundation, Inc.
|
||||||
|
|
||||||
;; This library is free software; you can redistribute it and/or
|
;; This library is free software; you can redistribute it and/or
|
||||||
;; modify it under the terms of the GNU Lesser General Public
|
;; modify it under the terms of the GNU Lesser General Public
|
||||||
|
@ -62,32 +62,21 @@
|
||||||
|
|
||||||
;; Autoload GnuTLS so that this module can be used even when GnuTLS is
|
;; Autoload GnuTLS so that this module can be used even when GnuTLS is
|
||||||
;; not available. At compile time, this yields "possibly unbound
|
;; not available. At compile time, this yields "possibly unbound
|
||||||
;; variable" warnings, but these are OK: we know that the variables will
|
;; variable" warnings, but these are OK: they'll be resolved at run time
|
||||||
;; be bound if we need them, because (guix download) adds GnuTLS as an
|
;; thanks to 'load-gnutls'.
|
||||||
;; input in that case.
|
|
||||||
|
|
||||||
;; XXX: Use this hack instead of #:autoload to avoid compilation errors.
|
(define (load-gnutls)
|
||||||
;; See <http://bugs.gnu.org/12202>.
|
"Attempt to load the (gnutls) module. Throw to 'gnutls-not-available
|
||||||
(module-autoload! (current-module)
|
if it is unavailable."
|
||||||
'(gnutls) '(make-session connection-end/client))
|
|
||||||
|
|
||||||
(define gnutls-module
|
|
||||||
(delay
|
|
||||||
(catch 'misc-error
|
(catch 'misc-error
|
||||||
(lambda ()
|
(lambda ()
|
||||||
(let ((module (resolve-interface '(gnutls))))
|
;; XXX: Use this hack instead of #:autoload to avoid compilation
|
||||||
;; In some 2.1/2.2 installations installed alongside Guile 2.0, gnutls
|
;; errors. See <http://bugs.gnu.org/12202>.
|
||||||
;; can be imported but the bindings are broken as "unknown type".
|
(module-use! (resolve-module '(web client))
|
||||||
;; Here we check that gnutls-version is the right type (a procedure)
|
(resolve-interface '(gnutls))))
|
||||||
;; to make sure the bindings are ok.
|
(lambda _
|
||||||
(if (procedure? (module-ref module 'gnutls-version))
|
|
||||||
module
|
|
||||||
#f)))
|
|
||||||
(const #f))))
|
|
||||||
|
|
||||||
(define (ensure-gnutls)
|
|
||||||
(if (not (force gnutls-module))
|
|
||||||
(throw 'gnutls-not-available "(gnutls) module not available")))
|
(throw 'gnutls-not-available "(gnutls) module not available")))
|
||||||
|
(set! load-gnutls (const #t)))
|
||||||
|
|
||||||
(define current-http-proxy
|
(define current-http-proxy
|
||||||
(make-parameter (let ((proxy (getenv "http_proxy")))
|
(make-parameter (let ((proxy (getenv "http_proxy")))
|
||||||
|
@ -101,14 +90,14 @@ host name without trailing dot."
|
||||||
(format (current-error-port)
|
(format (current-error-port)
|
||||||
"gnutls: [~a|~a] ~a" (getpid) level str))
|
"gnutls: [~a|~a] ~a" (getpid) level str))
|
||||||
|
|
||||||
(ensure-gnutls)
|
(load-gnutls)
|
||||||
|
|
||||||
(let ((session (make-session connection-end/client)))
|
(let ((session (make-session connection-end/client)))
|
||||||
;; Some servers such as 'cloud.github.com' require the client to support
|
;; Some servers such as 'cloud.github.com' require the client to support
|
||||||
;; the 'SERVER NAME' extension. However, 'set-session-server-name!' is
|
;; the 'SERVER NAME' extension. However, 'set-session-server-name!' is
|
||||||
;; not available in older GnuTLS releases. See
|
;; not available in older GnuTLS releases. See
|
||||||
;; <http://bugs.gnu.org/18526> for details.
|
;; <http://bugs.gnu.org/18526> for details.
|
||||||
(if (module-defined? (force gnutls-module)
|
(if (module-defined? (resolve-interface '(gnutls))
|
||||||
'set-session-server-name!)
|
'set-session-server-name!)
|
||||||
(set-session-server-name! session server-name-type/dns server)
|
(set-session-server-name! session server-name-type/dns server)
|
||||||
(format (current-error-port)
|
(format (current-error-port)
|
||||||
|
|
Loading…
Add table
Add a link
Reference in a new issue