diff mbox series

[bug#60520,1/4] gnu-maintenance: Factorize 'false-if-networking-failure'.

Message ID 20230103170319.16637-1-ludo@gnu.org
State New
Headers show
Series Tests for 'guix refresh' | expand

Commit Message

Ludovic Courtès Jan. 3, 2023, 5:03 p.m. UTC 
* 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 mbox series

Patch

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 @@  (define-module (guix gnu-maintenance)
   #: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 @@  (define* (import-html-updatable-release package #:key (version #f))
                         ""
                         (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 @@  (define-module (guix import utils)
   #: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 @@  (define (flatten lst)
      (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)))