site/cgi-bin/modules/BSE/Util/Fetcher.pm

   1 package BSE::Util::Fetcher;
   2 use strict;
   3 use warnings;
   4 use BSE::TB::Articles;
   5 use BSE::TB::AuditLog;
   6 use LWP::UserAgent;
   7 use BSE::Util::HTML "escape_uri";
   8 use JSON ();
   9
  10 our $VERSION = "1.002";
  11
  12 my $json_types = qq!\\A(?:application/json|text/x-json(?: encoding=(?:"utf-8"|utf-8)?))\\z!;
  13
  14 sub new {
  15   my ($class, %opts) = @_;
  16
  17   if ($opts{articles}) {
  18     $opts{harticles} = +{ map { $_ => 1 } @{$opts{articles}} };
  19   }
  20   $opts{report} ||= sub { print "@_\n" };
  21
  22   bless \%opts, $class;
  23 }
  24
  25 sub run {
  26   my ($self) = @_;
  27
  28   $self->{errors} = [];
  29
  30   my $cfg = $self->{cfg};
  31   my $section = $self->{section};
  32   my $verbose = $self->{verbose};
  33   my $report = $self->{report};
  34
  35   unless ($cfg->entry("basic", "access_control", 0)) {
  36     $self->crit(undef, undef, undef,
  37                 "Access control must be enabled for fetch processing");
  38     return;
  39   }
  40
  41   my %entries = $cfg->entries($section);
  42   my @data_keys = grep /^data/i, keys %entries;
  43
  44  KEY:
  45   for my $key (@data_keys) {
  46     (my $suffix = $key) =~ s/^data//i;
  47
  48     my $data_name = $cfg->entryErr($section, $key);
  49     my $bad_cfg = 0;
  50     unless ($data_name =~ /^([a-zA-Z0-9_-]+)$/) {
  51       $self->crit(undef, undef, undef,
  52                   "Invalid metadata name '$data_name' for [$section].$key");
  53       ++$bad_cfg;
  54     }
  55     my $url_name = $cfg->entry($section, "url$suffix", "${data_name}_url");
  56     unless ($url_name =~ /^([a-zA-Z0-9_-]+)$/) {
  57       $self->crit(undef, undef, undef,
  58                   "Invalid metadata url '$url_name' for [$section].url$suffix");
  59       ++$bad_cfg;
  60     }
  61     my $url_pattern = $cfg->entry($section, "url_pattern$suffix", '$s');
  62     unless ($url_pattern =~ /\$s/) {
  63       $self->crit(undef, undef, undef,
  64                   "Invalid url pattern '$url_pattern' for [$section].url_pattern$suffix");
  65       ++$bad_cfg;
  66     }
  67     my $url_escape = $cfg->entry($section, "url_escape$suffix", 0);
  68     my $types = $cfg->entry($section, "types$suffix", $json_types);
  69     my $types_re;
  70     unless (eval { $types_re = qr/$types/; 1 }) {
  71       $self->crit(undef, undef, undef,
  72                   "Cannot compile regexp /$types/ for [$section].types$suffix: $@");
  73       ++$bad_cfg;
  74     }
  75     my $validate = $cfg->entry($section, "validate$suffix", "json");
  76     unless ($validate =~ /\A(?:json|none)\z/i) {
  77       $self->crit(undef, undef, undef,
  78                   "Invalid validate '$validate' value for [$section].validate$suffix");
  79       ++$bad_cfg;
  80     }
  81     my $max_length = $cfg->entry($section, "max_length$suffix", 1_000_000);
  82     unless ($max_length =~ /\A[1-9][0-9]+\z/) {
  83       $self->crit(undef, undef, undef,
  84                   "Invalid max_length '$max_length' value for [$section].max_length$suffix");
  85       ++$bad_cfg;
  86     }
  87     my $on_fail = $cfg->entry($section, "on_fail$suffix", "delete");
  88     unless ($on_fail =~ /\A(delete|keep)\z/i) {
  89       $self->crit(undef, undef, undef,
  90                   "Invalid on_fail '$on_fail' value for [$section].on_fail$suffix");
  91       ++$bad_cfg;
  92     }
  93     my $on_success = $cfg->entry($section, "on_success$suffix", "");
  94     unless ($on_success =~ /\A(?:|(?&KEY)(?:,(?&KEY))*)\z
  95                            (?(DEFINE)
  96                              (?<KEY>log)
  97                            )/xi) {
  98       $self->crit(undef, undef, undef,
  99                   "Invalid on_success '$on_success' value for [$section].on_success$suffix");
 100       ++$bad_cfg;
 101     }
 102     $bad_cfg and next KEY;
 103
 104     my %cfg_dump =
 105       (
 106        data_name => $data_name,
 107        url_name => $url_name,
 108        url_pattern => $url_pattern,
 109        url_escape => $url_escape,
 110        types => $types,
 111        validate => $validate,
 112        max_length => $max_length,
 113        on_fail => $on_fail,
 114        on_success => $on_success,
 115       );
 116
 117     my $ua = LWP::UserAgent->new;
 118
 119     # look for articles with the url metadata defined
 120     my @meta = BSE::TB::Article->all_meta_by_name($url_name);
 121   META:
 122     for my $meta (@meta) {
 123       length $meta->value
 124         or next;
 125       if ($self->{harticles} && !$self->{harticles}{$meta->file_id}) {
 126         next META;
 127       }
 128       my ($article) = BSE::TB::Articles->getByPkey($meta->file_id)
 129         or next META;
 130
 131       my %base_dump =
 132         (
 133          %cfg_dump,
 134          article => $article->id,
 135         );
 136
 137       unless ($meta->is_text_type) {
 138         $self->fail($article, $data_name, $on_fail,
 139                     "Metadata $url_name for article " . $meta->file_id . " isn't text");
 140         next META;
 141       }
 142
 143       my $url_part = $meta->value_text;
 144       $url_part =~ /\S/ or next META;
 145       $url_escape and $url_part = escape_uri($url_part);
 146       (my $url = $url_pattern) =~ s/\$s/$url_part/;
 147
 148       unless ($url =~ /\A(?:https?|ftp):/) {
 149         $self->fail($article, $data_name, $on_fail, "$url isn't http, https or ftp",
 150                    \%base_dump);
 151         next META;
 152       }
 153
 154       $report->("$data_name: fetching $url") if $verbose;
 155       $base_dump{url} = $url;
 156       my $resp = $ua->get($url);
 157       unless ($resp->is_success) {
 158         print "  fetch failed: ", $resp->status_line, "\n" if $verbose;
 159         $self->fail($article, $data_name, $on_fail,
 160                     "Error fetching $url: " . $resp->status_line,
 161                     +{
 162                       %base_dump,
 163                       status => scalar $resp->status_line,
 164                      });
 165         next META;
 166       }
 167       $resp->decode;
 168       # we don't want character set decoding, just raw content after
 169       # decompression
 170       my $content = $resp->content;
 171       unless (length($content) <= $max_length) {
 172         $report->("  response too long") if $verbose;
 173         $self->fail($article, $data_name, $on_fail,
 174                     "Content is ".length($content)." which is larger than $max_length",
 175                     +{
 176                       %base_dump,
 177                       length => length($content),
 178                      });
 179         next META;
 180       }
 181       unless ($resp->content_type =~ $types_re) {
 182         $report->("  Invalid content type", $resp->content_type) if $verbose;
 183         $self->fail($article, $data_name, $on_fail,
 184                     "Content type '".$resp->content_type()."' doesn't match the types regexp",
 185                     +{
 186                       %base_dump,
 187                       content_type => $resp->content_type,
 188                      });
 189         next META;
 190       }
 191       if ($validate eq 'json') {
 192         my $json = JSON->new;
 193         unless (eval { $json->decode($content); 1 }) {
 194           $report->("  Failed JSON validation") if $verbose;
 195           $self->fail($article, $data_name, $on_fail,
 196                       "Content failed JSON validation", \%base_dump);
 197           next META;
 198         }
 199       }
 200
 201       if ($self->{save}) {
 202         my $data = $article->meta_by_name($data_name);
 203         if ($data) {
 204           $data->set_content_type($resp->content_type);
 205           $data->set_value($content);
 206           $data->save;
 207         }
 208         else {
 209           $data = $article->add_meta
 210             (
 211              name => $data_name,
 212              content_type => scalar $resp->content_type,
 213              value => $content,
 214              appdata => 1,
 215             );
 216         }
 217         $report->("  Saved") if $verbose;
 218         if ($on_success =~ /\blog\b/i) {
 219           BSE::TB::AuditLog->log
 220               (
 221                component => "fetcher::run",
 222                level => "info",
 223                actor => "S",
 224                msg => "Successfully saved '$data_name' for article '".$article->id."'",
 225                object => $article,
 226                dump => \%base_dump,
 227               );
 228         }
 229       }
 230     }
 231   }
 232
 233   return !@{$self->{errors}};
 234 }
 235
 236 sub errors {
 237   my $self = shift;
 238   $self->{errors};
 239 }
 240
 241 sub fail {
 242   my $self = shift;
 243   my ($article, $data_name, $on_fail) = @_;
 244   $self->_log("error", @_);
 245
 246   if ($article && $on_fail eq "delete" && $self->{save}) {
 247     $article->delete_meta_by_name($data_name);
 248   }
 249 }
 250
 251 sub crit {
 252   my $self = shift;
 253   $self->_log("crit", @_);
 254 }
 255
 256 sub _log {
 257   my ($self, $level, $article, $data_name, $on_fail, $message, $dump) = @_;
 258
 259   push @{$self->{errors}}, [ $level, $message ];
 260   if ($self->{log}) {
 261     BSE::TB::AuditLog->log
 262         (
 263          component => "fetcher::run",
 264          level => $level,
 265          actor => "S",
 266          msg => $message,
 267          object => $article,
 268          dump => $dump,
 269         );
 270   }
 271 }