Commit | Line | Data |
---|---|---|
d45dc6da EB |
1 | ;;; GNU Guix --- Functional package management for GNU |
2 | ;;; Copyright © 2014 Eric Bavier <bavier@member.fsf.org> | |
431b28d9 | 3 | ;;; Copyright © 2015 Mark H Weaver <mhw@netris.org> |
5b8e564c | 4 | ;;; Copyright © 2016 Alex Sassmannshausen <alex@pompo.co> |
9aba9b12 | 5 | ;;; Copyright © 2017, 2018 Tobias Geerinckx-Rice <me@tobias.gr> |
69f13255 | 6 | ;;; Copyright © 2020 Ludovic Courtès <ludo@gnu.org> |
d45dc6da EB |
7 | ;;; |
8 | ;;; This file is part of GNU Guix. | |
9 | ;;; | |
10 | ;;; GNU Guix is free software; you can redistribute it and/or modify it | |
11 | ;;; under the terms of the GNU General Public License as published by | |
12 | ;;; the Free Software Foundation; either version 3 of the License, or (at | |
13 | ;;; your option) any later version. | |
14 | ;;; | |
15 | ;;; GNU Guix is distributed in the hope that it will be useful, but | |
16 | ;;; WITHOUT ANY WARRANTY; without even the implied warranty of | |
17 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
18 | ;;; GNU General Public License for more details. | |
19 | ;;; | |
20 | ;;; You should have received a copy of the GNU General Public License | |
21 | ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. | |
22 | ||
23 | (define-module (guix import cpan) | |
24 | #:use-module (ice-9 match) | |
25 | #:use-module (ice-9 regex) | |
66392e47 EB |
26 | #:use-module ((ice-9 popen) #:select (open-pipe* close-pipe)) |
27 | #:use-module ((ice-9 rdelim) #:select (read-line)) | |
d45dc6da | 28 | #:use-module (srfi srfi-1) |
ff55fe55 | 29 | #:use-module (srfi srfi-26) |
d45dc6da | 30 | #:use-module (json) |
ca719424 | 31 | #:use-module (gcrypt hash) |
d45dc6da | 32 | #:use-module (guix store) |
b77d17d0 | 33 | #:use-module (guix utils) |
d45dc6da | 34 | #:use-module (guix base32) |
ff55fe55 EB |
35 | #:use-module (guix ui) |
36 | #:use-module ((guix download) #:select (download-to-store url-fetch)) | |
69f13255 | 37 | #:use-module ((guix import utils) #:select (factorize-uri)) |
d45dc6da | 38 | #:use-module (guix import json) |
66392e47 | 39 | #:use-module (guix packages) |
ff55fe55 | 40 | #:use-module (guix upstream) |
66392e47 | 41 | #:use-module (guix derivations) |
69f13255 LC |
42 | #:export (cpan-dependency? |
43 | cpan-dependency-relationship | |
44 | cpan-dependency-phase | |
45 | cpan-dependency-module | |
46 | cpan-dependency-version | |
47 | ||
48 | cpan-release? | |
49 | cpan-release-license | |
50 | cpan-release-author | |
51 | cpan-release-version | |
9d1af83e | 52 | cpan-release-module |
69f13255 LC |
53 | cpan-release-distribution |
54 | cpan-release-download-url | |
55 | cpan-release-abstract | |
56 | cpan-release-home-page | |
57 | cpan-release-dependencies | |
58 | json->cpan-release | |
59 | ||
60 | cpan-fetch | |
61 | cpan->guix-package | |
62 | metacpan-url->mirror-url | |
4aea90b1 LC |
63 | %cpan-updater |
64 | ||
65 | %metacpan-base-url)) | |
d45dc6da EB |
66 | |
67 | ;;; Commentary: | |
68 | ;;; | |
69 | ;;; Generate a package declaration template for the latest version of a CPAN | |
70 | ;;; module, using meta-data from metacpan.org. | |
71 | ;;; | |
72 | ;;; Code: | |
73 | ||
4aea90b1 LC |
74 | (define %metacpan-base-url |
75 | ;; Base URL of the MetaCPAN API. | |
76 | (make-parameter "https://fastapi.metacpan.org/v1/")) | |
77 | ||
69f13255 LC |
78 | ;; Dependency of a "release". |
79 | (define-json-mapping <cpan-dependency> make-cpan-dependency cpan-dependency? | |
80 | json->cpan-dependency | |
81 | (relationship cpan-dependency-relationship "relationship" | |
82 | string->symbol) ;requires | suggests | |
83 | (phase cpan-dependency-phase "phase" | |
84 | string->symbol) ;develop | configure | test | runtime | |
85 | (module cpan-dependency-module) ;string | |
86 | (version cpan-dependency-version)) ;string | |
87 | ||
88 | ;; Release as returned by <https://fastapi.metacpan.org/v1/release/PKG>. | |
89 | (define-json-mapping <cpan-release> make-cpan-release cpan-release? | |
90 | json->cpan-release | |
91 | (license cpan-release-license) | |
92 | (author cpan-release-author) | |
93 | (version cpan-release-version "version" | |
94 | (match-lambda | |
95 | ((? number? version) | |
96 | ;; Version is sometimes not quoted in the module json, so | |
97 | ;; it gets imported into Guile as a number, so convert it | |
98 | ;; to a string (example: "X11-Protocol-Other"). | |
99 | (number->string version)) | |
100 | ((? string? version) | |
101 | ;; Sometimes we get a "v" prefix. Strip it. | |
102 | (if (string-prefix? "v" version) | |
103 | (string-drop version 1) | |
104 | version)))) | |
105 | (module cpan-release-module "main_module") ;e.g., "Test::Script" | |
106 | (distribution cpan-release-distribution) ;e.g., "Test-Script" | |
107 | (download-url cpan-release-download-url "download_url") | |
108 | (abstract cpan-release-abstract "abstract") | |
109 | (home-page cpan-release-home-page "resources" | |
110 | (match-lambda | |
111 | (#f #f) | |
112 | ((lst ...) (assoc-ref lst "homepage")))) | |
113 | (dependencies cpan-release-dependencies "dependency" | |
114 | (lambda (vector) | |
115 | (map json->cpan-dependency (vector->list vector))))) | |
116 | ||
d45dc6da EB |
117 | (define string->license |
118 | (match-lambda | |
119 | ;; List of valid values from https://metacpan.org/pod/CPAN::Meta::Spec. | |
120 | ;; Some licenses are excluded based on their absense from (guix licenses). | |
121 | ("agpl_3" 'agpl3) | |
122 | ;; apache_1_1 | |
123 | ("apache_2_0" 'asl2.0) | |
47945cf3 EB |
124 | ;; artistic_1 |
125 | ("artistic_2" 'artistic2.0) | |
d45dc6da EB |
126 | ("bsd" 'bsd-3) |
127 | ("freebsd" 'bsd-2) | |
128 | ;; gfdl_1_2 | |
129 | ("gfdl_1_3" 'fdl1.3+) | |
130 | ("gpl_1" 'gpl1) | |
131 | ("gpl_2" 'gpl2) | |
132 | ("gpl_3" 'gpl3) | |
133 | ("lgpl_2_1" 'lgpl2.1) | |
134 | ("lgpl_3_0" 'lgpl3) | |
135 | ("mit" 'x11) | |
136 | ;; mozilla_1_0 | |
137 | ("mozilla_1_1" 'mpl1.1) | |
138 | ("openssl" 'openssl) | |
01ef804d | 139 | ("perl_5" 'perl-license) ;GPL1+ and Artistic 1 |
d45dc6da EB |
140 | ("qpl_1_0" 'qpl) |
141 | ;; ssleay | |
142 | ;; sun | |
143 | ("zlib" 'zlib) | |
d020821c MW |
144 | (#(x) (string->license x)) |
145 | (#(lst ...) `(list ,@(map string->license lst))) | |
d45dc6da EB |
146 | (_ #f))) |
147 | ||
148 | (define (module->name module) | |
149 | "Transform a 'module' name into a 'release' name" | |
150 | (regexp-substitute/global #f "::" module 'pre "-" 'post)) | |
151 | ||
66392e47 EB |
152 | (define (module->dist-name module) |
153 | "Return the base distribution module for a given module. E.g. the 'ok' | |
154 | module is distributed with 'Test::Simple', so (module->dist-name \"ok\") would | |
155 | return \"Test-Simple\"" | |
d020821c | 156 | (assoc-ref (json-fetch (string-append |
4aea90b1 | 157 | (%metacpan-base-url) "/module/" |
d020821c MW |
158 | module |
159 | "?fields=distribution")) | |
160 | "distribution")) | |
66392e47 | 161 | |
ff55fe55 EB |
162 | (define (package->upstream-name package) |
163 | "Return the CPAN name of PACKAGE." | |
164 | (let* ((properties (package-properties package)) | |
165 | (upstream-name (and=> properties | |
166 | (cut assoc-ref <> 'upstream-name)))) | |
167 | (or upstream-name | |
168 | (match (package-source package) | |
169 | ((? origin? origin) | |
170 | (match (origin-uri origin) | |
171 | ((or (? string? url) (url _ ...)) | |
172 | (match (string-match (string-append "([^/]*)-v?[0-9\\.]+") url) | |
173 | (#f #f) | |
174 | (m (match:substring m 1)))) | |
175 | (_ #f))) | |
176 | (_ #f))))) | |
177 | ||
178 | (define (cpan-fetch name) | |
69f13255 LC |
179 | "Return a <cpan-release> record for Perl module MODULE, |
180 | or #f on failure. MODULE should be the distribution name, such as | |
181 | \"Test-Script\" for the \"Test::Script\" module." | |
d45dc6da | 182 | ;; This API always returns the latest release of the module. |
c00ae79c LC |
183 | (and=> (json-fetch (string-append (%metacpan-base-url) "/release/" |
184 | name)) | |
185 | json->cpan-release)) | |
d45dc6da EB |
186 | |
187 | (define (cpan-home name) | |
9aba9b12 | 188 | (string-append "https://metacpan.org/release/" name)) |
d45dc6da | 189 | |
69f13255 LC |
190 | (define (metacpan-url->mirror-url url) |
191 | "Replace 'https://cpan.metacpan.org' in URL with 'mirror://cpan'." | |
ff55fe55 | 192 | (regexp-substitute/global #f "http[s]?://cpan.metacpan.org" |
69f13255 | 193 | url |
5b8e564c AS |
194 | 'pre "mirror://cpan" 'post)) |
195 | ||
69f13255 LC |
196 | (define cpan-source-url |
197 | (compose metacpan-url->mirror-url cpan-release-download-url)) | |
5b8e564c | 198 | |
90eaa941 LC |
199 | (define (perl-package) |
200 | "Return the 'perl' package. This is a lazy reference so that we don't | |
201 | depend on (gnu packages perl)." | |
202 | (module-ref (resolve-interface '(gnu packages perl)) 'perl)) | |
203 | ||
66392e47 | 204 | (define %corelist |
431b28d9 MW |
205 | (delay |
206 | (let* ((perl (with-store store | |
207 | (derivation->output-path | |
90eaa941 | 208 | (package-derivation store (perl-package))))) |
431b28d9 MW |
209 | (core (string-append perl "/bin/corelist"))) |
210 | (and (access? core X_OK) | |
211 | core)))) | |
66392e47 | 212 | |
d391ad57 | 213 | (define core-module? |
90eaa941 | 214 | (let ((rx (make-regexp |
d391ad57 EB |
215 | (string-append "released with perl v?([0-9\\.]*)" |
216 | "(.*and removed from v?([0-9\\.]*))?")))) | |
217 | (lambda (name) | |
90eaa941 LC |
218 | (define perl-version |
219 | (package-version (perl-package))) | |
220 | ||
d391ad57 EB |
221 | (define (version-between? lower version upper) |
222 | (and (version>=? version lower) | |
223 | (or (not upper) | |
224 | (version>? upper version)))) | |
225 | (and (force %corelist) | |
226 | (parameterize ((current-error-port (%make-void-port "w"))) | |
227 | (let* ((corelist (open-pipe* OPEN_READ (force %corelist) name))) | |
228 | (let loop () | |
229 | (let ((line (read-line corelist))) | |
230 | (if (eof-object? line) | |
231 | (begin (close-pipe corelist) #f) | |
232 | (or (and=> (regexp-exec rx line) | |
233 | (lambda (m) | |
234 | (let ((first (match:substring m 1)) | |
235 | (last (match:substring m 3))) | |
236 | (version-between? | |
237 | first perl-version last)))) | |
238 | (loop))))))))))) | |
239 | ||
69f13255 LC |
240 | (define (cpan-module->sexp release) |
241 | "Return the 'package' s-expression for a CPAN module from the release data | |
242 | in RELEASE, a <cpan-release> record." | |
d45dc6da | 243 | (define name |
69f13255 | 244 | (cpan-release-distribution release)) |
d45dc6da EB |
245 | |
246 | (define (guix-name name) | |
247 | (if (string-prefix? "perl-" name) | |
248 | (string-downcase name) | |
249 | (string-append "perl-" (string-downcase name)))) | |
250 | ||
69f13255 LC |
251 | (define version (cpan-release-version release)) |
252 | (define source-url (cpan-source-url release)) | |
d45dc6da EB |
253 | |
254 | (define (convert-inputs phases) | |
255 | ;; Convert phase dependencies into a list of name/variable pairs. | |
69f13255 LC |
256 | (match (filter-map (lambda (dependency) |
257 | (and (memq (cpan-dependency-phase dependency) | |
258 | phases) | |
259 | (cpan-dependency-module dependency))) | |
260 | (cpan-release-dependencies release)) | |
d45dc6da | 261 | ((inputs ...) |
a0c2c4b4 EB |
262 | (sort |
263 | (delete-duplicates | |
264 | ;; Listed dependencies may include core modules. Filter those out. | |
265 | (filter-map (match-lambda | |
69f13255 LC |
266 | ("perl" #f) ;implicit dependency |
267 | ((? core-module?) #f) | |
268 | (module | |
269 | (let ((name (guix-name (module->dist-name module)))) | |
270 | (list name | |
271 | (list 'unquote (string->symbol name)))))) | |
a0c2c4b4 EB |
272 | inputs)) |
273 | (lambda args | |
274 | (match args | |
275 | (((a _ ...) (b _ ...)) | |
276 | (string<? a b)))))))) | |
d45dc6da EB |
277 | |
278 | (define (maybe-inputs guix-name inputs) | |
279 | (match inputs | |
280 | (() | |
281 | '()) | |
282 | ((inputs ...) | |
283 | (list (list guix-name | |
284 | (list 'quasiquote inputs)))))) | |
285 | ||
d45dc6da EB |
286 | (let ((tarball (with-store store |
287 | (download-to-store store source-url)))) | |
288 | `(package | |
289 | (name ,(guix-name name)) | |
290 | (version ,version) | |
291 | (source (origin | |
292 | (method url-fetch) | |
293 | (uri (string-append ,@(factorize-uri source-url version))) | |
294 | (sha256 | |
295 | (base32 | |
296 | ,(bytevector->nix-base32-string (file-sha256 tarball)))))) | |
297 | (build-system perl-build-system) | |
298 | ,@(maybe-inputs 'native-inputs | |
66392e47 | 299 | ;; "runtime" may also be needed here. See |
d45dc6da EB |
300 | ;; https://metacpan.org/pod/CPAN::Meta::Spec#Phases, |
301 | ;; which says they are required during building. We | |
302 | ;; have not yet had a need for cross-compiled perl | |
66392e47 | 303 | ;; modules, however, so we leave it out. |
69f13255 | 304 | (convert-inputs '(configure build test))) |
23055424 | 305 | ,@(maybe-inputs 'propagated-inputs |
69f13255 | 306 | (convert-inputs '(runtime))) |
6d176ad3 | 307 | (home-page ,(cpan-home name)) |
69f13255 | 308 | (synopsis ,(cpan-release-abstract release)) |
d45dc6da | 309 | (description fill-in-yourself!) |
69f13255 | 310 | (license ,(string->license (cpan-release-license release)))))) |
d45dc6da EB |
311 | |
312 | (define (cpan->guix-package module-name) | |
313 | "Fetch the metadata for PACKAGE-NAME from metacpan.org, and return the | |
314 | `package' s-expression corresponding to that package, or #f on failure." | |
69f13255 LC |
315 | (let ((release (cpan-fetch (module->name module-name)))) |
316 | (and=> release cpan-module->sexp))) | |
ff55fe55 | 317 | |
00290e73 LC |
318 | (define cpan-package? |
319 | (let ((cpan-rx (make-regexp (string-append "(" | |
320 | "mirror://cpan" "|" | |
321 | "https?://www.cpan.org" "|" | |
322 | "https?://cpan.metacpan.org" | |
323 | ")")))) | |
324 | (url-predicate (cut regexp-exec cpan-rx <>)))) | |
ff55fe55 EB |
325 | |
326 | (define (latest-release package) | |
327 | "Return an <upstream-source> for the latest release of PACKAGE." | |
328 | (match (cpan-fetch (package->upstream-name package)) | |
329 | (#f #f) | |
69f13255 | 330 | (release |
ff55fe55 EB |
331 | (let ((core-inputs |
332 | (match (package-direct-inputs package) | |
333 | (((_ inputs _ ...) ...) | |
334 | (filter-map (match-lambda | |
335 | ((and (? package?) | |
336 | (? cpan-package?) | |
337 | (= package->upstream-name | |
338 | (? core-module? name))) | |
339 | name) | |
340 | (else #f)) | |
341 | inputs))))) | |
342 | ;; Warn about inputs that are part of perl's core | |
343 | (unless (null? core-inputs) | |
344 | (for-each (lambda (module) | |
69daee23 | 345 | (warning (G_ "input '~a' of ~a is in Perl core~%") |
ff55fe55 EB |
346 | module (package-name package))) |
347 | core-inputs))) | |
69f13255 LC |
348 | (let ((version (cpan-release-version release)) |
349 | (url (cpan-source-url release))) | |
ff55fe55 EB |
350 | (upstream-source |
351 | (package (package-name package)) | |
352 | (version version) | |
e956ae16 | 353 | (urls (list url))))))) |
ff55fe55 EB |
354 | |
355 | (define %cpan-updater | |
356 | (upstream-updater | |
357 | (name 'cpan) | |
358 | (description "Updater for CPAN packages") | |
359 | (pred cpan-package?) | |
360 | (latest latest-release))) |