Commit | Line | Data |
---|---|---|
233e7676 LC |
1 | ;;; GNU Guix --- Functional package management for GNU |
2 | ;;; Copyright © 2012 Nikita Karetnikov <nikita@karetnikov.org> | |
98fefb21 | 3 | ;;; Copyright © 2010, 2011, 2012, 2013 Ludovic Courtès <ludo@gnu.org> |
22189ed1 | 4 | ;;; |
233e7676 | 5 | ;;; This file is part of GNU Guix. |
22189ed1 | 6 | ;;; |
233e7676 | 7 | ;;; GNU Guix is free software; you can redistribute it and/or modify it |
22189ed1 NK |
8 | ;;; under the terms of the GNU General Public License as published by |
9 | ;;; the Free Software Foundation; either version 3 of the License, or (at | |
10 | ;;; your option) any later version. | |
11 | ;;; | |
233e7676 | 12 | ;;; GNU Guix is distributed in the hope that it will be useful, but |
22189ed1 NK |
13 | ;;; WITHOUT ANY WARRANTY; without even the implied warranty of |
14 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
15 | ;;; GNU General Public License for more details. | |
16 | ;;; | |
17 | ;;; You should have received a copy of the GNU General Public License | |
233e7676 | 18 | ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. |
22189ed1 NK |
19 | |
20 | (define-module (guix gnu-maintenance) | |
21 | #:use-module (web uri) | |
22 | #:use-module (web client) | |
23 | #:use-module (web response) | |
24 | #:use-module (ice-9 regex) | |
98fefb21 | 25 | #:use-module (ice-9 match) |
22189ed1 NK |
26 | #:use-module (srfi srfi-1) |
27 | #:use-module (srfi srfi-11) | |
28 | #:use-module (srfi srfi-26) | |
98fefb21 LC |
29 | #:use-module (system foreign) |
30 | #:use-module (guix ftp-client) | |
0d1e6ce4 | 31 | #:use-module (guix utils) |
ef010c0f | 32 | #:use-module (guix packages) |
98fefb21 | 33 | #:export (official-gnu-packages |
ef010c0f | 34 | gnu-package? |
98fefb21 LC |
35 | releases |
36 | latest-release | |
37 | gnu-package-name->name+version)) | |
38 | ||
39 | ;;; Commentary: | |
40 | ;;; | |
41 | ;;; Code for dealing with the maintenance of GNU packages, such as | |
42 | ;;; auto-updates. | |
43 | ;;; | |
44 | ;;; Code: | |
45 | ||
46 | \f | |
47 | ;;; | |
48 | ;;; List of GNU packages. | |
49 | ;;; | |
22189ed1 NK |
50 | |
51 | (define (http-fetch uri) | |
52 | "Return a string containing the textual data at URI, a string." | |
53 | (let*-values (((resp data) | |
54 | (http-get (string->uri uri))) | |
55 | ((code) | |
56 | (response-code resp))) | |
57 | (case code | |
58 | ((200) | |
993fb66d LC |
59 | (if data |
60 | data | |
61 | (begin | |
62 | ;; XXX: Guile 2.0.5 and earlier did not support chunked transfer | |
63 | ;; encoding, which is required when fetching %PACKAGE-LIST-URL | |
64 | ;; (see <http://lists.gnu.org/archive/html/guile-devel/2011-09/msg00089.html>). | |
65 | ;; Since users may still be using these versions, warn them and | |
66 | ;; bail out. | |
67 | (format (current-error-port) | |
68 | "warning: using Guile ~a, which does not support HTTP ~s encoding~%" | |
69 | (version) | |
70 | (response-transfer-encoding resp)) | |
71 | (error "download failed; use a newer Guile" | |
72 | uri resp)))) | |
22189ed1 NK |
73 | (else |
74 | (error "download failed:" uri code | |
75 | (response-reason-phrase resp)))))) | |
76 | ||
77 | (define %package-list-url | |
78 | (string-append "http://cvs.savannah.gnu.org/" | |
79 | "viewvc/*checkout*/gnumaint/" | |
80 | "gnupackages.txt?root=womb")) | |
81 | ||
82 | (define (official-gnu-packages) | |
83 | "Return a list of GNU packages." | |
84 | (define %package-line-rx | |
85 | (make-regexp "^package: (.+)$")) | |
86 | ||
87 | (let ((lst (string-split (http-fetch %package-list-url) #\nl))) | |
88 | (filter-map (lambda (line) | |
89 | (and=> (regexp-exec %package-line-rx line) | |
90 | (cut match:substring <> 1))) | |
91 | lst))) | |
ef010c0f LC |
92 | |
93 | (define gnu-package? | |
94 | (memoize | |
95 | (lambda (package) | |
96 | "Return true if PACKAGE is a GNU package. This procedure may access the | |
97 | network to check in GNU's database." | |
98 | ;; TODO: Find a way to determine that a package is non-GNU without going | |
99 | ;; through the network. | |
296540a6 LC |
100 | (let ((url (and=> (package-source package) origin-uri))) |
101 | (or (and (string? url) (string-prefix? "mirror://gnu" url)) | |
102 | (and (member (package-name package) (official-gnu-packages)) | |
103 | #t)))))) | |
ef010c0f | 104 | |
98fefb21 LC |
105 | \f |
106 | ;;; | |
107 | ;;; Latest release. | |
108 | ;;; | |
109 | ||
110 | (define (ftp-server/directory project) | |
111 | "Return the FTP server and directory where PROJECT's tarball are | |
112 | stored." | |
113 | (define quirks | |
114 | '(("commoncpp2" "ftp.gnu.org" "/gnu/commoncpp") | |
115 | ("ucommon" "ftp.gnu.org" "/gnu/commoncpp") | |
116 | ("libzrtpcpp" "ftp.gnu.org" "/gnu/ccrtp") | |
117 | ("libosip2" "ftp.gnu.org" "/gnu/osip") | |
118 | ("libgcrypt" "ftp.gnupg.org" "/gcrypt/libgcrypt") | |
119 | ("libgpg-error" "ftp.gnupg.org" "/gcrypt/libgpg-error") | |
120 | ("libassuan" "ftp.gnupg.org" "/gcrypt/libassuan") | |
121 | ("gnupg" "ftp.gnupg.org" "/gcrypt/gnupg") | |
122 | ("freefont-ttf" "ftp.gnu.org" "/gnu/freefont") | |
123 | ("gnu-ghostscript" "ftp.gnu.org" "/gnu/ghostscript") | |
124 | ("mit-scheme" "ftp.gnu.org" "/gnu/mit-scheme/stable.pkg") | |
125 | ("icecat" "ftp.gnu.org" "/gnu/gnuzilla") | |
126 | ("source-highlight" "ftp.gnu.org" "/gnu/src-highlite") | |
127 | ("TeXmacs" "ftp.texmacs.org" "/TeXmacs/targz"))) | |
128 | ||
129 | (match (assoc project quirks) | |
130 | ((_ server directory) | |
131 | (values server directory)) | |
132 | (_ | |
133 | (values "ftp.gnu.org" (string-append "/gnu/" project))))) | |
134 | ||
135 | (define (releases project) | |
136 | "Return the list of releases of PROJECT as a list of release name/directory | |
137 | pairs. Example: (\"mit-scheme-9.0.1\" . \"/gnu/mit-scheme/stable.pkg/9.0.1\"). " | |
138 | ;; TODO: Parse something like fencepost.gnu.org:/gd/gnuorg/packages-ftp. | |
139 | (define release-rx | |
140 | (make-regexp (string-append "^" project | |
141 | "-([0-9]|[^-])*(-src)?\\.tar\\."))) | |
142 | ||
143 | (define alpha-rx | |
144 | (make-regexp "^.*-.*[0-9](-|~)?(alpha|beta|rc|cvs|svn|git)-?[0-9\\.]*\\.tar\\.")) | |
145 | ||
146 | (define (sans-extension tarball) | |
147 | (let ((end (string-contains tarball ".tar"))) | |
148 | (substring tarball 0 end))) | |
149 | ||
6a917ef7 LC |
150 | (define (release-file file) |
151 | ;; Return #f if FILE is not a release tarball, otherwise return | |
152 | ;; PACKAGE-VERSION. | |
153 | (and (not (string-suffix? ".sig" file)) | |
154 | (regexp-exec release-rx file) | |
155 | (not (regexp-exec alpha-rx file)) | |
156 | (let ((s (sans-extension file))) | |
157 | (and (regexp-exec %package-name-rx s) s)))) | |
158 | ||
98fefb21 LC |
159 | (let-values (((server directory) (ftp-server/directory project))) |
160 | (define conn (ftp-open server)) | |
161 | ||
162 | (let loop ((directories (list directory)) | |
163 | (result '())) | |
6a917ef7 LC |
164 | (match directories |
165 | (() | |
166 | (ftp-close conn) | |
167 | result) | |
168 | ((directory rest ...) | |
169 | (let* ((files (ftp-list conn directory)) | |
170 | (subdirs (filter-map (match-lambda | |
171 | ((name 'directory . _) name) | |
172 | (_ #f)) | |
173 | files))) | |
174 | (loop (append (map (cut string-append directory "/" <>) | |
175 | subdirs) | |
176 | rest) | |
177 | (append | |
178 | ;; Filter out signatures, deltas, and files which | |
179 | ;; are potentially not releases of PROJECT--e.g., | |
180 | ;; in /gnu/guile, filter out guile-oops and | |
181 | ;; guile-www; in mit-scheme, filter out binaries. | |
182 | (filter-map (match-lambda | |
183 | ((file 'file . _) | |
184 | (and=> (release-file file) | |
185 | (cut cons <> directory))) | |
186 | (_ #f)) | |
187 | files) | |
188 | result)))))))) | |
98fefb21 | 189 | |
98fefb21 LC |
190 | (define (latest-release project) |
191 | "Return (\"FOO-X.Y\" . \"/bar/foo\") or #f." | |
192 | (let ((releases (releases project))) | |
193 | (and (not (null? releases)) | |
194 | (fold (lambda (release latest) | |
0d1e6ce4 | 195 | (if (version>? (car release) (car latest)) |
98fefb21 LC |
196 | release |
197 | latest)) | |
198 | '("" . "") | |
199 | releases)))) | |
200 | ||
201 | (define %package-name-rx | |
202 | ;; Regexp for a package name, e.g., "foo-X.Y". Since TeXmacs uses | |
203 | ;; "TeXmacs-X.Y-src", the `-src' suffix is allowed. | |
204 | (make-regexp "^(.*)-(([0-9]|\\.)+)(-src)?")) | |
205 | ||
206 | (define (gnu-package-name->name+version name+version) | |
207 | "Return the package name and version number extracted from NAME+VERSION." | |
208 | (let ((match (regexp-exec %package-name-rx name+version))) | |
209 | (if (not match) | |
210 | (values name+version #f) | |
211 | (values (match:substring match 1) (match:substring match 2))))) | |
212 | ||
213 | ;;; gnu-maintenance.scm ends here |