#!/usr/bin/perl
##--------------------------------------------------------------------------##
##  File:
##      $Id: extract-mesg.cgi.in.dist,v 1.2 2002/07/31 04:53:21 ehood Exp $
##  Author:
##      Earl Hood       earl@earlhood.com
##  Description:
##	CGI program to extract original raw message from archive.
##	Error reporting is very minimal.  Attempts are made to check
##	against malicious input.
##--------------------------------------------------------------------------##
##  Copyright (C) 2002	Earl Hood <earl@earlhood.com>
##
##  This program is free software; you can redistribute it and/or modify
##  it under the terms of the GNU General Public License as published by
##  the Free Software Foundation; either version 2 of the License, or
##  (at your option) any later version.
##  
##  This program is distributed in the hope that it will be useful,
##  but WITHOUT ANY WARRANTY; without even the implied warranty of
##  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
##  GNU General Public License for more details.
##  
##  You should have received a copy of the GNU General Public License
##  along with this program; if not, write to the Free Software
##  Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
##  02111-1307, USA
##--------------------------------------------------------------------------##

package MHArc::extract_mesg_cgi;

use CGI::Carp;

#############################################################################
##	BEGIN: Config Section
#############################################################################

## Full pathname to where raw archives are located.
my $mbox_archive_root = '/home/itdp/WWW/mbox';

## Message media-type: This is the media-type this script will return
## to the client when serving up the raw mail message.  Note, some
## browsers actually support message/rfc822, but this could potentially
## cause XSS HTML email attacks, so use with caution.
my $message_media_type = 'text/plain';

#############################################################################
##	END: Config Section
#############################################################################

$ENV{'PATH'} = '/usr/bin:/bin:/usr/bin';

## Query argument name to contain name of archive
my $argname_archive = 'a';

## Query argument name to contain month
my $argname_month = 'm';

## Query argument name to contain message-id
my $argname_id = 'i';

## Mbox message separator: Try to be more strict than '^From ', but
## not too strict to deal with possible variations.
my $msgsep = '^From \S+.*\d+:\d+:\d+';

MAIN: {
  my $form 	= parse_input();
  my $archive 	= $form->{$argname_archive} || "";
  my $month 	= $form->{$argname_month} || "";
  my $id 	= $form->{$argname_id} || "";

  my $list_dir;
  if (($month !~ /^\d{4}(?:-\d{2})$/) ||
      ($id !~ /.\@./) ||
      ($archive !~ /\S/) ||
      ($archive =~ /\.\./) ||
      (! -d ($list_dir = join('/', $mbox_archive_root,$archive)))) {
    warn qq/Invalid arguments: a=$archive, m=$month, i=$id\n/;
    print_input_error();
    last MAIN;
  }

  my $gzipped = 0;
  my $mbox_file = join('/', $list_dir, $month);
  if (! -e $mbox_file) {
    $mbox_file .= '.gz';
    $gzipped = 1;
  }
  if (! -e $mbox_file) {
    warn qq/"$mbox_file" does not exist\n/;
    print_input_error();
    last MAIN;
  }

  local(*MBOX);
  if ($gzipped) {
    if (!open(MBOX, "gzip -dc '$mbox_file' |")) {
      warn qq/Unable to exec "gzip -dc '$mbox_file'": $!\n/;
      print_error();
      last MAIN;
    }
  } else {
    if (!open(MBOX, $mbox_file)) {
      warn qq/Unable to open "$mbox_file": $!\n/;
      print_error();
      last MAIN;
    }
  }

  local $_;
  my $cache     = '';
  my $in_header = 1;
  my $msg_id    = '';
  my $found     = 0;

  SCAN: while (<MBOX>) {
    if (/$msgsep/o) {
      $cache = '';
      $in_header = 1;
      next SCAN;
    }
    next SCAN  unless $in_header;

    if (/^\r?$/) {
      $cache = '';
      $in_header = 0;
      next SCAN;
    }

    $cache .= $_;
    if (s/^message-id:\s*//i) {
      s/\s+\Z//;
      s/[<>]//g;
      if ($_ eq $id) {
	$found = 1;
	last SCAN;
      }
      $cache = '';
      $in_header = 0;
    }
  }

  if (!$found) {
    print_not_found_error();
    close(MBOX);
    last MAIN;
  }

  print_content_type($message_media_type);
  print STDOUT $cache;
  while (<MBOX>) {
    last  if /$msgsep/o;
    print STDOUT $_;
  }
  close(MBOX);
}

#############################################################################
##	Generic subroutines for CGI use
#############################################################################

sub print_input_error {
  print_content_type('text/plain');
  print STDOUT "Input Error\n";
}

sub print_error {
  print_content_type('text/plain');
  print STDOUT "Script Error\n";
}

sub print_not_found_error {
  print_content_type('text/plain');
  print STDOUT "Message Not Found\n";
}

sub print_location {
  print STDOUT 'Location: ', $_[0], "\r\n\r\n";
}

sub parse_input {
    my($method) = ($ENV{"REQUEST_METHOD"}) || 'GET';
    my($data);
    if ($method eq "GET") {
	$data = $ENV{"QUERY_STRING"} || "";
    } elsif ($method eq "POST") {
	read(STDIN, $data, $ENV{"CONTENT_LENGTH"});
    } else {
	warn qq/Unknown method: $method/;
	return undef;
    }

    my(@pairs, $name, $value);
    local $_;

    my $form = { };
    if ($data ne '') {
	@pairs = split(/&/, $data);
	foreach (@pairs) {
	    ($name, $value) = split(/=/);
	    $name = expandstr($name);
	    $value = expandstr($value);
	    $form->{$name} = $value;
	}
    }
    $form;
}

sub print_content_type {
    my($type) = shift;
    print STDOUT "Content-type: $type\n\n";
}

sub expandstr {
    my($str) = shift;
    $str =~ tr/+/ /;
    $str =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C", hex($1))/ge;
    $str;
}

########################################################################
__END__