01/11: gnu-maintenance: Factorize 'false-if-networking-failure'.

[guix-commits]

civodul pushed a commit to branch master
in repository guix.

commit f3edf29c67b50de888ff23c771b4cbe3e8142656
Author: Ludovic Courtès <ludo@gnu.org>
AuthorDate: Tue Jan 3 14:24:26 2023 +0100

    gnu-maintenance: Factorize 'false-if-networking-failure'.
    
    * guix/import/utils.scm (call-with-networking-exception-handler): New
    procedure.
    (false-if-networking-error): New macro.
    * guix/gnu-maintenance.scm (import-html-updatable-release): Use it
    instead of inline code.
---
 guix/gnu-maintenance.scm | 23 +++++++----------------
 guix/import/utils.scm    | 24 +++++++++++++++++++++++-
 2 files changed, 30 insertions(+), 17 deletions(-)

diff --git a/guix/gnu-maintenance.scm b/guix/gnu-maintenance.scm
index 8e60e52ea0..0418c297f2 100644
--- a/guix/gnu-maintenance.scm
+++ b/guix/gnu-maintenance.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2010-2022 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2010-2023 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2012, 2013 Nikita Karetnikov <nikita@karetnikov.org>
 ;;; Copyright © 2021 Simon Tournier <zimon.toutoune@gmail.com>
 ;;; Copyright © 2022 Maxime Devos <maximedevos@telenet.be>
@@ -43,6 +43,7 @@
   #:use-module (guix records)
   #:use-module (guix upstream)
   #:use-module (guix packages)
+  #:autoload   (guix import utils) (false-if-networking-error)
   #:autoload   (zlib) (call-with-gzip-input-port)
   #:autoload   (htmlprag) (html->sxml)            ;from Guile-Lib
   #:export (gnu-package-name
@@ -871,21 +872,11 @@ string to fetch a specific version."
                         ""
                         (dirname (uri-path uri))))
          (package   (package-upstream-name package)))
-    (catch #t
-      (lambda ()
-        (guard (c ((http-get-error? c) #f))
-          (import-html-release package
-                               #:version version
-                               #:base-url base
-                               #:directory directory)))
-      (lambda (key . args)
-        ;; Return false and move on upon connection failures and bogus HTTP
-        ;; servers.
-        (unless (memq key '(gnutls-error tls-certificate-error
-                                         system-error getaddrinfo-error
-                                         bad-header bad-header-component))
-          (apply throw key args))
-        #f))))
+    (false-if-networking-error
+     (import-html-release package
+                          #:version version
+                          #:base-url base
+                          #:directory directory))))
 
 (define %gnu-updater
   ;; This is for everything at ftp.gnu.org.
diff --git a/guix/import/utils.scm b/guix/import/utils.scm
index 41311cb86e..72795d2c61 100644
--- a/guix/import/utils.scm
+++ b/guix/import/utils.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012, 2013, 2018, 2019, 2020, 2023 Ludovic Courtès 
<ludo@gnu.org>
 ;;; Copyright © 2016 Jelle Licht <jlicht@fsfe.org>
 ;;; Copyright © 2016 David Craven <david@craven.ch>
 ;;; Copyright © 2017, 2019, 2020, 2022 Ricardo Wurmus <rekado@elephly.net>
@@ -54,10 +54,12 @@
   #:use-module (srfi srfi-9)
   #:use-module (srfi srfi-11)
   #:use-module (srfi srfi-26)
+  #:use-module (srfi srfi-34)
   #:use-module (srfi srfi-71)
   #:export (factorize-uri
 
             flatten
+            false-if-networking-error
 
             url-fetch
             guix-hash-url
@@ -122,6 +124,26 @@ of the string VERSION is replaced by the symbol 'version."
      (cons elem memo)))
    '() lst))
 
+(define (call-with-networking-exception-handler thunk)
+  "Invoke THUNK, returning #f if one of the usual networking exception is
+thrown."
+  (catch #t
+    (lambda ()
+      (guard (c ((http-get-error? c) #f))
+        (thunk)))
+    (lambda (key . args)
+      ;; Return false and move on upon connection failures and bogus HTTP
+      ;; servers.
+      (unless (memq key '(gnutls-error tls-certificate-error
+                                       system-error getaddrinfo-error
+                                       bad-header bad-header-component))
+        (apply throw key args))
+      #f)))
+
+(define-syntax-rule (false-if-networking-error exp)
+  "Evaluate EXP, returning #f if a networking-related exception is thrown."
+  (call-with-networking-exception-handler (lambda () exp)))
+
 (define (url-fetch url file-name)
   "Save the contents of URL to FILE-NAME.  Return #f on failure."
   (parameterize ((current-output-port (current-error-port)))