amaharaneko/guix-mirrors
1
1
Fork 0
mirror of https://codeberg.org/guix/guix.git synced 2025-10-02 02:15:12 +00:00
Code Issues Projects Releases Packages Wiki Activity Actions

gnu-maintenance: 'sourceforge' updater reuses the same connection.

Browse source 
* guix/gnu-maintenance.scm (latest-sourceforge-release): Call
'open-socket-for-uri' upfront.  Pass #:port and #:keep-alive? to
'http-head'.  Wrap body in 'dynamic-wind' and call 'close-port' upon
exit.
This commit is contained in:
Ludovic Courtès 2021-04-08 09:34:03 +02:00
parent 91fe9dd08e
commit eb6ac483a5
No known key found for this signature in database
GPG key ID: 090B11993D9AEBB5
1 changed files with 35 additions and 26 deletions
Download patch file Download diff file Expand all files Collapse all files

21
guix/gnu-maintenance.scm
View file

@ -31,7 +31,7 @@
#:use-module (srfi srfi-34) #:use-module (srfi srfi-34)
#:use-module (rnrs io ports) #:use-module (rnrs io ports)
#:use-module (system foreign) #:use-module (system foreign)
#:use-module (guix http-client) #:use-module ((guix http-client) #:hide (open-socket-for-uri))
#:use-module (guix ftp-client) #:use-module (guix ftp-client)
#:use-module (guix utils) #:use-module (guix utils)
#:use-module (guix memoization) #:use-module (guix memoization)
@ -669,10 +669,10 @@ GNOME packages; EMMS is included though, because its releases are on gnu.org."
#:host (uri-host uri) #:host (uri-host uri)
#:path (string-append (uri-path uri) extension))) #:path (string-append (uri-path uri) extension)))
(define (valid-uri? uri) (define (valid-uri? uri port)
;; Return true if URI is reachable. ;; Return true if URI is reachable.
(false-if-exception (false-if-exception
(case (response-code (http-head uri)) (case (response-code (http-head uri #:port port #:keep-alive? #t))
((200 302) #t) ((200 302) #t)
(else #f)))) (else #f))))
@ -680,7 +680,13 @@ GNOME packages; EMMS is included though, because its releases are on gnu.org."
(base (string-append "https://sourceforge.net/projects/" (base (string-append "https://sourceforge.net/projects/"
name "/files")) name "/files"))
(url (string-append base "/latest/download")) (url (string-append base "/latest/download"))
(response (false-if-exception (http-head url)))) (uri (string->uri url))
(port (false-if-exception (open-socket-for-uri uri)))
(response (and port
(http-head uri #:port port #:keep-alive? #t))))
(dynamic-wind
(const #t)
(lambda ()
(and response (and response
(= 302 (response-code response)) (= 302 (response-code response))
(response-location response) (response-location response)
@ -696,14 +702,17 @@ GNOME packages; EMMS is included though, because its releases are on gnu.org."
(let* ((loc (response-location response)) (let* ((loc (response-location response))
(sig (any (lambda (extension) (sig (any (lambda (extension)
(let ((uri (uri-append loc extension))) (let ((uri (uri-append loc extension)))
(and (valid-uri? uri) (and (valid-uri? uri port)
(string-append url extension)))) (string-append url extension))))
'(".asc" ".sig" ".sign")))) '(".asc" ".sig" ".sign"))))
(upstream-source (upstream-source
(package name) (package name)
(version (tarball->version (basename path))) (version (tarball->version (basename path)))
(urls (list url)) (urls (list url))
(signature-urls (and sig (list sig)))))))))))) (signature-urls (and sig (list sig)))))))))))
(lambda ()
(when port
(close-port port))))))
(define (latest-xorg-release package) (define (latest-xorg-release package)
"Return the latest release of PACKAGE." "Return the latest release of PACKAGE."