maintainers/scripts/nix-generate-from-cpan.pl

   1 #!/usr/bin/env perl
   2
   3 use utf8;
   4 use strict;
   5 use warnings;
   6
   7 use CPAN::Meta();
   8 use CPANPLUS::Backend();
   9 use MIME::Base64;
  10 use Module::CoreList;
  11 use Getopt::Long::Descriptive qw( describe_options );
  12 use JSON::PP qw( encode_json );
  13 use Log::Log4perl qw(:easy);
  14 use Readonly();
  15
  16 # Readonly hash that maps CPAN style license strings to information
  17 # necessary to generate a Nixpkgs style license attribute.
  18 Readonly::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
 174 sub 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.
 201 sub 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
 217 sub 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
 229 sub get_pkg_name {
 230     my ($module) = @_;
 231     return ( $module->package_name, $module->package_version =~ s/^v(\d)/$1/r );
 232 }
 233
 234 sub 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).
 257 sub 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
 272 sub 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
 297 sub uniq {
 298     return keys %{ { map { $_ => 1 } @_ } };
 299 }
 300
 301 sub 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
 358 sub sha256_to_sri {
 359     my ($sha256) = @_;
 360     return "sha256-" . encode_base64(pack("H*", $sha256), '');
 361 }
 362
 363 my ( $opt, $module_name ) = handle_opts();
 364
 365 Log::Log4perl->easy_init(
 366     {
 367         level => $opt->debug ? $DEBUG : $INFO,
 368         layout => '%m%n'
 369     }
 370 );
 371
 372 my $cb = CPANPLUS::Backend->new;
 373
 374 my @modules = $cb->search( type => "name", allow => [$module_name] );
 375 die "module $module_name not found\n" if scalar @modules == 0;
 376 die "multiple packages that match module $module_name\n" if scalar @modules > 1;
 377 my $module = $modules[0];
 378
 379 my ($pkg_name, $pkg_version) = get_pkg_name $module;
 380 my $attr_name = pkg_to_attr $module;
 381
 382 INFO( "attribute name: ", $attr_name );
 383 INFO( "module: ",         $module->module );
 384 INFO( "version: ",        $module->version );
 385 INFO( "package: ", $module->package, " (", "$pkg_name-$pkg_version", ", ", $attr_name, ")" );
 386 INFO( "path: ",    $module->path );
 387
 388 my $tar_path = $module->fetch();
 389 my $sri_hash = sha256_to_sri($module->status->checksum_value);
 390 INFO( "downloaded to: ", $tar_path );
 391 INFO( "hash: ", $sri_hash );
 392
 393 my $pkg_path = $module->extract();
 394 INFO( "unpacked to: ", $pkg_path );
 395
 396 my $meta = read_meta($pkg_path);
 397
 398 DEBUG( "metadata: ", encode_json( $meta->as_struct ) ) if defined $meta;
 399
 400 my @runtime_deps = sort( uniq( get_deps( $cb, $meta, "runtime" ) ) );
 401 INFO("runtime deps: @runtime_deps");
 402
 403 my @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.
 410 my %in_runtime_deps = map { $_ => 1 } @runtime_deps;
 411 @build_deps = grep { not $in_runtime_deps{$_} } @build_deps;
 412
 413 INFO("build deps: @build_deps");
 414
 415 my $homepage = $meta ? $meta->resources->{homepage} : undef;
 416 INFO("homepage: $homepage") if defined $homepage;
 417
 418 my $description = $meta ? $meta->abstract : undef;
 419 if ( 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");
 430 my $license = $meta ? render_license( $meta->licenses ) : undef;
 431
 432 INFO( "RSS feed: https://metacpan.org/feed/distribution/",
 433     $module->package_name );
 434
 435 my $build_fun = -e "$pkg_path/Build.PL"
 436   && !-e "$pkg_path/Makefile.PL" ? "buildPerlModule" : "buildPerlPackage";
 437
 438 print STDERR "===\n";
 439
 440 print <<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     };
 448 EOF
 449 print <<EOF if scalar @build_deps > 0;
 450     buildInputs = [ @build_deps ];
 451 EOF
 452 print <<EOF if scalar @runtime_deps > 0;
 453     propagatedBuildInputs = [ @runtime_deps ];
 454 EOF
 455 print <<EOF;
 456     meta = {
 457 EOF
 458 print <<EOF if defined $homepage;
 459       homepage = "$homepage";
 460 EOF
 461 print <<EOF if defined $description && $description ne "Unknown";
 462       description = "$description";
 463 EOF
 464 print <<EOF if defined $license;
 465       license = $license;
 466 EOF
 467 print <<EOF if $opt->maintainer;
 468       maintainers = [ maintainers.${\$opt->maintainer} ];
 469 EOF
 470 print <<EOF;
 471     };
 472   };
 473 EOF