|
1 #!/usr/bin/perl |
|
2 |
|
3 use warnings; |
|
4 use strict; |
|
5 |
|
6 use IO::File; |
|
7 use IPC::Run qw(run); |
|
8 use Mail::Sendmail; |
|
9 use Sys::Hostname::Long; |
|
10 |
|
11 =head1 Name |
|
12 |
|
13 rpi - a wrapper around B<reprepro processincoming> |
|
14 |
|
15 =head1 Description |
|
16 |
|
17 Until B<reprepro> supports a better mechanism for sending notifications for |
|
18 rejected packages we just execute B<reprepro processincoming> and parse its |
|
19 stdout and its stderr. Everything matching C<$important> patterns will be sent |
|
20 to either the signer of the changes file, the changer (from the B<Changed-By> |
|
21 field if present) or the maintainer (from the B<Maintainer> field). Depending |
|
22 on the type of message suggestions for problem resolution may be added. To |
|
23 enable us to determine which message relates to which .changes file we need a |
|
24 patched B<reprepro>: |
|
25 |
|
26 --- incoming.c.orig 2009-06-11 10:48:27.000000000 +0200 |
|
27 +++ reprepro-3.5.2/incoming.c 2009-06-11 14:29:28.000000000 +0200 |
|
28 @@ -1854,6 +1854,8 @@ |
|
29 for( j = 0 ; j < i->files.count ; j ++ ) { |
|
30 const char *basename = i->files.values[j]; |
|
31 size_t l = strlen(basename); |
|
32 + char *fullfilename; |
|
33 + |
|
34 #define C_SUFFIX ".changes" |
|
35 #define C_LEN strlen(C_SUFFIX) |
|
36 if( l <= C_LEN || strcmp(basename+(l-C_LEN),C_SUFFIX) != 0 ) |
|
37 @@ -1861,7 +1863,16 @@ |
|
38 if( changesfilename != NULL && strcmp(basename, changesfilename) != 0 ) |
|
39 continue; |
|
40 /* a .changes file, check it */ |
|
41 + fullfilename = calc_dirconcat(i->directory, i->files.values[j]); |
|
42 + if( fullfilename == NULL ) { |
|
43 + result = RET_ERROR_OOM; |
|
44 + continue; |
|
45 + } |
|
46 + printf("processing changesfile '%s'\n", fullfilename); |
|
47 + fprintf(stderr, "processing changesfile '%s'\n", fullfilename); |
|
48 r = process_changes(database, dereferenced, i, j); |
|
49 + printf("changesfile '%s' done\n", fullfilename); |
|
50 + fprintf(stderr, "changesfile '%s' done\n", fullfilename); |
|
51 RET_UPDATE(result, r); |
|
52 } |
|
53 |
|
54 To avoid possibly bothering random people we can limit possible recipients with |
|
55 a regular expression in C<$valid_receivers>. Any output matching the |
|
56 C<$unimportant> regular expression will not be sent to anyone. If we cant |
|
57 determine anyone to send the notification to we will try to send it to the |
|
58 C<$fallback> address. Anything matching none of the defined patterns will be |
|
59 sent to the C<$fallback> address too. Everything will be printed to stdout. |
|
60 |
|
61 =cut |
|
62 |
|
63 my $hostname = hostname_long; |
|
64 for (*STDERR, *STDOUT) { select $_; $|=1; } |
|
65 |
|
66 # see man reprepro |
|
67 # used as argument to the -b option of reprepro |
|
68 my $repo = "$ENV{HOME}/repo"; |
|
69 |
|
70 # the ruleset to use for processincoming |
|
71 my $ruleset = "ius"; |
|
72 |
|
73 # the actual reprepro command to execute |
|
74 my @cmd = ('/usr/bin/reprepro', '-b', $repo, 'processincoming', $ruleset); |
|
75 |
|
76 # wont send any notification mails to anyone not matching this regexp |
|
77 my $valid_receivers = '[@.]schlittermann.de>?$'; |
|
78 |
|
79 # anything noteworthy not sent to anyone else will be sent here; does not need |
|
80 # to match $valid_receivers |
|
81 my $fallback = "apt\@$hostname"; |
|
82 |
|
83 # any output not matching any of the defined patterns will be logged here if |
|
84 # defined, dont forget to also pass the write mode, fex: "> /path/to/file" if |
|
85 # you want to overwrite it or ">> /path/to/file" if you want to append to it |
|
86 my $log_uncaught; |
|
87 $log_uncaught = ">> $ENV{HOME}/var/log/reprepro/uncaught"; |
|
88 |
|
89 # raw command output will be logged here if defined, dont forget the write mode |
|
90 # - see $log_uncaught |
|
91 my $log_raw; |
|
92 $log_raw = ">> $ENV{HOME}/var/log/reprepro/raw"; |
|
93 |
|
94 # anything that would be sent to the signer/changer/maintainer goes to |
|
95 # $fallback instead if this is set |
|
96 my $dont_send_to_real_uploader = 1; |
|
97 |
|
98 # prototypes for message handling routines |
|
99 sub m_mismatch($); |
|
100 sub m_missingfile($$$); |
|
101 sub m_mayexist($$$); |
|
102 sub m_allskipped($); |
|
103 sub m_equal_or_newer($$); |
|
104 sub m_unsigned($); |
|
105 sub m_asis(); |
|
106 |
|
107 # prototypes for other routines |
|
108 sub parse_incoming($); |
|
109 sub uploader($); |
|
110 sub run_command_and_parse_output($$$$$$); |
|
111 sub parse_output($$$$$$$$); |
|
112 sub sendmails($$$$); |
|
113 |
|
114 # anything matching these is considered noteworthy and should be sent to someone |
|
115 my $important = { |
|
116 qq{^File "([^"]+)" is already registered with different checksums!} => \&m_mismatch, |
|
117 "^file '([^']+)' is needed for '([^']+)', not yet registered in the pool and not found in '([^']+)'\$" => \&m_missingfile, |
|
118 "^Warning: trying to put version '([^']+)' of '([^']+)' in '([^']+)',\$" => \&m_mayexist, |
|
119 "^Skipping ([^ ]+) because all packages are skipped!\$" => \&m_allskipped, |
|
120 "^Data seems not to be signed trying to use directly...\$" => \&m_unsigned, |
|
121 "^ERROR: File '([^']+)' does not match expextations:\$" => \&m_asis, |
|
122 "^Not putting '([^']+)' in '([^']+)' as already in there with equal or newer version.\$" => \&m_equal_or_newer |
|
123 }; |
|
124 |
|
125 # anything matching these will not be sent to anyone |
|
126 my $unimportant = '^' |
|
127 . ( join '|', |
|
128 "Exporting indices...", |
|
129 "while there already is '[^']+' in there.", |
|
130 "(md5|sha(1|256)) expected: [[:xdigit:]]{32,}, got: [[:xdigit:]]{32,}", |
|
131 "size expected: \\d+, got: \\d+", |
|
132 "There have been errors!") |
|
133 . '$'; |
|
134 |
|
135 my $rci = "$repo/conf/incoming"; |
|
136 my $i = parse_incoming($rci)->{$ruleset}->{'IncomingDir'}; |
|
137 die "Can't find IncomingDir for ruleset [$ruleset] in configuration file: [$rci]\n" unless defined $i; |
|
138 |
|
139 # we need to determine uploaders before running reprepro, because it will |
|
140 # remove the *.changes files before we are going to parse its output |
|
141 my $uploaders = { map { $_ => uploader($_) } glob("$i/*.changes") }; |
|
142 my $messages = run_command_and_parse_output([@cmd], $uploaders, $important, $unimportant, $log_uncaught, $log_raw); |
|
143 sendmails($messages, $valid_receivers, $fallback, $hostname); |
|
144 |
|
145 # determine 'uploader' of changes file; 'uploader' means here: either the |
|
146 # signer of the changes file or the changer or the maintainer in that order of |
|
147 # preference; the 'changer' means what is extracted from the 'Changed-By' field |
|
148 # of the .changes file if present; 'maintainer' will be extracted from the |
|
149 # 'Maintainer' field if necessary; nothing will be returned if the signature |
|
150 # verification command fails for some reason |
|
151 sub uploader($) { |
|
152 my ($c) = @_; |
|
153 my $vc = "LANG=POSIX /usr/bin/gpg --verify $c 2>&1"; |
|
154 |
|
155 my @r = qx{$vc}; |
|
156 |
|
157 if ($?) { |
|
158 warn "[$0]: [$vc] failed: [$!] [$?]\n"; |
|
159 return; |
|
160 } |
|
161 |
|
162 for (@r) { |
|
163 return "$1" if /^gpg: Good signature from "(.+)"$/; |
|
164 } |
|
165 |
|
166 my $e; |
|
167 my $fh = new IO::File "< $c" or warn "[$0]: Can't open [< $c]: $!\n"; |
|
168 while (<$fh>) { |
|
169 if (/^Changed-By:\s*(\S.+\S)\s*$/) { |
|
170 $e = $1; last; |
|
171 } |
|
172 $e = $1 if /^Maintainer:\s*(\S.+\S)\s*$/ |
|
173 } |
|
174 close $fh or warn "[$0]: Can't close [$fh]: $!\n"; |
|
175 |
|
176 return $e; |
|
177 |
|
178 } |
|
179 |
|
180 # checksum mismatch |
|
181 sub m_mismatch($) { |
|
182 return "Try to remove the offending lines from the changesfile or just rebuild with dpkg-buildpackage -B\n"; |
|
183 } |
|
184 |
|
185 # missingfile |
|
186 sub m_missingfile($$$) { |
|
187 my ($m, $i, $c) = @_; |
|
188 my $t = $m =~ /\.orig\.tar\.gz$/ ? "Try to rebuild with dpkg-buildpackage -sa or do 'changestool <.changes-filename> includeallsources' and resign the changesfile afterwards\n" : ''; |
|
189 #print "MISSINGFILE: [$c], [$t]\n"; |
|
190 return $t; |
|
191 } |
|
192 |
|
193 # mayexist |
|
194 sub m_mayexist($$$) { |
|
195 # package & version are confused in reprepro output |
|
196 # currently (3.5.2-6) |
|
197 # my ($p, $v, $cca) = @_; |
|
198 # $cca =~ /^[^|]+\|[^|]+\|([^|]+)$/; |
|
199 |
|
200 #print "MAYEXIST: [$c], [package ..]\n"; |
|
201 return "package may be already present with higher version\n"; |
|
202 } |
|
203 |
|
204 # allskipped |
|
205 sub m_allskipped($) { |
|
206 #print "ALLSKIPPED: [$_[0]], [nüx ..]\n"; |
|
207 return "package may be already present with same or higher version\n"; |
|
208 } |
|
209 |
|
210 # equal or newer |
|
211 sub m_equal_or_newer($$) { |
|
212 #print "EQUAL_OR_NEWER: [$_[0]], [nüx ..]\n"; |
|
213 return ''; |
|
214 } |
|
215 |
|
216 # unsigned |
|
217 sub m_unsigned($) { return 'You may want to check whether both the .changes and the .dsc file are signed'; } |
|
218 |
|
219 # return empty string |
|
220 sub m_asis() { return ''; } |
|
221 |
|
222 # parse conf/incoming, return ref to hash: |
|
223 # { name1 => { field11 => value11, field12 => value12, ... }, |
|
224 # { name2 => { field21 => value21, ... }, ... |
|
225 sub parse_incoming($) { |
|
226 |
|
227 my ($cf) = @_; |
|
228 my ($name, $conf); |
|
229 my $fh = new IO::File "< $cf" or warn "Can't open [< $cf]: $!"; |
|
230 |
|
231 while (<$fh>) { |
|
232 |
|
233 if (/^(\S+)\s*:\s*(\S+)\s/) { |
|
234 |
|
235 if ($1 eq 'Name') { |
|
236 $name = $2; |
|
237 $conf->{$name} = {}; |
|
238 } else { |
|
239 warn "Undefined Name\n" unless defined $name; |
|
240 $conf->{$name}->{$1} = $2; |
|
241 } |
|
242 |
|
243 } |
|
244 |
|
245 } |
|
246 close $fh or warn "Can't close [$fh]: $!\n"; |
|
247 |
|
248 return $conf; |
|
249 |
|
250 } |
|
251 |
|
252 # run the command and parse its output |
|
253 sub run_command_and_parse_output($$$$$$) { |
|
254 |
|
255 my @cmd = @{shift()}; |
|
256 my ($u, $important, $unimportant, $luname, $lrname) = @_; |
|
257 |
|
258 my ($ih, $oh, $eh); |
|
259 |
|
260 run \@cmd, \$ih, \$oh, \$eh or warn "running [@cmd] returned: [$?] [$!]\n"; |
|
261 |
|
262 my ($ln, $lh); |
|
263 $ln = { uncaught => $luname, raw => $lrname }; |
|
264 |
|
265 for (keys %{$ln}) { |
|
266 if (defined $ln->{$_}) { |
|
267 $lh->{$_} = new IO::File $ln->{$_} or warn "Can't open [$ln->{$_}]: $!\n"; |
|
268 } |
|
269 } |
|
270 |
|
271 my $messages = parse_output([@cmd], $oh, $eh, $u, $important, $unimportant, $lh->{'uncaught'}, $lh->{'raw'}); |
|
272 |
|
273 for (keys %{$lh}) { |
|
274 if (defined $lh->{$_}) { |
|
275 close $lh->{$_} or warn "Can't close [$lh->{$_}]: $!"; |
|
276 } |
|
277 } |
|
278 |
|
279 return $messages; |
|
280 |
|
281 } |
|
282 |
|
283 # parse the commands output extract messages matching the defined patterns from |
|
284 # stdout/err, add suggestions for problem resolution if possible and try to |
|
285 # assign it to an uploader |
|
286 sub parse_output($$$$$$$$) { |
|
287 |
|
288 my @cmd = @{shift()}; |
|
289 my ($oh, $eh, $u, $important, $unimportant, $uncaught, $raw) = @_; |
|
290 |
|
291 my ($m, $c, $f); |
|
292 |
|
293 $f = 'fallback'; |
|
294 |
|
295 LINE: |
|
296 for my $line (split /\n/, $oh . $eh) { |
|
297 |
|
298 $line .= "\n"; |
|
299 print "[@cmd]: $line"; |
|
300 print $raw $line if defined $raw; |
|
301 |
|
302 # try to determine uploader |
|
303 if ($line =~ /^processing changesfile '([^']+)'$/) { |
|
304 $c = $1; |
|
305 $u = $uploaders->{$c}; |
|
306 unless (defined $u) { |
|
307 |
|
308 $u = $f; |
|
309 my $w = "Won't send notification for [$i/$c] because i couldn't determine any uploader to sent it to.\n"; |
|
310 $m->{$u} //= ''; |
|
311 $m->{$u} .= "[$c]: $w"; |
|
312 warn "[$0]: $w"; |
|
313 |
|
314 } |
|
315 |
|
316 next LINE; |
|
317 |
|
318 } |
|
319 |
|
320 # done with that changesfile |
|
321 if ($line =~ /^changesfile '[^']+' done$/) { |
|
322 undef $c; |
|
323 $u = $f; |
|
324 next LINE; |
|
325 } |
|
326 |
|
327 # anything matching $important should be sent to someone |
|
328 for (keys(%{$important})) { |
|
329 if ($line =~ $_) { |
|
330 my $t = $important->{$_}->($1, $2, $3, $4, $5, $6, $7, $8, $9); |
|
331 if (defined $u) { |
|
332 $m->{$u} = '' unless defined $m->{$u}; |
|
333 $m->{$u} .= "[$c]: $line"; |
|
334 $m->{$u} .= $t if defined $t; |
|
335 $m->{$u} .= "\n"; |
|
336 } |
|
337 next LINE; |
|
338 } |
|
339 |
|
340 } |
|
341 |
|
342 # unimportant stuff? |
|
343 next LINE if $line =~ /$unimportant/; |
|
344 |
|
345 # everything not matching any other pattern |
|
346 $m->{$f} = '' unless defined $m->{$f}; |
|
347 $m->{$f} .= "[uncaught line]: $line\n"; |
|
348 |
|
349 print $uncaught $line if defined $uncaught; |
|
350 |
|
351 } |
|
352 |
|
353 return $m; |
|
354 |
|
355 } |
|
356 |
|
357 # send the notification mails |
|
358 sub sendmails($$$$) { |
|
359 |
|
360 my ($messages, $valid_receivers, $fallback, $hostname) = @_; |
|
361 |
|
362 my $from = "$ENV{LOGNAME}\@$hostname"; |
|
363 my $mfb = $messages->{'fallback'}; |
|
364 |
|
365 for my $u (keys %{$messages}) { |
|
366 |
|
367 next if $u eq 'fallback'; |
|
368 |
|
369 if ($u =~ $valid_receivers) { |
|
370 |
|
371 my ($msg, $to) = ($messages->{$u}, $u); |
|
372 ($msg, $to) = ("[This is just a test mail to you. If this wasn't a test mail, then it should have been sent to [$u]]\n\n" . $messages->{$u}, $fallback) if $dont_send_to_real_uploader; |
|
373 |
|
374 sendmail(From => $from, |
|
375 Subject => "[apt] Possible Problem importing your changes", |
|
376 To => $to, |
|
377 Message => $msg); |
|
378 print "[$0]: ", $Mail::Sendmail::log, "\n"; |
|
379 warn "[$0]: ", $Mail::Sendmail::error, "\n" if $Mail::Sendmail::error; |
|
380 |
|
381 } else { |
|
382 |
|
383 my $w = "Won't send notification: invalid receiver [$u]\n\n"; |
|
384 $mfb //= ''; $mfb .= $w; $mfb .= ">>>\n[$messages->{$u}]\n<<<\n\n"; |
|
385 warn "[$0]: $w"; |
|
386 |
|
387 } |
|
388 |
|
389 } |
|
390 |
|
391 if (defined $mfb) { |
|
392 |
|
393 sendmail(From => $from, |
|
394 Subject => "[apt] Possible Problem processing incoming", |
|
395 To => $fallback, |
|
396 Message => $mfb); |
|
397 print "[$0]: ", $Mail::Sendmail::log, "\n"; |
|
398 warn "[$0]: ", $Mail::Sendmail::error, "\n" if $Mail::Sendmail::error; |
|
399 |
|
400 } |
|
401 |
|
402 } |
|
403 |
|
404 sub BEGIN { |
|
405 print "[$0]: Started at ", scalar localtime, "\n"; |
|
406 } |
|
407 |
|
408 sub END { |
|
409 print "[$0]: Finished at ", scalar localtime, "\n"; |
|
410 } |