#!/usr/bin/perl

=head1 NAME

postfix-detach-from-queue

=head1 DESCRIPTION

detaches one or multiple mails from queu and dumps them into another folder. If requested, they
are also removed from the posfix queue either via "postsuper" or by removing (much faster but
postfix has to be stopped!)

=cut

use strict;
use warnings;

use Getopt::Long;


my %opt = ();
GetOptions(
    # show help
    "help|h"        => \( $opt{ help } = 0 ),
    
    # show help
    "dry|d"         => \( $opt{ dry } = 0 ),
    
    # show help
    "verbose|v"     => \( $opt{ verbose } = 0 ),
    
    # show help
    "verbose-level|l=i"=> \( $opt{ verbose_level } = 1 ),
    
    # max amount of results to work on
    "max|m=i"       => \( $opt{ max } = 0 ),
    
    # via queue id (single)
    "queue-id|i=s"  => \( $opt{ queue_id } ),
    
    # determine by from
    "from|f=s"      => \( $opt{ from } ),
    
    # determine by to
    "to|t=s"        => \( $opt{ to } ),
    
    # determine by reason
    "reason|r=s"    => \( $opt{ reason } ),
    
    # a mailq dump file
    "mailq-dump|q=s"  => \( $opt{ mailq_dump } ),
    
    # via queue id (single)
    "output-dir|o=s"  => \( $opt{ output_dir } ),
    
    # check depth in deferred file ..
    "deferred-lines=i" => \( $opt{ deferred_lines } = 50 ),
    
    # command line
    "postcat-cmd=s" => \( $opt{ cmd_postcat } = '/usr/sbin/postcat' ),
    "postsuper-cmd=s"=> \( $opt{ cmd_postsuper } = '/usr/sbin/postsuper' ),
    "find-cmd=s"    => \( $opt{ cmd_find } = '/usr/bin/find' ),
    "head-cmd=s"    => \( $opt{ cmd_head } = '/usr/bin/head' ),
    
    # directories
    "deferred-dir=s"=> \( $opt{ dir_deferred } = '/var/spool/postfix/deferred' ),
    "defer-dir=s"   => \( $opt{ dir_defer } = '/var/spool/postfix/defer' ),
    
    # wheter remove files:
    "do-remove|u"   => \( $opt{ do_remove } = 0 ),
    
    # dont use postsuper:
    "direct-remove|x" => \( $opt{ direct_remove } = 0 ),
);


die join( "", <DATA> )
    if $opt{ help } || ( ! $opt{ queue_id } && ! $opt{ from } && ! $opt{ to } && ! $opt{ reason } );
unless ( $opt{ dry } ) {
    die "Output dir (-o path) is missing!\n"
        unless $opt{ output_dir };
    die "No such output directory '$opt{ output_dir }' or not accessable\n"
        unless -d $opt{ output_dir };
    $opt{ output_dir } =~ s~/+$~~; # remove tailing "/" from output dir 
}


print "Searching now in mail queue, this could take some time..\n";
my @queue_ids = $opt{ queue_id }
    ? split( /\s*,\s*/, $opt{ queue_id } )
    : $opt{ mailq_dump }
        ? parse_mailq_dump_for_ids()
        : find_queue_ids()
;
print "Found ". ( scalar @queue_ids ). " ids to work for detaching!\n";

foreach my $id( @queue_ids ) {
    debug( "Detach $id" );
    my $exists = $opt{ dry } ? 1 : detach_file( $id );
    if ( $exists && $opt{ do_remove } && ! $opt{ dry } ) {
        debug( "Removing $id from queue" );
        if ( $opt{ direct_remove } ) {
            `$opt{ cmd_find } "$opt{ dir_defer }" -name "$id" -delete`;
            `$opt{ cmd_find } "$opt{ dir_deferred }" -name "$id" -delete`;
        }
        else {
            `$opt{ cmd_postsuper} -d "$id"`;
        }
    }
    elsif ( ! $exists ) {
        debug( "Dont detach '$id' cause not existing", 2 );
    }
}
print "Done, ". ( scalar @queue_ids ). " worked on totally!\n";




