#!/usr/bin/perl -w
#
# This file is part of the exilog suite.
#
# http://duncanthrax.net/exilog/
#
# (c) Tom Kistner 2004
#
# See LICENSE for licensing information.
#

package exilog_parse;
use strict;
use exilog_util;
use Digest::MD5 qw( md5_base64 );

use Data::Dumper;

BEGIN {
  use Exporter;
  use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);

  $VERSION     = 0.1;
  @ISA         = qw(Exporter);
  @EXPORT      = qw(
                      &parse_message_line
                      &parse_reject_line
                      &date_to_stamp
                      &stamp_to_date
                   );

  %EXPORT_TAGS = ();
  @EXPORT_OK   = qw();
}

sub _parse_error {
  my $subj = shift || "";
  my $h = shift || {};

  $subj = _parse_delivery($subj,$h);

  m/()()/;
  if ($subj =~ / host ([^ ]+?) \[([0-9A-Fa-f:.]+?)\]\:/) {
    $h->{host_addr} = $2;
    $h->{host_dns} = $1;
  };
  $subj =~ s/^[ :]+//;
  $subj =~ s/ +$//;
  $h->{errmsg} = $subj if ($subj);

  return $subj;
};


sub _parse_deferral {
  my $subj = shift || "";
  my $h = shift || {};

  $subj = _parse_delivery($subj,$h);

  if ($subj =~ / host ([^ ]+?) \[([0-9A-Fa-f:.]+?)\]\:/) {
    $h->{host_addr} = $2;
    $h->{host_dns} = $1;
  };
  $subj =~ s/^[ :]+//;
  $subj =~ s/ +$//;
  $h->{errmsg} = $subj if ($subj);

  return $subj;
};


sub _parse_delivery {
  my $subj = shift || "";
  my $h = shift || {};


  # When +sender_on_delivery is set, cut away the F=<> part
  $subj =~ s/[PF]\=[^ :]+([ :])/$1/;

  m/()/;

  $subj =~ s/^.+?[\=\-\*][\>\=\*] (.+?)((\: )|( R\=)|( \<)|( \())/$2/;
  $h->{rcpt_final} = $1 if ($1);
  $subj =~ s/^\: //;
  $subj =~ s/^ +//;

  m/()/;
  $subj =~ s/^\((.+?)\) //;
  $h->{rcpt_intermediate} = $1 if ($1);

  m/()/;
  $subj =~ s/^\<(.+?)\> //;
  if ($1) {
    $h->{rcpt} = $1;
  }
  else {
    $h->{rcpt} = $h->{rcpt_final};
  };

  # Catch TLS DN first because it may contain C= ST= L= patterns (we don't use it)
  m/()/;
  $subj =~ s/DN="[^"]*" //;
  $h->{dn} = $1 if ($1);

  # Catch subject lines
  m/()/;
  $subj =~ s/T="[^"]*" //;
  $h->{subject} = $1 if ($1);

  m/()/;
  $subj =~ s/R\=([^ \:]+)//;
  $h->{router} = $1 if ($1);

  m/()/;
  $subj =~ s/ST\=([^ \:]+)//;
  $h->{shadow_transport} = $1 if ($1);

  m/()/;
  $subj =~ s/T\=([^ \:]+)//;
  $h->{transport} = $1 if ($1);

  m/()/;
  $subj =~ s/X\=([^ ]+)//;
  $h->{tls_cipher} = $1 if ($1);

  m/()()/;
  $subj =~ s/H\=([^ ]+) \[(.+?)\]//;
  $h->{host_dns} = $1 if ($1);
  $h->{host_addr} = $2 if ($2);

  return $subj;
};




sub _parse_arrival {
  my $subj = shift || "";
  my $h = shift || {};

  m/()/;
  $subj =~ s/^.+?\<\= (.+?) //;
  $h->{mailfrom} = $1 if ($1);

  m/()()/;
  $subj =~ s/H\=(.+?) ([A-Za-z]\=)/$2/;
  if ($1) {
    my $hstr = $1;
    m/()/;
    $hstr =~ s/\[([0-9A-Fa-f:.]+)\]$//;
    $h->{host_addr} = $1 if ($1);

    $hstr =~ s/^ +//;
    $hstr =~ s/ +$//;

    m/()/;
    $hstr =~ s/\((.+?)\)$//;
    $h->{host_helo} = $1 if ($1);

    $hstr =~ s/^ +//;
    $hstr =~ s/ +$//;

    # if we have something left over now, it must
    # be a confirmed rdns host name
    $h->{host_rdns} = $hstr if ($hstr);
  }

  m/()/;
  $subj =~ s/P\=([^ ]+)//;
  $h->{proto} = $1 if ($1);
  if ($1 =~ /^local/) {
    # U= contains local user account
    m/()/;
    $subj =~ s/U\=([^ ]+)//;
    $h->{user} = $1 if ($1);
  }
  elsif ( ($1 eq 'asmtp') || ($1 eq 'esmtpa') || ($1 eq 'esmtpsa') ) {
    # fill in both auth user and ident
    m/()/;
    $subj =~ s/A\=([^ ]+)//;
    $h->{user} = $1 if ($1);

    m/()/;
    $subj =~ s/U\=([^ ]+)//;
    $h->{host_ident} = $1 if ($1);
  }
  else {
    # U= contains remote ident
    m/()/;
    $subj =~ s/U\=([^ ]+)//;
    $h->{host_ident} = $1 if ($1);
  };

  m/()/;
  $subj =~ s/S\=([^ ]+)//;
  $h->{size} = $1 if ($1);

  m/()/;
  $subj =~ s/id\=([^ ]+)//;
  $h->{msgid} = $1 if ($1);

  m/()/;
  $subj =~ s/X\=([^ ]+)//;
  $h->{tls_cipher} = $1 if ($1);

  m/()/;
  $subj =~ s/R\=([^ ]+)//;
  $h->{bounce_parent} = $1 if ($1);

  return $subj;
};

