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> |
d45dc6da EB |
4 | ;;; |
5 | ;;; This file is part of GNU Guix. | |
6 | ;;; | |
7 | ;;; GNU Guix is free software; you can redistribute it and/or modify it | |
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 | ;;; | |
12 | ;;; GNU Guix is distributed in the hope that it will be useful, but | |
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 | |
18 | ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. | |
19 | ||
20 | (define-module (guix import cpan) | |
21 | #:use-module (ice-9 match) | |
22 | #:use-module (ice-9 regex) | |
66392e47 EB |
23 | #:use-module ((ice-9 popen) #:select (open-pipe* close-pipe)) |
24 | #:use-module ((ice-9 rdelim) #:select (read-line)) | |
d45dc6da EB |
25 | #:use-module (srfi srfi-1) |
26 | #:use-module (json) | |
27 | #:use-module (guix hash) | |
28 | #:use-module (guix store) | |
29 | #:use-module (guix base32) | |
30 | #:use-module ((guix download) #:select (download-to-store)) | |
31 | #:use-module (guix import utils) | |
32 | #:use-module (guix import json) | |
66392e47 EB |
33 | #:use-module (guix packages) |
34 | #:use-module (guix derivations) | |
35 | #:use-module (gnu packages perl) | |
d45dc6da EB |
36 | #:export (cpan->guix-package)) |
37 | ||
38 | ;;; Commentary: | |
39 | ;;; | |
40 | ;;; Generate a package declaration template for the latest version of a CPAN | |
41 | ;;; module, using meta-data from metacpan.org. | |
42 | ;;; | |
43 | ;;; Code: | |
44 | ||
45 | (define string->license | |
46 | (match-lambda | |
47 | ;; List of valid values from https://metacpan.org/pod/CPAN::Meta::Spec. | |
48 | ;; Some licenses are excluded based on their absense from (guix licenses). | |
49 | ("agpl_3" 'agpl3) | |
50 | ;; apache_1_1 | |
51 | ("apache_2_0" 'asl2.0) | |
52 | ;; artistic_1_0 | |
2491d589 | 53 | ("artistic_2_0" 'artistic2.0) |
d45dc6da EB |
54 | ("bsd" 'bsd-3) |
55 | ("freebsd" 'bsd-2) | |
56 | ;; gfdl_1_2 | |
57 | ("gfdl_1_3" 'fdl1.3+) | |
58 | ("gpl_1" 'gpl1) | |
59 | ("gpl_2" 'gpl2) | |
60 | ("gpl_3" 'gpl3) | |
61 | ("lgpl_2_1" 'lgpl2.1) | |
62 | ("lgpl_3_0" 'lgpl3) | |
63 | ("mit" 'x11) | |
64 | ;; mozilla_1_0 | |
65 | ("mozilla_1_1" 'mpl1.1) | |
66 | ("openssl" 'openssl) | |
2491d589 | 67 | ("perl_5" '(package-license perl)) ;GPL1+ and Artistic 1 |
d45dc6da EB |
68 | ("qpl_1_0" 'qpl) |
69 | ;; ssleay | |
70 | ;; sun | |
71 | ("zlib" 'zlib) | |
72 | ((x) (string->license x)) | |
73 | ((lst ...) `(list ,@(map string->license lst))) | |
74 | (_ #f))) | |
75 | ||
76 | (define (module->name module) | |
77 | "Transform a 'module' name into a 'release' name" | |
78 | (regexp-substitute/global #f "::" module 'pre "-" 'post)) | |
79 | ||
66392e47 EB |
80 | (define (module->dist-name module) |
81 | "Return the base distribution module for a given module. E.g. the 'ok' | |
82 | module is distributed with 'Test::Simple', so (module->dist-name \"ok\") would | |
83 | return \"Test-Simple\"" | |
84 | (assoc-ref (json-fetch (string-append "http://api.metacpan.org/module/" | |
85 | module)) | |
86 | "distribution")) | |
87 | ||
d45dc6da EB |
88 | (define (cpan-fetch module) |
89 | "Return an alist representation of the CPAN metadata for the perl module MODULE, | |
90 | or #f on failure. MODULE should be e.g. \"Test::Script\"" | |
91 | ;; This API always returns the latest release of the module. | |
92 | (json-fetch (string-append "http://api.metacpan.org/release/" | |
93 | ;; XXX: The 'release' api requires the "release" | |
94 | ;; name of the package. This substitution seems | |
95 | ;; reasonably consistent across packages. | |
96 | (module->name module)))) | |
97 | ||
98 | (define (cpan-home name) | |
99 | (string-append "http://search.cpan.org/dist/" name)) | |
100 | ||
66392e47 | 101 | (define %corelist |
431b28d9 MW |
102 | (delay |
103 | (let* ((perl (with-store store | |
104 | (derivation->output-path | |
105 | (package-derivation store perl)))) | |
106 | (core (string-append perl "/bin/corelist"))) | |
107 | (and (access? core X_OK) | |
108 | core)))) | |
66392e47 | 109 | |
d45dc6da EB |
110 | (define (cpan-module->sexp meta) |
111 | "Return the `package' s-expression for a CPAN module from the metadata in | |
112 | META." | |
113 | (define name | |
114 | (assoc-ref meta "distribution")) | |
115 | ||
116 | (define (guix-name name) | |
117 | (if (string-prefix? "perl-" name) | |
118 | (string-downcase name) | |
119 | (string-append "perl-" (string-downcase name)))) | |
120 | ||
121 | (define version | |
122 | (assoc-ref meta "version")) | |
123 | ||
66392e47 | 124 | (define (core-module? name) |
431b28d9 | 125 | (and (force %corelist) |
66392e47 | 126 | (parameterize ((current-error-port (%make-void-port "w"))) |
431b28d9 | 127 | (let* ((corelist (open-pipe* OPEN_READ (force %corelist) name))) |
66392e47 EB |
128 | (let loop ((line (read-line corelist))) |
129 | (if (eof-object? line) | |
130 | (begin (close-pipe corelist) #f) | |
131 | (if (string-contains line "first released with perl") | |
132 | (begin (close-pipe corelist) #t) | |
133 | (loop (read-line corelist))))))))) | |
134 | ||
d45dc6da EB |
135 | (define (convert-inputs phases) |
136 | ;; Convert phase dependencies into a list of name/variable pairs. | |
137 | (match (flatten | |
138 | (map (lambda (ph) | |
139 | (filter-map (lambda (t) | |
140 | (assoc-ref* meta "metadata" "prereqs" ph t)) | |
141 | '("requires" "recommends" "suggests"))) | |
142 | phases)) | |
143 | (#f | |
144 | '()) | |
145 | ((inputs ...) | |
a0c2c4b4 EB |
146 | (sort |
147 | (delete-duplicates | |
148 | ;; Listed dependencies may include core modules. Filter those out. | |
149 | (filter-map (match-lambda | |
150 | (("perl" . _) ;implicit dependency | |
151 | #f) | |
152 | ((module . _) | |
153 | (and (not (core-module? module)) | |
154 | (let ((name (guix-name (module->dist-name module)))) | |
155 | (list name | |
156 | (list 'unquote (string->symbol name))))))) | |
157 | inputs)) | |
158 | (lambda args | |
159 | (match args | |
160 | (((a _ ...) (b _ ...)) | |
161 | (string<? a b)))))))) | |
d45dc6da EB |
162 | |
163 | (define (maybe-inputs guix-name inputs) | |
164 | (match inputs | |
165 | (() | |
166 | '()) | |
167 | ((inputs ...) | |
168 | (list (list guix-name | |
169 | (list 'quasiquote inputs)))))) | |
170 | ||
171 | (define source-url | |
e92a4ad9 EB |
172 | (regexp-substitute/global #f "http://cpan.metacpan.org" |
173 | (assoc-ref meta "download_url") | |
174 | 'pre "mirror://cpan" 'post)) | |
d45dc6da EB |
175 | |
176 | (let ((tarball (with-store store | |
177 | (download-to-store store source-url)))) | |
178 | `(package | |
179 | (name ,(guix-name name)) | |
180 | (version ,version) | |
181 | (source (origin | |
182 | (method url-fetch) | |
183 | (uri (string-append ,@(factorize-uri source-url version))) | |
184 | (sha256 | |
185 | (base32 | |
186 | ,(bytevector->nix-base32-string (file-sha256 tarball)))))) | |
187 | (build-system perl-build-system) | |
188 | ,@(maybe-inputs 'native-inputs | |
66392e47 | 189 | ;; "runtime" may also be needed here. See |
d45dc6da EB |
190 | ;; https://metacpan.org/pod/CPAN::Meta::Spec#Phases, |
191 | ;; which says they are required during building. We | |
192 | ;; have not yet had a need for cross-compiled perl | |
66392e47 EB |
193 | ;; modules, however, so we leave it out. |
194 | (convert-inputs '("configure" "build" "test"))) | |
d45dc6da EB |
195 | ,@(maybe-inputs 'inputs |
196 | (convert-inputs '("runtime"))) | |
197 | (home-page ,(string-append "http://search.cpan.org/dist/" name)) | |
198 | (synopsis ,(assoc-ref meta "abstract")) | |
199 | (description fill-in-yourself!) | |
200 | (license ,(string->license (assoc-ref meta "license")))))) | |
201 | ||
202 | (define (cpan->guix-package module-name) | |
203 | "Fetch the metadata for PACKAGE-NAME from metacpan.org, and return the | |
204 | `package' s-expression corresponding to that package, or #f on failure." | |
205 | (let ((module-meta (cpan-fetch module-name))) | |
206 | (and=> module-meta cpan-module->sexp))) |