ryan77627/guix
1
0
Fork 0
mirror of https://git.in.rschanz.org/ryan77627/guix.git synced 2024-12-25 05:48:07 -05:00
Code Issues Projects Releases Packages Wiki Activity Actions

gnu-maintenance: Factorize 'false-if-networking-failure'.

Browse source 
* 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:
Ludovic Courtès 2023-01-03 14:24:26 +01:00
parent 3012dad9eb
commit f3edf29c67
No known key found for this signature in database
GPG key ID: 090B11993D9AEBB5
2 changed files with 30 additions and 17 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

23
guix/gnu-maintenance.scm
View file

@ -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.

24
guix/import/utils.scm
View file

@ -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)))