sub _parse_reject {
  my $subj = shift;
  my $h = shift;

  m/()()/;
  $subj =~ s/H\=(.+?) \[(.+?)\] //;
  if ($1 && $2) {
    $h->{host_addr} = $2;
    my $hstr = $1;

    $hstr =~ s/^ +//;
    $hstr =~ s/ +$//;

    m/()/;
    $hstr =~ s/\((.+?)\)$//;
    $h->{host_helo} = $1 if ($1);

    $hstr =~ s/^ +//;
    $hstr =~ s/ +$//;

    # if we have something left over now, it must
    # be a confirmed rdns host name
    $h->{host_rdns} = $hstr if ($hstr);
  };

  m/()/;
  $subj =~ s/U\=(.+?) //;
  $h->{host_ident} = $1 if ($1);

  m/()()/;
  $subj =~ s/F\=(\<.*?\>) //;
  $h->{mailfrom} = $1 if ($1);
  if (exists($h->{mailfrom})) {
    unless ($h->{mailfrom} eq '<>') {
      $h->{mailfrom} =~ s/[<>]//g;
    }
  };

  m/()()/;
  $subj =~ m/\<(.+?)\>/;
  if ($1) {
    $h->{rcpt} = $1;
  };

  return $subj;
};


# Parse a reject line
sub parse_reject_line {
  my $subj = shift || "";
  chomp($subj);

  my $h = { 'table' => 'rejects' };

  # There are 2 types of rejects: one without a message ID (pre-DATA)
  # and one with message ID (post-DATA). Try the latter first.

  m/()()()()/;
  $subj =~ m/(\d{4}-\d\d-\d\d) (\d\d:\d\d:\d\d( [-+]\d{4})?) ([A-Za-z0-9]{6}-[A-Za-z0-9]{6}-[A-Za-z0-9]{2}) (H=.*)$/;
  my ($date,$tod,$msgid,$line) = ($1,$2,$4,$5);
  if ($date && $tod && $msgid && $line) {
    # line with message id
    $h->{data}->{message_id} = $msgid;
  }
  else {
    # try format without message id
    m/()()()()/;
    $subj =~ m/(\d{4}-\d\d-\d\d) (\d\d:\d\d:\d\d( [-+]\d{4})?) (H=.*)$/;
    ($date,$tod,$line) = ($1,$2,$4);
    unless ($date && $tod && $line) {
      # unparsable
      return 0;
    };
    # Add custom "Message ID" hash
    $h->{data}->{message_id} = substr(md5_base64($date,$tod,$line),0,16);
  };

  $h->{data}->{timestamp} = date_to_stamp($date,$tod);
  $h->{data}->{errmsg} = substr(_parse_reject($line,$h->{data}),0,255);

  return $h;
};


# Parse line that relates to an actual message.
sub parse_message_line {
  my $subj = shift || "";
  chomp($subj);

  # Exception: do not use "retry time not reached [for any host]".
  # It's just too spammy and gets logged by default.
  return 0 if ($subj =~ /retry time not reached$/);
  return 0 if ($subj =~ /retry time not reached for any host$/);

  # Grab date, time and message id
  $subj =~ m/(\d{4}-\d\d-\d\d) (\d\d:\d\d:\d\d( [-+]\d{4})?) ([A-Za-z0-9]{6}-[A-Za-z0-9]{6}-[A-Za-z0-9]{2}) (([^ ]+).*)$/;
  my ($date,$tod,$msgid,$line,$type) = ($1,$2,$4,$5,$6);
  $line =~ s/^ +// if (defined($line));
  unless ($date && $tod && $msgid && $line && $type) {
    # non-message based line
    return 0;
  };

  # removed fttb, too much overhead
  #my $h = { 'data' => { 'line' => $line, 'message_id' => $msgid } };
  my $h = { 'data' => { 'message_id' => $msgid } };


  if ($type eq '<=') {
    $h->{table} = 'messages';
    $h->{data}->{timestamp} = date_to_stamp($date,$tod);
    _parse_arrival($subj,$h->{data});
  }
  elsif (($type eq '=>') || ($type eq '->') || ($type eq '*>')) {
    $h->{table} = 'deliveries';
    $h->{data}->{timestamp} = date_to_stamp($date,$tod);
    _parse_delivery($subj,$h->{data});
  }
  elsif ($type eq '**') {
    $h->{table} = 'errors';
    $h->{data}->{timestamp} = date_to_stamp($date,$tod);
    _parse_error($subj,$h->{data});
  }
  elsif ($type eq '==') {
    $h->{table} = 'deferrals';
    $h->{data}->{timestamp} = date_to_stamp($date,$tod);
    _parse_deferral($subj,$h->{data});
  }
  elsif ($type eq 'Completed') {
    $h->{table} = 'messages';
    $h->{data}->{completed} = date_to_stamp($date,$tod);
  }
  else {
    if ($line =~ /^H\=.*rejected/) {
      # looks like a reject line after DATA, pass on
      return 0;
    };

    $h->{table} = 'unknown';
    $h->{data}->{timestamp} = date_to_stamp($date,$tod);
    $h->{data}->{line} = substr($line,0,255);
  };

  return $h;
};

1;