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