media-scraper

   1 #!/usr/bin/perl -w
   2 use strict;
   3
   4 use POSIX;
   5 use IO::Handle;
   6 use Carp;
   7 use TOML::Parser;
   8 use Data::Dumper;
   9 use Time::HiRes;
  10 use Digest::MD5 qw(md5_hex);
  11 use File::Compare;
  12
  13 our $max_rate = 2; # per second
  14
  15 # todo: allow to read size details out of svg (maybe in daemon-otter?)
  16 # todo: allow scraper method none to handle item vs filename mismatch
  17
  18 #print Dumper($libinfo);
  19
  20 open DEBUG, ">&STDERR" or die $!;
  21 autoflush DEBUG 1;
  22
  23 sub run_curl {
  24   my ($datalog, $output, $url, @xopts) = @_;
  25   my @curl = (qw(curl -Ssf -L --proto-redir -all), @xopts);
  26   push @curl, '-o', "$output.tmp", $url;
  27   our $last_curl;
  28   $last_curl //= 0.;
  29   my $now = Time::HiRes::time;
  30   my $delay = 1./$max_rate - ($now - $last_curl);
  31   Time::HiRes::sleep $delay if $delay > 0;
  32   $last_curl = $now;
  33 #  print DEBUG "+ @curl\n";
  34   $!=$?=0; my $r = system @curl; die "curl failed ($? $!): @curl" if $r;
  35   my $logtime = strftime "%F %T UTC", gmtime time;
  36   print $datalog "$logtime: downloaded into $output from $url\n"
  37     or die $!;
  38   rename "$output.tmp", "$output" or die "install $output: $!";
  39 }
  40
  41 sub cfg_lookup_1 ($@) {
  42   my ($dict, @keys) = @_;
  43   #print DEBUG "cfg_lookup_1 ".Dumper($dict, \@keys);
  44   foreach my $k (@keys) {
  45     confess unless ref $dict eq 'HASH';
  46     $dict = $dict->{$k};
  47     return undef if !defined $dict;
  48   }
  49   #print DEBUG "cfg_lookup_1 (@keys) => $dict\n";
  50   return $dict;
  51 }
  52
  53 sub mk_cfg_lookup ($$@) {
  54   my ($groups, $thisgroup, @keysprefix) = @_;
  55   #print DEBUG "mk_cfg_lookup >@keysprefix< ".Dumper($thisgroup);
  56   return sub {
  57     #print DEBUG "from mk_cfg_lookup >@keysprefix< >@_<\n";
  58     my $cgroup = $thisgroup;
  59     for (;;) {
  60       my $got = cfg_lookup_1($cgroup, @keysprefix, @_);
  61       return $got if defined $got;
  62       my $inherit = cfg_lookup_1($cgroup, qw(inherit));
  63       return undef unless $inherit;
  64       $cgroup = $groups->{$inherit};
  65       confess "$inherit".Dumper($groups,$inherit)."?" unless $cgroup;
  66     }
  67   }
  68 }
  69
  70 sub cfg_affixes ($$$) {
  71   my ($cfg, $keybase, $middle) = @_;
  72   return
  73     ($cfg->("${keybase}_prefix") // '')
  74     .$middle
  75     .($cfg->("${keybase}_suffix") // '');
  76 }
  77
  78 sub method_none { return sub { } }
  79 sub methodlic_none { undef }
  80 sub methodisoffline_none { 0 }
  81
  82 sub methodlic_wikimedia ($) {
  83   my ($scraper) = @_;
  84   my $spdx = ${ \ $scraper->('spdx') };
  85   return <<END.($spdx =~ m{/} ? <<END : '').<<END;
  86 These files were all obtained from
  87     ${ \ $scraper->('site-title') }
  88
  89 They are all available under at least, and distributed here under,
  90     $spdx
  91 END
  92 (deepending on the file - consult the source file for details)
  93 END
  94 as well as possibly other licences.  There is NO WARRANTY.
  95
  96 See <file>.download-log for the original URL and download timestamp.
  97 The wikitext of the File: page on the wiki is in <file>.wikitext, and
  98 contains the authorship and derivation information, as well as
  99 information about any alternative licence terms.
 100
 101 [ This LICENCE file was generated by media-scraper and should not
 102   be manually edited ]
 103 END
 104 }
 105
 106 sub method_wikimedia ($$$) {
 107   my ($scraper, $methname) = @_;
 108   #print DEBUG "METHOD $methname...\n";
 109   return sub {
 110     my ($lbase, $ldest, $rstem) = @_;
 111     my $rfilename = cfg_affixes $scraper, 'filename', $rstem;
 112     my $url = cfg_affixes $scraper, 'url', $rfilename;
 113     my $wt = "$lbase.wikitext";
 114     #print DEBUG "rfilename=$rfilename url=$url .\n";
 115     my $datalog = new IO::File "$lbase.download-log", '>>' or die $!;
 116     print $datalog "\n" or die $!;
 117     run_curl $datalog, $wt, $url;
 118     open WT, "$wt" or die $!;
 119     my (@lics) = @{ $scraper->('licences') };
 120     s/\W/\\$&/g foreach @lics;
 121     s/\\\*$/.*/g foreach @lics;
 122     my $lic1_re = '(?:'.(join '|', @lics).')';
 123     my $ok;
 124     while (<WT>) {
 125       s/\s+$//;
 126       if (m{^ \{\{ ($lic1_re) \}\} $}xi ||
 127           m{^ \{\{ self\| (?:[^{}]*\|)? ($lic1_re) (?:\|[^{}]*)? \}\} $}xi) {
 128         print "licence=$1 ";
 129         $ok = 1;
 130         last;
 131       }
 132     }
 133     if (!$ok) {
 134       die "\nfile $wt from $url no appropriate licence $lic1_re";
 135     }
 136     my $hash_prefix = '';
 137     if ($scraper->('data_url_hashprefix')) {
 138       # https://www.mediawiki.org/wiki/Special:MyLanguage/Manual:$wgHashedUploadDirectory
 139       md5_hex($rfilename) =~ m{^((.).)} or die;
 140       $hash_prefix .= "$2/$1/";
 141     }
 142     my $data_url = cfg_affixes $scraper, 'data_url', $hash_prefix.$rfilename;
 143     run_curl $datalog, $ldest, $data_url;
 144     close $datalog or die $!;
 145   };
 146 }
 147
 148 sub methodisoffline_wikimedia { 0 }
 149
 150 sub method_cards_oxymoron {
 151   my ($scraper, $methname) = @_;
 152   return sub {
 153     my ($lbase, $ldest, $rstem) = @_;
 154     my $lgif = $lbase;
 155     $lgif =~ m{/card-oxymoron-(\w+)-(\w+)$} or die "$lbase ?";
 156     my $basename = $`;
 157     $lgif = "$basename/cards/src/\l$1$2.gif";
 158
 159     if (stat $lgif) {
 160     } elsif ($! != ENOENT) {
 161       die "$lgif $!";
 162     } else {
 163       print STDERR "\nbuilding $basename...\n";
 164       $!=$?=0; system "$basename/build" and die "$! $?";
 165     }
 166     $!=$?=0; system qw(convert), $lgif, $ldest and die "$! $?";
 167   }
 168 }
 169 sub methodlic_cards_oxymoron { undef }
 170 sub methodisoffline_cards_oxymoron ($$) { 1 }
 171
 172 our $offline;
 173
 174 while (@ARGV && $ARGV[0] =~ m/^-/) {
 175   $_ = shift @ARGV;
 176   last if m/^-$/;
 177   if (m/^--offline$/) {
 178     $offline = 1;
 179   } else {
 180     die "bad option: \`$_'";
 181   }
 182 }
 183
 184 my $input = $ARGV[0] // die;
 185 $input =~ m/\.toml$/ or die "$input ?";
 186 my $basename = $`;
 187 mkdir $basename or $!==EEXIST or die "mkdir $basename: $!";
 188
 189 my $parser = TOML::Parser->new();
 190 my $libinfo = $parser->parse_file($input);
 191 my $groups = $libinfo->{group};
 192 my $scraper = sub { $libinfo->{scraper}{$_[0]} };
 193 my $method = $scraper->('method');
 194 $method =~ s/-/_/g;
 195 my $method_fn = ${*::}{"method_$method"};
 196
 197 my $methodlic_fn = ${*::}{"methodlic_$method"};
 198 my $licpath = "$basename/LICENCE";
 199
 200 my $methodisoffline_fn = ${*::}{"methodisoffline_$method"};
 201
 202 my $method_lictext = $methodlic_fn->($scraper);
 203 if (defined $method_lictext) {
 204   my $licfile = new IO::File "$licpath.tmp", '>' or die $!;
 205
 206   print $licfile <<END, $method_lictext, <<END or die $!;
 207 SPDX-License-Identifier: ${ \ $scraper->('spdx') }
 208 (applies to the contents of this directory unless otherwise stated)
 209
 210 END
 211
 212 The download was done by media-scraper, controlled by $input.
 213 END
 214   close $licfile or die $!;
 215 }
 216
 217 my $makepath = "$basename/files.make";
 218 my $makefile = new IO::File "$makepath.tmp", '>' or die $!;
 219
 220 foreach my $groupname (sort keys %$groups) {
 221   my $group_dict = $groups->{$groupname};
 222   my $gcfg = mk_cfg_lookup($groups, $group_dict);
 223   my $method_impl = $method_fn->($scraper, $method);
 224   foreach (split(/\n/, $gcfg->('files'))) {
 225     s/^\s+//;
 226     next if m/^\#/ || m/^$/ || m/^\:/;
 227     m/^(\S+)\s+(\S+)/ or die "bad line in files: \`$_'";
 228     my $lministem = $1;
 229     my $rministem = $2;
 230
 231     my $lstem = cfg_affixes $gcfg, 'item', $lministem;
 232     my $rstem = cfg_affixes $gcfg, 'stem', $rministem;
 233     my $lbase = "$basename/$lstem";
 234     my $lupstream = "$lbase.svg";
 235     my $lprocessed = "$lbase.usvg";
 236
 237     print DEBUG "file $lstem ";
 238
 239     my $process_colour = sub ($$) {
 240       my ($linput, $lprocessed) = @_;
 241       print $makefile <<END or die $!;
 242 LIBRARY_FILES += $lprocessed
 243 $lprocessed: $linput $licpath $input
 244         \$(LIBRARY_PROCESS_SVG)
 245 END
 246     };
 247
 248     my $process_colours = sub {
 249       my $colours = $gcfg->('colours');
 250       if (!keys %$colours) {
 251         $process_colour->($lupstream, $lprocessed, "");
 252         return;
 253       }
 254       foreach my $colour (sort keys %$colours) {
 255         my $cspec = $colours->{$colour};
 256         my $abbrev = $cspec->{abbrev} or confess;
 257         my $ncoloured = $lupstream;
 258         $ncoloured =~ s/\.svg$/.coloured$&/;
 259         my $outfile  = $lprocessed;
 260         $ncoloured =~ s/_c/$abbrev/ or confess "$outfile ?";
 261         $outfile  =~ s/_c/$abbrev/ or confess "$outfile ?";
 262         my $coloured = $lupstream;
 263
 264         my $ci = 0;
 265         my $cfp;
 266         my $emitmap = sub {
 267           my ($from, $to) = @_;
 268           confess if $from =~ m/\W/ || $to =~ m/\W/;
 269
 270           $coloured = $ncoloured;
 271           if (!defined $cfp) {
 272             $cfp ="\$@.$ci.tmp";
 273             print $makefile <<END or die $!;
 274 LIBRARY_CLEAN += $ncoloured
 275 $ncoloured: $lupstream \$(MAKEFILE_DEP) \$(USVG_DEP) $makepath
 276         \$(USVG_CMD) -c - <\$< >$cfp
 277 END
 278           }
 279           $ci++;
 280           my $nfp = "\$@.$ci.tmp";
 281           print $makefile <<END or die $!;
 282         \$(RECOLOUR_SVG) -f '$from' -t '$to' $cfp >$nfp
 283 END
 284           $cfp = $nfp;
 285         };
 286
 287         my %map = %{ $cspec->{map} // { } };
 288         while (keys %map) {
 289           my $from = (sort keys %map)[0];
 290           my @maybe_cycle = ();
 291           my $cycle;
 292           for (;;) {
 293             push @maybe_cycle, $from;
 294             my $to = $map{$from};
 295             if (!exists $map{$to}) {
 296               last;
 297             }
 298             $from = $to;
 299             if (grep { $_ eq $to } @maybe_cycle) {
 300               $cycle = $to;
 301               last;
 302             }
 303           }
 304           my $emit_most = sub ($) {
 305             my ($end) = @_;
 306             $end //= $#maybe_cycle;
 307             foreach my $i (@maybe_cycle[0..$end]) {
 308               $emitmap->($i, $map{$i});
 309             }
 310           };
 311           if (defined $cycle) {
 312             my $temp = 'abcbfb'; # chosen at random
 313             my $aside = $maybe_cycle[-1];
 314             $emitmap->($aside, $temp);
 315             $emit_most->($#maybe_cycle-1);
 316             $emitmap->($temp, $map{$aside});
 317             print $makefile <<END or die $!;
 318 # cycle: @maybe_cycle
 319 END
 320           } else {
 321             $emit_most->();
 322           }
 323           delete $map{$_} foreach @maybe_cycle;
 324         }
 325         if ($ci) {
 326           # inkscape extensions have a tendency to write an empty
 327           # file when they don't like their input or arguments
 328           print $makefile <<END or die $!;
 329         test -s $cfp
 330         mv -f $cfp \$@
 331 END
 332         }
 333
 334         $process_colour->($coloured, $outfile);
 335       }
 336     };
 337
 338     $process_colours->();
 339
 340     if (! $methodisoffline_fn->($basename, $lupstream)) {
 341       if (stat $lupstream) {
 342         print DEBUG "already.\n";
 343         next;
 344       }
 345       die "$lupstream $!" unless $!==ENOENT;
 346
 347       if ($offline) {
 348         print DEBUG "missing.\n";
 349         warn "offline but $lupstream missing\n";
 350         next;
 351       }
 352     }
 353
 354     $method_impl->($lbase, $lupstream, $rstem);
 355
 356     print DEBUG "done.\n";
 357   }
 358 }
 359
 360 close $makefile or die $!;
 361
 362 if (defined($method_lictext)) {
 363   my $cmp = compare("$licpath.tmp", $licpath);
 364   die if $cmp < 0;
 365   if ($cmp) {
 366     rename "$licpath.tmp", $licpath or die $!;
 367   } else {
 368     remove "$licpath.tmp";
 369   }
 370 }
 371
 372 rename "$makepath.tmp", $makepath or die $!;