mirror/guix
1
0
Fork 0
mirror of https://git.savannah.gnu.org/git/guix.git synced 2025-01-18 21:46:35 +01:00
Code Issues Projects Releases Packages Wiki Activity Actions

gnu-maintenance: Add 'sourceforge' updater.

Browse source 
This updater currently covers 2.4% of the packages.

* guix/gnu-maintenance.scm (latest-sourceforge-release): New procedure.
(%sourceforge-updater): New variable.
* doc/guix.texi (Invoking guix refresh): Document it.
This commit is contained in:
Ludovic Courtès 2021-04-04 22:33:44 +02:00
parent 10b01e7ed6
commit b92cfc322d
No known key found for this signature in database
GPG key ID: 090B11993D9AEBB5
2 changed files with 54 additions and 0 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

2
doc/guix.texi
View file

@ -11713,6 +11713,8 @@ list of updaters). Currently, @var{updater} may be one of:
the updater for GNU packages;
@item savannah
the updater for packages hosted at @uref{https://savannah.gnu.org, Savannah};
@item sourceforge
the updater for packages hosted at @uref{https://sourceforge.net, SourceForge};
@item gnome
the updater for GNOME packages;
@item kde

52
guix/gnu-maintenance.scm
View file

@ -66,6 +66,7 @@ (define-module (guix gnu-maintenance)
%gnu-updater
%gnu-ftp-updater
%savannah-updater
%sourceforge-updater
%xorg-updater
%kernel.org-updater
%generic-html-updater))
@ -660,6 +661,50 @@ (define (latest-savannah-release package)
#:directory directory)
(cut adjusted-upstream-source <> rewrite))))
(define (latest-sourceforge-release package)
"Return the latest release of PACKAGE."
(define (uri-append uri extension)
;; Return URI with EXTENSION appended.
(build-uri (uri-scheme uri)
#:host (uri-host uri)
#:path (string-append (uri-path uri) extension)))
(define (valid-uri? uri)
;; Return true if URI is reachable.
(false-if-exception
(case (response-code (http-head uri))
((200 302) #t)
(else #f))))
(let* ((name (package-upstream-name package))
(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))
;; 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))))))))))))
(define (latest-xorg-release package)
"Return the latest release of PACKAGE."
(let ((uri (string->uri (origin-uri (package-source package)))))
@ -774,6 +819,13 @@ (define %savannah-updater
(pred (url-prefix-predicate "mirror://savannah/"))
(latest latest-savannah-release)))
(define %sourceforge-updater
(upstream-updater
(name 'sourceforge)
(description "Updater for packages hosted on sourceforge.net")
(pred (url-prefix-predicate "mirror://sourceforge/"))
(latest latest-sourceforge-release)))
(define %xorg-updater
(upstream-updater
(name 'xorg)