pyrox.dev
1#!/usr/bin/env perl
2
3use utf8;
4use strict;
5use warnings;
6
7use CPAN::Meta();
8use CPANPLUS::Backend();
9use MIME::Base64;
10use Module::CoreList;
11use Getopt::Long::Descriptive qw( describe_options );
12use JSON::PP qw( encode_json );
13use Log::Log4perl qw(:easy);
14use Readonly();
15
16# Readonly hash that maps CPAN style license strings to information
17# necessary to generate a Nixpkgs style license attribute.
18Readonly::Hash my %LICENSE_MAP => (
19
20 # The Perl 5 License (Artistic 1 & GPL 1 or later).
21 perl_5 => {
22 licenses => [qw( artistic1 gpl1Plus )]
23 },
24
25 # GNU Affero General Public License, Version 3.
26 agpl_3 => {
27 licenses => [qw( agpl3Plus )],
28 amb => 1
29 },
30
31 # Apache Software License, Version 1.1.
32 apache_1_1 => {
33 licenses => ["Apache License 1.1"],
34 in_set => 0
35 },
36
37 # Apache License, Version 2.0.
38 apache_2_0 => {
39 licenses => [qw( asl20 )]
40 },
41
42 # Artistic License, (Version 1).
43 artistic_1 => {
44 licenses => [qw( artistic1 )]
45 },
46
47 # Artistic License, Version 2.0.
48 artistic_2 => {
49 licenses => [qw( artistic2 )]
50 },
51
52 # BSD License (three-clause).
53 bsd => {
54 licenses => [qw( bsd3 )],
55 amb => 1
56 },
57
58 # FreeBSD License (two-clause).
59 freebsd => {
60 licenses => [qw( bsd2 )]
61 },
62
63 # GNU Free Documentation License, Version 1.2.
64 gfdl_1_2 => {
65 licenses => [qw( fdl12Plus )]
66 },
67
68 # GNU Free Documentation License, Version 1.3.
69 gfdl_1_3 => {
70 licenses => [qw( fdl13Plus )]
71 },
72
73 # GNU General Public License, Version 1.
74 gpl_1 => {
75 licenses => [qw( gpl1Plus )],
76 amb => 1
77 },
78
79 # GNU General Public License, Version 2. Note, we will interpret
80 # "gpl" alone as GPL v2+.
81 gpl_2 => {
82 licenses => [qw( gpl2Plus )],
83 amb => 1
84 },
85
86 # GNU General Public License, Version 3.
87 gpl_3 => {
88 licenses => [qw( gpl3Plus )],
89 amb => 1
90 },
91
92 # GNU Lesser General Public License, Version 2.1. Note, we will
93 # interpret "gpl" alone as LGPL v2.1+.
94 lgpl_2_1 => {
95 licenses => [qw( lgpl21Plus )],
96 amb => 1
97 },
98
99 # GNU Lesser General Public License, Version 3.0.
100 lgpl_3_0 => {
101 licenses => [qw( lgpl3Plus )],
102 amb => 1
103 },
104
105 # MIT (aka X11) License.
106 mit => {
107 licenses => [qw( mit )]
108 },
109
110 # Mozilla Public License, Version 1.0.
111 mozilla_1_0 => {
112 licenses => [qw( mpl10 )]
113 },
114
115 # Mozilla Public License, Version 1.1.
116 mozilla_1_1 => {
117 licenses => [qw( mpl11 )]
118 },
119
120 # OpenSSL License.
121 openssl => {
122 licenses => [qw( openssl )]
123 },
124
125 # Q Public License, Version 1.0.
126 qpl_1_0 => {
127 licenses => [qw( qpl )]
128 },
129
130 # Original SSLeay License.
131 ssleay => {
132 licenses => ["Original SSLeay License"],
133 in_set => 0
134 },
135
136 # Sun Internet Standards Source License (SISSL).
137 sun => {
138 licenses => ["Sun Industry Standards Source License v1.1"],
139 in_set => 0
140 },
141
142 # zlib License.
143 zlib => {
144 licenses => [qw( zlib )]
145 },
146
147 # Other Open Source Initiative (OSI) approved license.
148 open_source => {
149 licenses => [qw( free )],
150 amb => 1
151 },
152
153 # Requires special permission from copyright holder.
154 restricted => {
155 licenses => [qw( unfree )],
156 amb => 1
157 },
158
159 # Not an OSI approved license, but not restricted. Note, we
160 # currently map this to unfreeRedistributable, which is a
161 # conservative choice.
162 unrestricted => {
163 licenses => [qw( unfreeRedistributable )],
164 amb => 1
165 },
166
167 # License not provided in metadata.
168 unknown => {
169 licenses => [],
170 amb => 1
171 }
172);
173
174sub handle_opts {
175 my ( $opt, $usage ) = describe_options(
176 'usage: $0 %o MODULE',
177 [ 'maintainer|m=s', 'the package maintainer' ],
178 [ 'debug|d', 'enable debug output' ],
179 [ 'help', 'print usage message and exit' ]
180 );
181
182 if ( $opt->help ) {
183 print $usage->text;
184 exit;
185 }
186
187 my $module_name = $ARGV[0];
188
189 if ( !defined $module_name ) {
190 print STDERR "Missing module name\n";
191 print STDERR $usage->text;
192 exit 1;
193 }
194
195 return ( $opt, $module_name );
196}
197
198# Takes a Perl package attribute name and returns 1 if the name cannot
199# be referred to as a bareword. This typically happens if the package
200# name is a reserved Nix keyword.
201sub is_reserved {
202 my ($pkg) = @_;
203
204 return $pkg =~ /^(?: assert |
205 else |
206 if |
207 import |
208 in |
209 inherit |
210 let |
211 rec |
212 then |
213 while |
214 with )$/x;
215}
216
217sub pkg_to_attr {
218 my ($module) = @_;
219 my $attr_name = $module->package_name;
220 if ( $attr_name eq "libwww-perl" ) {
221 return "LWP";
222 }
223 else {
224 $attr_name =~ s/-//g;
225 return $attr_name;
226 }
227}
228
229sub get_pkg_name {
230 my ($module) = @_;
231 return ( $module->package_name, $module->package_version =~ s/^v(\d)/$1/r );
232}
233
234sub read_meta {
235 my ($pkg_path) = @_;
236
237 my $yaml_path = "$pkg_path/META.yml";
238 my $json_path = "$pkg_path/META.json";
239 my $meta;
240
241 if ( -r $json_path ) {
242 $meta = CPAN::Meta->load_file($json_path);
243 }
244 elsif ( -r $yaml_path ) {
245 $meta = CPAN::Meta->load_file($yaml_path);
246 }
247 else {
248 WARN("package has no META.yml or META.json");
249 }
250
251 return $meta;
252}
253
254# Map a module to the attribute corresponding to its package
255# (e.g. HTML::HeadParser will be mapped to HTMLParser, because that
256# module is in the HTML-Parser package).
257sub module_to_pkg {
258 my ( $cb, $module_name ) = @_;
259 my @modules = $cb->search( type => "name", allow => [$module_name] );
260 if ( scalar @modules == 0 ) {
261
262 # Fallback.
263 $module_name =~ s/:://g;
264 return $module_name;
265 }
266 my $module = $modules[0];
267 my $attr_name = pkg_to_attr($module);
268 DEBUG("mapped dep $module_name to $attr_name");
269 return $attr_name;
270}
271
272sub get_deps {
273 my ( $cb, $meta, $type ) = @_;
274
275 return if !defined $meta;
276
277 my $prereqs = $meta->effective_prereqs;
278 my $deps = $prereqs->requirements_for( $type, "requires" );
279 my @res;
280 foreach my $n ( $deps->required_modules ) {
281 next if $n eq "perl";
282
283 my @core = Module::CoreList->find_modules(qr/^$n$/);
284 next if (@core);
285
286 my $pkg = module_to_pkg( $cb, $n );
287
288 # If the package name is reserved then we need to refer to it
289 # through the "self" variable.
290 $pkg = "self.\"$pkg\"" if is_reserved($pkg);
291
292 push @res, $pkg;
293 }
294 return @res;
295}
296
297sub uniq {
298 return keys %{ { map { $_ => 1 } @_ } };
299}
300
301sub render_license {
302 my ($cpan_license) = @_;
303
304 return if !defined $cpan_license;
305
306 my $licenses;
307
308 # If the license is ambiguous then we'll print an extra warning.
309 # For example, "gpl_2" is ambiguous since it may refer to exactly
310 # "GPL v2" or to "GPL v2 or later".
311 my $amb = 0;
312
313 # Whether the license is available inside `lib.licenses`.
314 my $in_set = 1;
315
316 my $nix_license = $LICENSE_MAP{$cpan_license};
317 if ( !$nix_license ) {
318 WARN("Unknown license: $cpan_license");
319 $licenses = [$cpan_license];
320 $in_set = 0;
321 }
322 else {
323 $licenses = $nix_license->{licenses};
324 $amb = $nix_license->{amb};
325 $in_set = !$nix_license->{in_set};
326 }
327
328 my $license_line;
329
330 if ( @$licenses == 0 ) {
331
332 # Avoid defining the license line.
333 }
334 elsif ($in_set) {
335 my $lic = 'lib.licenses';
336 if ( @$licenses == 1 ) {
337 $license_line = "$lic.$licenses->[0]";
338 }
339 else {
340 $license_line = "with $lic; [ " . join( ' ', @$licenses ) . " ]";
341 }
342 }
343 else {
344 if ( @$licenses == 1 ) {
345 $license_line = $licenses->[0];
346 }
347 else {
348 $license_line = '[ ' . join( ' ', @$licenses ) . ' ]';
349 }
350 }
351
352 INFO("license: $cpan_license");
353 WARN("License '$cpan_license' is ambiguous, please verify") if $amb;
354
355 return $license_line;
356}
357
358sub sha256_to_sri {
359 my ($sha256) = @_;
360 return "sha256-" . encode_base64(pack("H*", $sha256), '');
361}
362
363my ( $opt, $module_name ) = handle_opts();
364
365Log::Log4perl->easy_init(
366 {
367 level => $opt->debug ? $DEBUG : $INFO,
368 layout => '%m%n'
369 }
370);
371
372my $cb = CPANPLUS::Backend->new;
373
374my @modules = $cb->search( type => "name", allow => [$module_name] );
375die "module $module_name not found\n" if scalar @modules == 0;
376die "multiple packages that match module $module_name\n" if scalar @modules > 1;
377my $module = $modules[0];
378
379my ($pkg_name, $pkg_version) = get_pkg_name $module;
380my $attr_name = pkg_to_attr $module;
381
382INFO( "attribute name: ", $attr_name );
383INFO( "module: ", $module->module );
384INFO( "version: ", $module->version );
385INFO( "package: ", $module->package, " (", "$pkg_name-$pkg_version", ", ", $attr_name, ")" );
386INFO( "path: ", $module->path );
387
388my $tar_path = $module->fetch();
389my $sri_hash = sha256_to_sri($module->status->checksum_value);
390INFO( "downloaded to: ", $tar_path );
391INFO( "hash: ", $sri_hash );
392
393my $pkg_path = $module->extract();
394INFO( "unpacked to: ", $pkg_path );
395
396my $meta = read_meta($pkg_path);
397
398DEBUG( "metadata: ", encode_json( $meta->as_struct ) ) if defined $meta;
399
400my @runtime_deps = sort( uniq( get_deps( $cb, $meta, "runtime" ) ) );
401INFO("runtime deps: @runtime_deps");
402
403my @build_deps = sort( uniq(
404 get_deps( $cb, $meta, "configure" ),
405 get_deps( $cb, $meta, "build" ),
406 get_deps( $cb, $meta, "test" )
407) );
408
409# Filter out runtime dependencies since those are already handled.
410my %in_runtime_deps = map { $_ => 1 } @runtime_deps;
411@build_deps = grep { not $in_runtime_deps{$_} } @build_deps;
412
413INFO("build deps: @build_deps");
414
415my $homepage = $meta ? $meta->resources->{homepage} : undef;
416INFO("homepage: $homepage") if defined $homepage;
417
418my $description = $meta ? $meta->abstract : undef;
419if ( defined $description ) {
420 $description = uc( substr( $description, 0, 1 ) )
421 . substr( $description, 1 ); # capitalise first letter
422 $description =~ s/\.$//; # remove period at the end
423 $description =~ s/\s*$//;
424 $description =~ s/^\s*//;
425 $description =~ s/\n+/ /; # Replace new lines by space.
426 INFO("description: $description");
427}
428
429#print(Data::Dumper::Dumper($meta->licenses) . "\n");
430my $license = $meta ? render_license( $meta->licenses ) : undef;
431
432INFO( "RSS feed: https://metacpan.org/feed/distribution/",
433 $module->package_name );
434
435my $build_fun = -e "$pkg_path/Build.PL"
436 && !-e "$pkg_path/Makefile.PL" ? "buildPerlModule" : "buildPerlPackage";
437
438print STDERR "===\n";
439
440print <<EOF;
441 ${\(is_reserved($attr_name) ? "\"$attr_name\"" : $attr_name)} = $build_fun {
442 pname = "$pkg_name";
443 version = "$pkg_version";
444 src = fetchurl {
445 url = "mirror://cpan/${\$module->path}/${\$module->package}";
446 hash = "$sri_hash";
447 };
448EOF
449print <<EOF if scalar @build_deps > 0;
450 buildInputs = [ @build_deps ];
451EOF
452print <<EOF if scalar @runtime_deps > 0;
453 propagatedBuildInputs = [ @runtime_deps ];
454EOF
455print <<EOF;
456 meta = {
457EOF
458print <<EOF if defined $homepage;
459 homepage = "$homepage";
460EOF
461print <<EOF if defined $description && $description ne "Unknown";
462 description = "$description";
463EOF
464print <<EOF if defined $license;
465 license = $license;
466EOF
467print <<EOF if $opt->maintainer;
468 maintainers = [ maintainers.${\$opt->maintainer} ];
469EOF
470print <<EOF;
471 };
472 };
473EOF