1.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
     1.2 +++ b/doručenky/dorucenky.pl	Wed Nov 30 15:44:34 2011 +0100
     1.3 @@ -0,0 +1,93 @@
     1.4 +#!/usr/bin/env perl
     1.5 +
     1.6 +use strict;
     1.7 +use MIME::Parser;
     1.8 +use Net::SMTP;
     1.9 +
    1.10 +# K doručenkám typu:
    1.11 +#	Content-Type: multipart/report; report-type=delivery-status; ~ Delivery Status Notification (DSN)
    1.12 +# doplňujeme hlavičku References, 
    1.13 +# aby si je e-mailový klient mohl zařadit do vlákna pod zprávu, ke které doručenka patří.
    1.14 +
    1.15 +# viz http://search.cpan.org/~dskoll/MIME-tools-5.502/lib/MIME/Entity.pm
    1.16 +# viz http://search.cpan.org/~dskoll/MIME-tools-5.502/lib/MIME/Head.pm
    1.17 +# viz http://search.cpan.org/~gbarr/libnet-1.21/Net/SMTP.pm
    1.18 +
    1.19 +
    1.20 +# Nastavení --------------------------------------------------------------------
    1.21 +my $komu = 'noreply@example.com'; # adresa správce – sem pošleme zprávy, pokud nevíme, kam je poslat (chybí Delivered-To), nebo máme podezření na zacyklení
    1.22 +# ------------------------------------------------------------------------------
    1.23 +
    1.24 +my $znacka = "X-DSN-Pridej-References"; # hlavička, kterou si poznačíme, že zpráva prošla tímto programem
    1.25 +my $stav = "chyba - nedefinovano"; # výchozí hodnota naší hlavičky
    1.26 +
    1.27 +
    1.28 +# Načteme zprávu
    1.29 +my $parser = new MIME::Parser;
    1.30 +$parser->output_to_core(1);
    1.31 +my $dorucenka = $parser->parse(\*STDIN);
    1.32 +
    1.33 +
    1.34 +# Kontrola, že se zpráva nezacyklila (chybí naše značka)
    1.35 +if ($dorucenka->head->count($znacka) == 0) {
    1.36 +	
    1.37 +	# Podle hlavičky Delivered-To zjistíme, kam máme zprávu poslat zpátky	
    1.38 +	my $deliveredTo = $dorucenka->head->get("Delivered-To", 1); # [0] = adresa tohoto skriptu, [1] = předchozí adresa – původní příjemce doručenky 
    1.39 +	if ($deliveredTo) {
    1.40 +		$deliveredTo =~ s/\s+$//; # zbavíme se přebytečného konce řádku
    1.41 +		$komu = $deliveredTo;
    1.42 +		$dorucenka->head->delete("Delivered-To", 1); # aby si poštovní server nemyslel, že se zpráva zacyklila 
    1.43 +		
    1.44 +		# Pokud hlavička References chybí, doplníme ji
    1.45 +		if ($dorucenka->head->count("References") == 0) {
    1.46 +			
    1.47 +			# Zjistíme Message-ID původní zprávy
    1.48 +			my $messageID;
    1.49 +			my @casti = $dorucenka->parts;
    1.50 +			for my $cast (@casti) {
    1.51 +				if ($cast->mime_type eq "text/rfc822-headers") {
    1.52 +					my @radky = $cast->bodyhandle->as_lines;
    1.53 +					for my $radek (@radky) {
    1.54 +						if ($radek =~ /^Message-ID:\s*(<.*>)$/) {
    1.55 +							$messageID = $1;
    1.56 +						}
    1.57 +					}
    1.58 +				}			
    1.59 +			}		
    1.60 +			
    1.61 +			# Nastavíme nalezené Message-ID do References hlavičky
    1.62 +			if ($messageID) {
    1.63 +				$stav = "ok";
    1.64 +				$dorucenka->head->add("References", $messageID);
    1.65 +			} else {
    1.66 +				$stav = "chyba - Message-ID nenalezeno";
    1.67 +			}
    1.68 +			
    1.69 +		} else {
    1.70 +			$stav = "hlavicka References uz byla nastavena drive";
    1.71 +		}		
    1.72 +	} else {
    1.73 +		$stav = "chyba - nevime, kam zpravu poslat zpet";
    1.74 +	}	
    1.75 +} else {
    1.76 +	# Zpráva se zacyklila → pouze přidáme svoji značku
    1.77 +	# a pošleme správci (nezměníme $komu)
    1.78 +	$stav = "chyba - cyklus";
    1.79 +}
    1.80 +
    1.81 +
    1.82 +$stav .= " [pid=$$,uid=$>]"; # přidáme PID a UID
    1.83 +$dorucenka->head->add($znacka, $stav);
    1.84 +
    1.85 +# Výpis (nepotřebujeme, jen pro ladění)
    1.86 +#$dorucenka->print(\*STDOUT);
    1.87 +#print "Pošleme komu: $komu\n";
    1.88 +
    1.89 +# Odeslání přes SMTP (pro ostrý provoz):
    1.90 +my $smtp = Net::SMTP->new("localhost");
    1.91 +$smtp->mail('<>');
    1.92 +$smtp->to($komu);
    1.93 +$smtp->data();
    1.94 +$dorucenka->print($smtp);
    1.95 +$smtp->dataend();
    1.96 +$smtp->quit;