diff --git a/module/web/client.scm b/module/web/client.scm index a08c4203c..9273a45ad 100644 --- a/module/web/client.scm +++ b/module/web/client.scm @@ -320,7 +320,8 @@ host name without trailing dot." (read-response port)) (define* (open-socket-for-uri uri-or-string - #:key (verify-certificate? #t)) + #:key (verify-certificate? #t) + (flags 0)) "Return an open input/output port for a connection to URI-OR-STRING. When VERIFY-CERTIFICATE? is true, verify HTTPS server certificates." (define uri @@ -373,10 +374,18 @@ When VERIFY-CERTIFICATE? is true, verify HTTPS server certificates." (when (and https? (current-https-proxy)) (setup-http-tunnel s uri)) - (if https? - (tls-wrap s (uri-host uri) - #:verify-certificate? verify-certificate?) - s))) + (let ((port (if https? + (tls-wrap s (uri-host uri) + #:verify-certificate? verify-certificate?) + s))) + (unless (zero? flags) + ;; FLAGS might contain O_NONBLOCK. Thus, set it as a last step + ;; because 'handshake' otherwise throws an exception for + ;; GNUTLS_E_AGAIN. + (let ((initial-flags (fcntl s F_GETFL))) + (fcntl s F_SETFL (logior initial-flags flags)))) + + port))) (define (extend-request r k v . additional) (let ((r (set-field r (request-headers)