sub parse_mailq_dump_for_ids {
    open my $fh_dump, "<", $opt{ mailq_dump }
        or die "Cannot open mailq dump '$opt{ mailq_dump }' for read: $@\n";
    my $rx_from = $opt{ from }
        ? $opt{ from } =~ /\@/
            ? qr/\Q$opt{ from }\E/
            : qr/^[^@]+?\@\Q$opt{ from }\E/
        : undef
    ;
    my $rx_reason = $opt{ reason }
        ? qr/\Q$opt{ reason }\E/
        : undef
    ;
    my $rx_to = $opt{ to }
        ? $opt{ to } =~ /\@/
            ? qr/^\s*\Q$opt{ to }\E/
            : qr/^\s*\S[^@]+?\@\Q$opt{ to }\E/
        : undef
    ;
    my $rx_empty = qr/^\s*$/;
    my $reason_or_to = $rx_reason || $rx_to;
    
    my $m = 0;
    my @ids = ();
    my $id;
    my %current = ();
    
    CHECK_MAILQ_DUMP:
    while ( my $l = <$fh_dump> ) {
        chomp $l;
        last CHECK_MAILQ_DUMP if $opt{ max } && scalar @ids >= $opt{ max }; 
        
        # empty line -> ready for parsing the first ID and FROM linke
        if ( $m == -1 && $l =~ $rx_empty ) {
            $m++;
        }
        
        # the ID and FROM line
        elsif ( $m == 0 && $l =~ /^([A-Z0-9]+)\s+\d+.*?\s+(\S+?\@.*?)$/ ) {
            ( $id, my $from ) = ( $1, $2 );
            
            # checking from ..
            if ( ! $rx_from || $from =~ $rx_from ) {
                debug( "$id - MATCH $opt{ from } IN $from FOR $rx_from", 4 ) if $rx_from;
                
                %current = ( from => $from );
                
                # still waiting for reason or to
                if ( $reason_or_to ) {
                    $m++;
                }
                
                # all found -> remember id
                else {
                    push @ids, $id;
                    $id = undef;
                    $m = -1;
                    debug( "Found mail: FROM='$from'", 3 );
                }
            }
            else {
                debug( "$id - NO MATCH $opt{ from } IN $from FOR $rx_from", 4 ) if $rx_from;
            }
        }
        
        # the REASON line
        elsif ( $m == 1 ) {
            if ( ! $rx_reason || $l =~ $rx_reason ) {
                debug( "$id - MATCH $opt{ reason } IN $l FOR $rx_reason", 4 ) if $rx_reason;
                
                ( $current{ reason } = $l ) =~ s/^\s+//;
                
                # still waiting for to
                if ( $rx_to ) {
                    $m++;
                }
                
                # all found -> remember id
                else {
                    push @ids, $id;
                    $id = undef;
                    $m = -1;
                    debug( "Found mail: FROM='$current{ from }', REASON='$current{ reason }'", 3 );
                }
            }
            else {
                debug( "$id - NO MATCH $opt{ reason } IN $l FOR $rx_reason", 4 ) if $rx_reason;
                $m = -1;
            }
        }
        
        # the TO line
        elsif ( $m > 1 ) {
            
            # empty line, all over, next turn
            if ( $l =~ $rx_empty ) {
                $m = 0;
            }
            
            # all found -> remember id
            elsif ( $l =~ $rx_to ) {
                debug( "$id - MATCH $opt{ to } IN $l FOR $rx_to", 4 ) if $rx_to;
                push @ids, $id;
                $id = undef;
                $m = -1;
                ( my $to = $l ) =~ s/^\s+//;
                debug( "Found mail: FROM='$current{ from }', TO='$to', REASON='$current{ reason }'", 3 );
            }
            else {
                debug( "$id - NO MATCH $opt{ to } IN $l FOR $rx_to", 4 ) if $rx_to;
            }
        }
    }
    close $fh_dump;
    
    return @ids;
}



