#! /usr/bin/perl

# Copyright (C) 2003 by the Free Software Foundation, Inc.
#
# 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.

my $doc = <<EOT;
Provide an authentication wrapper around htdig's htsearch when
it is running on a different machine to Mailman.

This relies on htsearch not normally being able to access per list htdig 
conf files for list archives without the intervention of this script,
which inserts a 'CONFIG_DIR' environment variable to enable that acccess.

The security available with this script is limited as it cannot
consult the user authentication information held by Mailman. Instead
we rely on the mmsearch CGI script on the Mailman server doing that and 
then passing the request to this script using an HTTP request. 

The only protection against malicious request to this script is to restrict
this script to responding only when an HTTP request originates from a machine
with a particular IP number: e.g. we only allow requests from our 'trusted'
MM server.
EOT

# Edit the following configuration variables to suit your installation.
#
# For example:
# 
#my $MAILTO = 'mailman@mailman.yourdomain.com';
#my @VALID_IP_LIST = ('192.168.1.111');
#my $HTDIG_CONF_LINK_DIR = '/mailman/run/archives/htdig';
#my $HTDIG_HTSEARCH_PATH = '/opt/www/htdig/bin/htsearch';

my $MAILTO = '';
my @VALID_IP_LIST = ();
my $HTDIG_CONF_LINK_DIR = '';
my $HTDIG_HTSEARCH_PATH = '';

# End of things for you to edit

use CGI;
use URI::Escape;
use IPC::Open2;

my %errors = ('cgi' => 'CGI problem.',
              'info' => 'Path info.',
              'list' => 'The requested list cannot be accesssed.',
              'htsearch' => 'htearch failed',
              'auth' => 'Authentication failure.',
             );

sub true_path {
    my $path = shift;
    $path =~ s/\.\.\///g;
    $path =~ s/\.\///g;
    return substr $path, 1;
}

sub GetPathPieces {
    my $path = $ENV{'PATH_INFO'};
    if ($path) {
        my @pathbits = ();
        foreach my $bit (split /\//, $path ) {
            push (@pathbits, $bit) if $bit;
        }
        return @pathbits if scalar @pathbits;
    }
    return ();
}

my @required_fields = ('method',
                       'format',
                       'sort',
                       'config',
                      );

my %allowed_fields = ('method' => 0,
                      'format' => 0,
                      'sort' => 0,
                      'config' => 1,
                      'words' => 0,
                      'submit' => 0,
                      'restrict' => 0,
                      'exclude' => 0,
                      'page' => 0,
                     );
                     
sub error_quit {
    my ($listname, $reason, $detail)  = @_;
    my $fault = $errors{$reason} . " $detail";
    my $mailto = $MAILTO;
    my $referer = $ENV{'HTTP_REFERER'} ; # 'Referer not known'
    my $uri = $ENV{'REQUEST_URI'};      # 'URI not known'
    print <<EOT;
Content-type: text/html

<HTML>
<HEAD>
    <TITLE>htdig Archives Access Failure</TITLE> 
</HEAD>
<BODY BGCOLOR="#ffffff">
<H1>htdig Archives Access Failure</H1> 
$fault
<P>
    Searching the archives of list $listname failed.
</P>
<P>
    If this problem persists then please e-mail the following information to the 
<A HREF="mailto:$mailto">$mailto</A>:
</P>
<PRE>
    $referer
    $uri
</PRE>
<HR>
</BODY>
</HTML>
EOT
    exit(0);
}

sub check_params {
    my ($listname, $query, $detail) = @_;
    my @fieldnames = $query->param();
    $detail = "$detail  fields: " . join(',', @fieldnames);
    foreach my $fieldname (@required_fields) {
        if (! $query->param($fieldname)) {
            error_quit($listname, 'cgi', " -5- $detail");
        }
    }
    my @urlencoded = ();
    foreach my $fieldname (@fieldnames) {
        if (! exists $allowed_fields{$fieldname}) {
            error_quit($listname, 'cgi', "-6- $detail|$fieldname");
        }
        my $fc = $query->param($fieldname);
        if (ref(\$fc) ne 'SCALAR') {
            error_quit($listname , 'cgi', "-8- $detail|$fieldname");
        }
        push @urlencoded, "$fieldname=" . uri_escape($fc);
    }
    return join '&', @urlencoded;
}

my $htaccess = '.htaccess';
my $htaccess_len = length($htaccess);

sub doit {
    my $request_method = $ENV{'REQUEST_METHOD'};
    my $query = CGI::new();
    my @list_info = GetPathPieces();
    if (scalar(@list_info) != 1) {
        error_quit('', 'info', '-2-');
    }
    my $path_listname = lc $list_info[0];
    my $encoded_params = check_params($path_listname, $query, 'Field count -4-');
    my $listname;
    my $cfg = $query->param('config');
    if (substr($cfg, -$htaccess_len) eq $htaccess) {
        $listname = substr $cfg, 0, length($cfg) - $htaccess_len;
    } elsif ($cfg)
    {
        $listname = $cfg;
        
    } else {
        error_quit('', 'list', '-3-');
    }
    if ($path_listname ne $listname) {
        error_quit($listname, 'list', "$path_listname:$listname");
    }
    if (scalar @VALID_IP_LIST) {
        my $remote_addr = $ENV{'REMOTE_ADDR'};
        my @request_bits = split /\./, $remote_addr;
        my $got_a_match = 0;
        my $ip;
        foreach $ip (@VALID_IP_LIST) {
            @valid_bits = split /\./, $ip;
            my $mismatch = 0;
            for (my $i=0; $i<4; $i++) {
                if ($request_bits[$i] ne $valid_bits[$i]) {
                    $mismatch = 1;
                    last;
                }
            }
            if (! $mismatch) {
                $got_a_match = 1;
                last;
            }
        }
        if (! $got_a_match) {
            error_quit($listname, 'auth', "-10- $remote_addr");
        }
    }
    $ENV{'CONFIG_DIR'} = $HTDIG_CONF_LINK_DIR;
    my $cmd = $HTDIG_HTSEARCH_PATH;
    if ($request_method eq 'POST') {
       $ENV{'CONTENT_LENGTH'} = length $encoded_params;
    } else {
        error_quit($listname, 'auth', "-11- method");
    }
    my $child_pid = open2(\*Readchild, \*Writechild, $cmd);
    print Writechild $encoded_params;
    close Writechild;
    my $response = '';
    while (<Readchild>) {
        $response .= $_;
    }
    my $rc = waitpid $child_pid, 0;
    my $exitstatus = ($? >> 8) & 0xff;
    if ($exitstatus) {
        error_quit($listname, 'htsearch', "-12- exit: $existstatus");
    }
    if (! $response) {
        error_quit($listname, 'htsearch', "-13-");
    }
    print $response;
    exit 0;
}

if ($MAILTO and -d $HTDIG_CONF_LINK_DIR and -x $HTDIG_HTSEARCH_PATH) {
    doit();
} else {
    error_quit('', 'cgi', '-14- misconfigured');
}
