Initial commit

knots/non-blocking.scm

@@ -0,0 +1,63 @@
+;;; Guile Knots
+;;; Copyright © 2020 Christopher Baines <mail@cbaines.net>
+;;;
+;;; This file is part of Guile Knots.
+;;;
+;;; The Guile Knots is free software; you can redistribute it and/or
+;;; modify it under the terms of the GNU General Public License as
+;;; published by the Free Software Foundation; either version 3 of the
+;;; License, or (at your option) any later version.
+;;;
+;;; The Guile Knots is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;; General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with the guix-data-service.  If not, see
+;;; <http://www.gnu.org/licenses/>.
+
+(define-module (knots non-blocking)
+  #:use-module (web uri)
+  #:use-module (web client)
+  #:export (non-blocking-port
+            nonblocking-open-socket-for-uri))
+
+(define (non-blocking-port port)
+  "Make PORT non-blocking and return it."
+  (let ((flags (fcntl port F_GETFL)))
+    (when (zero? (logand O_NONBLOCK flags))
+      (fcntl port F_SETFL (logior O_NONBLOCK flags)))
+    port))
+
+(define* (nonblocking-open-socket-for-uri uri
+                                          #:key (verify-certificate? #t))
+  (define tls-wrap
+    (@@ (web client) tls-wrap))
+
+  (define https?
+    (eq? 'https (uri-scheme uri)))
+
+  (define plain-uri
+    (if https?
+        (build-uri
+         'http
+         #:userinfo (uri-userinfo uri)
+         #:host (uri-host uri)
+         #:port (or (uri-port uri) 443)
+         #:path (uri-path uri)
+         #:query (uri-query uri)
+         #:fragment (uri-fragment uri))
+        uri))
+
+  (let ((s (open-socket-for-uri plain-uri)))
+    (if https?
+        (let ((port
+               (tls-wrap s (uri-host uri)
+                         #:verify-certificate? verify-certificate?)))
+          ;; Guile/guile-gnutls don't handle the handshake happening on a non
+          ;; blocking socket, so change the behavior here.
+          (non-blocking-port s)
+          port)
+        (non-blocking-port s))))
+