the metadata fetcher
[bse.git] / 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 }