mirror of
https://git.in.rschanz.org/ryan77627/guix.git
synced 2025-01-13 06:36:37 -05:00
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.
This commit is contained in:
parent
3012dad9eb
commit
f3edf29c67
2 changed files with 30 additions and 17 deletions
|
@ -1,5 +1,5 @@
|
||||||
;;; GNU Guix --- Functional package management for GNU
|
;;; 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 © 2012, 2013 Nikita Karetnikov <nikita@karetnikov.org>
|
||||||
;;; Copyright © 2021 Simon Tournier <zimon.toutoune@gmail.com>
|
;;; Copyright © 2021 Simon Tournier <zimon.toutoune@gmail.com>
|
||||||
;;; Copyright © 2022 Maxime Devos <maximedevos@telenet.be>
|
;;; Copyright © 2022 Maxime Devos <maximedevos@telenet.be>
|
||||||
|
@ -43,6 +43,7 @@ (define-module (guix gnu-maintenance)
|
||||||
#:use-module (guix records)
|
#:use-module (guix records)
|
||||||
#:use-module (guix upstream)
|
#:use-module (guix upstream)
|
||||||
#:use-module (guix packages)
|
#:use-module (guix packages)
|
||||||
|
#:autoload (guix import utils) (false-if-networking-error)
|
||||||
#:autoload (zlib) (call-with-gzip-input-port)
|
#:autoload (zlib) (call-with-gzip-input-port)
|
||||||
#:autoload (htmlprag) (html->sxml) ;from Guile-Lib
|
#:autoload (htmlprag) (html->sxml) ;from Guile-Lib
|
||||||
#:export (gnu-package-name
|
#:export (gnu-package-name
|
||||||
|
@ -871,21 +872,11 @@ (define* (import-html-updatable-release package #:key (version #f))
|
||||||
""
|
""
|
||||||
(dirname (uri-path uri))))
|
(dirname (uri-path uri))))
|
||||||
(package (package-upstream-name package)))
|
(package (package-upstream-name package)))
|
||||||
(catch #t
|
(false-if-networking-error
|
||||||
(lambda ()
|
(import-html-release package
|
||||||
(guard (c ((http-get-error? c) #f))
|
#:version version
|
||||||
(import-html-release package
|
#:base-url base
|
||||||
#:version version
|
#:directory directory))))
|
||||||
#: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))))
|
|
||||||
|
|
||||||
(define %gnu-updater
|
(define %gnu-updater
|
||||||
;; This is for everything at ftp.gnu.org.
|
;; This is for everything at ftp.gnu.org.
|
||||||
|
|
|
@ -1,5 +1,5 @@
|
||||||
;;; GNU Guix --- Functional package management for GNU
|
;;; 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 Jelle Licht <jlicht@fsfe.org>
|
||||||
;;; Copyright © 2016 David Craven <david@craven.ch>
|
;;; Copyright © 2016 David Craven <david@craven.ch>
|
||||||
;;; Copyright © 2017, 2019, 2020, 2022 Ricardo Wurmus <rekado@elephly.net>
|
;;; 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-9)
|
||||||
#:use-module (srfi srfi-11)
|
#:use-module (srfi srfi-11)
|
||||||
#:use-module (srfi srfi-26)
|
#:use-module (srfi srfi-26)
|
||||||
|
#:use-module (srfi srfi-34)
|
||||||
#:use-module (srfi srfi-71)
|
#:use-module (srfi srfi-71)
|
||||||
#:export (factorize-uri
|
#:export (factorize-uri
|
||||||
|
|
||||||
flatten
|
flatten
|
||||||
|
false-if-networking-error
|
||||||
|
|
||||||
url-fetch
|
url-fetch
|
||||||
guix-hash-url
|
guix-hash-url
|
||||||
|
@ -122,6 +124,26 @@ (define (flatten lst)
|
||||||
(cons elem memo)))
|
(cons elem memo)))
|
||||||
'() lst))
|
'() 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)
|
(define (url-fetch url file-name)
|
||||||
"Save the contents of URL to FILE-NAME. Return #f on failure."
|
"Save the contents of URL to FILE-NAME. Return #f on failure."
|
||||||
(parameterize ((current-output-port (current-error-port)))
|
(parameterize ((current-output-port (current-error-port)))
|
||||||
|
|
Loading…
Reference in a new issue