sub find_queue_ids {
    my $req_defer    = 0;
    my $req_deferred = 0;
    my ( $rx_defer, $rx_deferred );
    
    if ( $opt{ from } ) {
        debug( "Using From: $opt{ from }" );
        $req_deferred ++;
        $rx_deferred = $opt{ from } =~ /\@/
            ? qr/^From: .*?<[^>]*?\Q$opt{ from }\E[^>]*?>/
            : qr/^From: .*?<.+?\@\Q$opt{ from }\E[^>]*?>/
        ;
    }
    
    if ( $opt{ to } ) {
        debug( "Using To: $opt{ to }" );
        $req_defer ++;
        $rx_defer = $opt{ to } =~ /\@/
            ? qr/^recipient=\Q$opt{ to }\E/
            : qr/^recipient=.+?\@\Q$opt{ to }\E/
        ;
    }
    
    if ( $opt{ reason } ) {
        debug( "Using reason: $opt{ reason }" );
        $req_defer ++;
        my $rx_add = qr/^diag_text=.*?\Q$opt{ reason }\E.*?$/;
        $rx_defer = $rx_defer ? qr/(?:$rx_defer|$rx_add)/ : $rx_add;
    }
    
    
    my @queue_ids = ();
    
    if ( $req_defer ) {
        open my $cmd_find, "-|", "$opt{ cmd_find } \"$opt{ dir_defer }\" -type f";
        
        CHECK_DEFER:
        while ( my $f = <$cmd_find> ) {
            chomp $f;
            open my $fh, "<", $f or die "Cannot open defer file '$f' for read!\n";
            
            my $c = 0;
            
            CHECK_FILE:
            while( my $l = <$fh> ) {
                chomp $l;
                if ( $l =~ $rx_defer ) {
                    last CHECK_FILE if ++$c == $req_defer;
                }
            }
            
            # found ok:
            if ( $c == $req_defer ) {
                ( my $id ) = $f =~ /^(?:.*?\/)?([^\/]+?)$/;
                
                # check also in deferred
                if ( $req_deferred ) {
                    
                    # determine the deferred file
                    my $deferred_file = "$opt{ dir_deferred }/". substr( $id, 0, 1 ). "/$id";
                    
                    # no such file ?
                    die "Cannot find corresponding deferred file '$deferred_file'\n"
                        unless -f $deferred_file;
                    
                    # retreive the first 50 lines from the file .. this HAS TO BE enough
                    my @head = split( /\n/, `$opt{ cmd_postcat } \"$deferred_file\" | $opt{ cmd_head } -$opt{ deferred_lines }` );
                    my $c2 = 0;
                    
                    CHECK_INNER_DEFERRED:
                    foreach my $h( @head ) {
                        if ( $h =~ $rx_deferred ) {
                            last CHECK_INNER_DEFERRED if ++$c2 == $req_deferred;
                        }
                    }
                    
                    # save wheter we are ok
                    $c = $c2 == $req_deferred;
                }
                
                if ( $c ) {
                    debug( "Found for $id" );
                    push @queue_ids, $id;
                }
            }
            
            last CHECK_DEFER if $opt{ max } && $opt{ max } <= scalar @queue_ids;
        }
        close $cmd_find;
    }
    
    # look in the deferred files
    elsif ( $req_deferred ) {
        open my $cmd_find, "-|", "$opt{ cmd_find } \"$opt{ dir_deferred }\" -type f";
        
        CHECK_DEFERRED:
        while ( my $f = <$cmd_find> ) {
            chomp $f;
            
            # retreive the first 50 lines from the file .. this HAS TO BE enough
            my @head = split( /\n/, `$opt{ cmd_postcat } \"$f\" | $opt{ cmd_head } -$opt{ deferred_lines }` );
            my $c = 0;
            
            CHECK_HEADER_DEFERRED:
            foreach my $h( @head ) {
                if ( $h =~ $rx_deferred ) {
                    if ( ++$c == $req_deferred ) {
                        ( my $id ) = $f =~ /^(?:.*?\/)?([^\/]+?)$/;
                        push @queue_ids, $id;
                        last CHECK_HEADER_DEFERRED;
                    }
                }
            }
            
            last CHECK_DEFERRED if $opt{ max } && $opt{ max } <= scalar @queue_ids;
        }
        
        close $cmd_find;
    }
    
    return @queue_ids;
}



