guix/guix
3
4
Fork 0
mirror of git://git.savannah.gnu.org/guix.git synced 2023-12-14 03:33:07 +01:00
Code Issues Releases Wiki Activity

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
Show stats Download patch file Download diff file Expand all files Collapse all files

61
guix/gnu-maintenance.scm
View file

@ -31,7 +31,7 @@
#:use-module (srfi srfi-34)
#:use-module (rnrs io ports)
#: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 utils)
#: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)
#:path (string-append (uri-path uri) extension)))
(define (valid-uri? uri)
(define (valid-uri? uri port)
;; Return true if URI is reachable.
(false-if-exception
(case (response-code (http-head uri))
(case (response-code (http-head uri #:port port #:keep-alive? #t))
((200 302) #t)
(else #f))))
@ -680,30 +680,39 @@ GNOME packages; EMMS is included though, because its releases are on gnu.org."
(base (string-append "https://sourceforge.net/projects/"
name "/files"))
(url (string-append base "/latest/download"))
(response (false-if-exception (http-head url))))
(and response
(= 302 (response-code response))
(response-location response)
(match (string-tokenize (uri-path (response-location response))
(char-set-complement (char-set #\/)))
((_ components ...)
(let* ((path (string-join components "/"))
(url (string-append "mirror://sourceforge/" path)))
(and (release-file? name (basename path))
(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
(= 302 (response-code response))
(response-location response)
(match (string-tokenize (uri-path (response-location response))
(char-set-complement (char-set #\/)))
((_ components ...)
(let* ((path (string-join components "/"))
(url (string-append "mirror://sourceforge/" path)))
(and (release-file? name (basename path))
;; Take the heavy-handed approach of probing 3 additional
;; URLs. XXX: Would be nicer if this could be avoided.
(let* ((loc (response-location response))
(sig (any (lambda (extension)
(let ((uri (uri-append loc extension)))
(and (valid-uri? uri)
(string-append url extension))))
'(".asc" ".sig" ".sign"))))
(upstream-source
(package name)
(version (tarball->version (basename path)))
(urls (list url))
(signature-urls (and sig (list sig))))))))))))
;; Take the heavy-handed approach of probing 3 additional
;; URLs. XXX: Would be nicer if this could be avoided.
(let* ((loc (response-location response))
(sig (any (lambda (extension)
(let ((uri (uri-append loc extension)))
(and (valid-uri? uri port)
(string-append url extension))))
'(".asc" ".sig" ".sign"))))
(upstream-source
(package name)
(version (tarball->version (basename path)))
(urls (list url))
(signature-urls (and sig (list sig)))))))))))
(lambda ()
(when port
(close-port port))))))
(define (latest-xorg-release package)
"Return the latest release of PACKAGE."