doručenky/dorucenky.pl
author František Kučera <franta-hg@frantovo.cz>
Mon Mar 10 12:21:02 2014 +0100 (2014-03-10)
changeset 27 60cfdaa89b3a
parent 23 c78f71bda340
permissions -rwxr-xr-x
hgignore
     1 #!/usr/bin/env perl
     2 
     3 use strict;
     4 use MIME::Parser;
     5 use Net::SMTP;
     6 
     7 # K doručenkám typu:
     8 #	Content-Type: multipart/report; report-type=delivery-status; ~ Delivery Status Notification (DSN)
     9 # doplňujeme hlavičku References, 
    10 # aby si je e-mailový klient mohl zařadit do vlákna pod zprávu, ke které doručenka patří.
    11 
    12 # viz http://search.cpan.org/~dskoll/MIME-tools-5.502/lib/MIME/Entity.pm
    13 # viz http://search.cpan.org/~dskoll/MIME-tools-5.502/lib/MIME/Head.pm
    14 # viz http://perldoc.perl.org/Net/SMTP.html
    15 
    16 # aptitude install libmime-tools-perl libmailtools-perl
    17 
    18 
    19 # Nastavení --------------------------------------------------------------------
    20 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í
    21 # ------------------------------------------------------------------------------
    22 
    23 my $znacka = "X-DSN-Pridej-References"; # hlavička, kterou si poznačíme, že zpráva prošla tímto programem
    24 my $stav = "chyba - nedefinovano"; # výchozí hodnota naší hlavičky
    25 
    26 
    27 # Načteme zprávu
    28 my $parser = new MIME::Parser;
    29 $parser->output_to_core(1);
    30 my $dorucenka = $parser->parse(\*STDIN);
    31 
    32 
    33 # Kontrola, že se zpráva nezacyklila (chybí naše značka)
    34 if ($dorucenka->head->count($znacka) == 0) {
    35 	
    36 	# Podle hlavičky Delivered-To zjistíme, kam máme zprávu poslat zpátky	
    37 	my $deliveredTo = $dorucenka->head->get("Delivered-To", 1); # [0] = adresa tohoto skriptu, [1] = předchozí adresa – původní příjemce doručenky 
    38 	if ($deliveredTo) {
    39 		$deliveredTo =~ s/\s+$//; # zbavíme se přebytečného konce řádku
    40 		$komu = $deliveredTo;
    41 		$dorucenka->head->delete("Delivered-To", 1); # aby si poštovní server nemyslel, že se zpráva zacyklila 
    42 		
    43 		# Pokud hlavička References chybí, doplníme ji
    44 		if ($dorucenka->head->count("References") == 0) {
    45 			
    46 			# Zjistíme Message-ID původní zprávy
    47 			my $messageID;
    48 			my @casti = $dorucenka->parts;
    49 			for my $cast (@casti) {
    50 				if ($cast->mime_type eq "text/rfc822-headers") {
    51 					my @radky = $cast->bodyhandle->as_lines;
    52 					for my $radek (@radky) {
    53 						if ($radek =~ /^Message-ID:\s*(<.*>)$/) {
    54 							$messageID = $1;
    55 						}
    56 					}
    57 				}			
    58 			}		
    59 			
    60 			# Nastavíme nalezené Message-ID do References hlavičky
    61 			if ($messageID) {
    62 				$stav = "ok";
    63 				$dorucenka->head->add("References", $messageID);
    64 			} else {
    65 				$stav = "chyba - Message-ID nenalezeno";
    66 			}
    67 		} else {
    68 			$stav = "ok - hlavicka References uz byla nastavena drive";
    69 		}		
    70 	} else {
    71 		$stav = "chyba - nevime, kam zpravu poslat zpet";
    72 	}	
    73 } else {
    74 	$stav = "chyba - zprava se zacyklila";
    75 }
    76 
    77 
    78 $stav .= " [pid=$$,uid=$>]"; # přidáme PID a UID
    79 $dorucenka->head->add($znacka, $stav);
    80 
    81 # Výpis (nepotřebujeme, jen pro ladění)
    82 #$dorucenka->print(\*STDOUT);
    83 #print "Pošleme komu: $komu\n";
    84 
    85 # Odeslání přes SMTP (pro ostrý provoz):
    86 my $smtp = Net::SMTP->new("localhost");
    87 $smtp->mail('<>');
    88 $smtp->to($komu);
    89 $smtp->data();
    90 $dorucenka->print($smtp);
    91 $smtp->dataend();
    92 $smtp->quit;
    93