sub detach_file {
    my ( $queue_id ) = @_;
    
    my $deferred_file = "$opt{ dir_deferred }/". substr( $queue_id, 0, 1 ). "/$queue_id";
    return 0 unless -f $deferred_file;
    
    open my $cmd_postcat, "-|", "$opt{ cmd_postcat } -q \"$queue_id\"";
    open my $fh_dst, ">", "$opt{ output_dir }/$queue_id"
        or die "Cannot open destination file '$opt{ output_dir }/$queue_id' for write: $@\n";
    
    my $r = 0;
    while( my $l = <$cmd_postcat> ) {
        if ( $r ) {
            if ( $l =~ /\*\*\* HEADER EXTRACTED/ ) { last; }
            else {
                print $fh_dst $l
                    or die "Canot write to destination file '$opt{ output_dir }/$queue_id': $@\n";
            }
        }
        elsif ( $l =~ /^\*\*\* MESSAGE CONTENTS/ ) { $r++ }
    }
    close $fh_dst;
    close $cmd_postcat;
    
    return 1;
}



sub debug {
    my $msg = shift;
    my $level = shift || 1;
    my $p = join( "", map { "  " } 1..$level );
    print "$p$msg\n" if ( $opt{ dry } || $opt{ verbose } ) && $opt{ verbose_level } >= $level;
}



__DATA__

postfix-detach-from-queue <-q queue-id |  <-f <from-sender>> <-t <to-recipient>> <-r <defer-reason>> <opt>

    ! Either use -q queue-id OR on or multiple of -f, -t and/or -r !
    
    --queue-id | -i queue-id
        remove a single id or multiple ids (separated by ",") from queue
    
    --from |-f from-sender
        either a full email like email@domain.tld or a domain like domain.tld
        This is so much SLOWER then to and reason because we have to dump the
        deferred files to find this!
    
    --to | -t to-recipient
        either a full email like email@domain.tld or a domain like domain.tld
    
    --reason | -r reason
        some part of the defer reason in mailq
    
    opt:
        
        --output-dir | -o path-to-output
            all detached mails will be outputed in this directory, named as 
            their id in the queue
            Required unless dry!
    
        --mailq-dump | -q path-to-mailq-dump
            path to a mail dump .. this can be generated by:
            #> mailq > /some/file
        
        --help | -h
            this help
        
        --dry | -d
            dont act, just tell what you would do
        
        --verbose | -v
            tell what you do as in dry, but still do
        
        --verbose-level | -l 1
            verbosity level .. default is 1, the higher the more.. max is 4
            
        --do-remove | -u
            perfom the removal from the queue (via postsuper or direct, see
            below)
        
        --direct-remove | -x
            not using postsuper to remove the mail from queu but direct removal
            via "find .. -delete" which is much faster BUT postfix should not
            run or errors could occure!
        
        --max | -m 0
            max amount to found queue items to work on
            default is 0 which means infinite
        
        --deferred-lines 50
            amount of lines from head in the deferred file we dump to find the
            --to attribute until giving up. 50 is default .. more is slower
        
        --postcat-cmd path-to-postcat
            per default /usr/sbin/postcat, provide another path if you like
        
        --postsuper-cmd path-to-postsuper
            per default /usr/sbin/postsuper, provide another path if you like
        
        --find-cmd path-to-find
            per default /usr/bin/find, provide another path if you like
        
        --head-cmd path-to-head
            per default /usr/bin/head, provide another path if you like
        
        --deferred-dir path
            path to the directory with the deferred files
            default: /var/spool/postfix/deferred
        
        --defer-dir path
            path to the directory with the defer files
            default: /var/spool/postfix/defer