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
  81 sub methodlic_wikimedia ($) {
  82   my ($scraper) = @_;
  83   return <<END;
  84 These files were all obtained from
  85     ${ \ $scraper->('site-title') }
  86
  87 They are all available under at least, and distributed here under,
  88     ${ \ $scraper->('spdx') }
  89 as well as possibly other licences.  There is NO WARRANTY.
  90
  91 See <file>.download-log for the original URL and download timestamp.
  92 The wikitext of the File: page on the wiki is in <file>.wikitext, and
  93 contains the authorship and derivation information, as well as
  94 information about any alternative licence terms.
  95
  96 [ This LICENCE file was generated by media-scraper and should not
  97   be manually edited ]
  98 END
  99 }
 100
 101 sub method_wikimedia ($$$) {
 102   my ($scraper, $methname) = @_;
 103   #print DEBUG "METHOD $methname...\n";
 104   return sub {
 105     my ($lbase, $ldest, $rstem) = @_;
 106     my $rfilename = cfg_affixes $scraper, 'filename', $rstem;
 107     my $url = cfg_affixes $scraper, 'url', $rfilename;
 108     my $wt = "$lbase.wikitext";
 109     #print DEBUG "rfilename=$rfilename url=$url .\n";
 110     my $datalog = new IO::File "$lbase.download-log", '>>' or die $!;
 111     print $datalog "\n" or die $!;
 112     run_curl $datalog, $wt, $url;
 113     open WT, "$wt" or die $!;
 114     my (@lics) = @{ $scraper->('licences') };
 115     s/\W/\\$&/g foreach @lics;
 116     my $lic1_re = '(?:'.(join '|', @lics).')';
 117     my $ok;
 118     while (<WT>) {
 119       s/\s+$//;
 120       if (m{^ \{\{ ($lic1_re) \}\} $}xi ||
 121           m{^ \{\{ self\| (?:[^{}]*\|)? ($lic1_re) (?:\|[^{}]*)? \}\} $}xi) {
 122         print "licence=$1 ";
 123         $ok = 1;
 124         last;
 125       }
 126     }
 127     if (!$ok) {
 128       die "\nfile $wt from $url no appropriate licence $lic1_re";
 129     }
 130     my $hash_prefix = '';
 131     if ($scraper->('data_url_hashprefix')) {
 132       # https://www.mediawiki.org/wiki/Special:MyLanguage/Manual:$wgHashedUploadDirectory
 133       md5_hex($rfilename) =~ m{^((.).)} or die;
 134       $hash_prefix .= "$2/$1/";
 135     }
 136     my $data_url = cfg_affixes $scraper, 'data_url', $hash_prefix.$rfilename;
 137     run_curl $datalog, $ldest, $data_url;
 138     close $datalog or die $!;
 139   };
 140 }
 141
 142 my $input = $ARGV[0] // die;
 143 $input =~ m/\.toml$/ or die "$input ?";
 144 my $basename = $`;
 145 mkdir $basename or $!==EEXIST or die "mkdir $basename: $!";
 146
 147 my $parser = TOML::Parser->new();
 148 my $libinfo = $parser->parse_file($input);
 149 my $groups = $libinfo->{group};
 150 my $scraper = sub { $libinfo->{scraper}{$_[0]} };
 151 my $method = $scraper->('method');
 152 my $method_fn = ${*::}{"method_$method"};
 153
 154 my $methodlic_fn = ${*::}{"methodlic_$method"};
 155 my $licpath = "$basename/LICENCE";
 156
 157 my $method_lictext = $methodlic_fn->($scraper);
 158 if (defined $method_lictext) {
 159   my $licfile = new IO::File "$licpath.tmp", '>' or die $!;
 160
 161   print $licfile <<END, $method_lictext, <<END or die $!;
 162 SPDX-License-Identifier: ${ \ $scraper->('spdx') }
 163 (applies to the contents of this directory unless otherwise stated)
 164
 165 END
 166
 167 The download was done by media-scraper, controlled by $input.
 168 END
 169   close $licfile or die $!;
 170 }
 171
 172 my $makepath = "$basename/files.make";
 173 my $makefile = new IO::File "$makepath.tmp", '>' or die $!;
 174
 175 foreach my $groupname (sort keys %$groups) {
 176   my $group_dict = $groups->{$groupname};
 177   my $gcfg = mk_cfg_lookup($groups, $group_dict);
 178   my $method_impl = $method_fn->($scraper, $method);
 179   foreach (split(/\n/, $gcfg->('files'))) {
 180     s/^\s+//;
 181     next if m/^\#/ || m/^$/;
 182     m/^(\S+)\s+(\S+)/ or die;
 183     my $lministem = $1;
 184     my $rministem = $2;
 185     my $lstem = cfg_affixes $gcfg, 'item', $lministem;
 186     my $rstem = cfg_affixes $gcfg, 'stem', $rministem;
 187     my $lbase = "$basename/$lstem";
 188     my $lupstream = "$lbase.svg";
 189     my $lprocessed = "$lbase.usvg";
 190
 191     print DEBUG "file $lstem ";
 192
 193     print $makefile <<END or die $!;
 194 LIBRARY_FILES += $lprocessed
 195 $lprocessed: $lupstream $licpath $input
 196         \$(LIBRARY_PROCESS_SVG)
 197 END
 198
 199     if (stat $lupstream) {
 200       print DEBUG "already.\n";
 201       next;
 202     }
 203     die "$lupstream $!" unless $!==ENOENT;
 204
 205     $method_impl->($lbase, $lupstream, $rstem);
 206
 207     print DEBUG "done.\n";
 208   }
 209 }
 210
 211 close $makefile or die $!;
 212
 213 if (defined($method_lictext)) {
 214   my $cmp = compare("$licpath.tmp", $licpath);
 215   die if $cmp < 0;
 216   if ($cmp) {
 217     rename "$licpath.tmp", $licpath or die $!;
 218   } else {
 219     remove "$licpath.tmp";
 220   }
 221 }
 222
 223 rename "$makepath.tmp", $makepath or die $!;