#!/usr/bin/perl
# ---------------------------------------------------------------------------------------------
#
# pfdiagnose.pl --- checks popfile installation for issues that could
#                   cause operating problems.
#
# This program authored by Scott W Leighton (helphand@pacbell.net)
# as a utility program for Popfile, which is Copyrighted
# by John Graham-Cumming. 
#
#    pfdiagnose.pl
#    Copyright (C) 2003  Scott W. Leighton helphand@pacbell.net
#
#    Modified May 23, 2003 - added support for version 0.19.x
#             May 24, 2003 - make corpus table file optional
#             May 24, 2003 - added missing mapping for ui_port -> html_port
#             June 20, 2003 - allow for non-existant table files and
#                             table files that only contain CRLF
#             June 21, 2003 - report if POPFile is running
#
#
#    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
#
#
#
# Popfile and components
# Copyright (c) 2001-2003 John Graham-Cumming
#
# ---------------------------------------------------------------------------------------------

use strict;
use IO::Socket;

    my @errors;
    my $fn = 'popfile.cfg';
    my %cfg;
    my $version;

    #
    # Misc subroutines to check values
    #

sub ck_port {
    my ($c, $v) = @_;
    unless ($v =~ /\d{1,5}/ ) {
        push @errors, "'$c' has illegal value '$v' (must be 1 - 65535)\n";
    } else {
        unless ($v >= 0 && $v <= 65535) {
            push @errors, "'$c' must be a number from 1 - 65535, found '$v'\n";
        }
    }
}

sub ck_numb_range {
    my ($c, $v, $l, $h) = @_;
    unless ($v =~ /\d+/ ) {
        push @errors, "'$c' must be a valid number, found '$v'\n";
    } else {
        unless ($v >= $l && $v <= $h) {
            push @errors, "'$c' must be from $l to $h, found '$v'\n";
        }
    }
}

sub ck_pf_config {
    if ( open CONFIG, "<popfile.cfg" ) {
        while ( <CONFIG> ) {
            s/(\015|\012)//g; 
            if ( /(\S+) (.+)/ ) {
                if (defined $cfg{$1}) {
                   push @errors, "Entry $1 with value $2 is duplicated (last occurance is the one used, you should remove all duplicate $1 entries)\n";
                }
                $cfg{$1}=$2;
            }
        }
        close CONFIG;
    } else {
        push @errors, "Unable to open popfile.cfg: $!";
    }
}

sub upgrade_parameter {
    my ( $parameter ) = @_;

    # This table maps from the old parameter to the new one, for example the old
    # xpl parameter which controls insertion of the X-POPFile-Link header in email
    # is now called GLOBAL_xpl and is accessed through POPFile::Module::global_config_
    # The old piddir parameter is now config_piddir and is accessed through either config_
    # if accessed from the config module or through module_config_ from outside

    my %upgrades = ( 

		     # Parameters that are now handled by Classifier::Bayes

		     'corpus',                   'bayes_corpus',
		     'unclassified_probability', 'bayes_unclassified_probability',

		     # Parameters that are now handled by POPFile::Configuration

		     'piddir',                   'config_piddir',

		     # Parameters that are now global to POPFile

		     'debug',                    'GLOBAL_debug',
		     'ecount',                   'GLOBAL_ecount',
		     'mcount',                   'GLOBAL_mcount',
		     'msgdir',                   'GLOBAL_msgdir',
		     'subject',                  'GLOBAL_subject',
                     'timeout',                  'GLOBAL_timeout',
		     'xpl',                      'GLOBAL_xpl',
		     'xtc',                      'GLOBAL_xtc',
		     'download_count',           'GLOBAL_download_count',

		     # Parameters that are now handled by POPFile::Logger

		     'logdir',                   'logger_logdir',

		     # Parameters that are now handled by Proxy::POP3

		     'localpop',                 'pop3_local',
		     'port',                     'pop3_port',
		     'sport',                    'pop3_secure_port',
		     'server',                   'pop3_secure_server',
		     'separator',                'pop3_separator',
		     'toptoo',                   'pop3_toptoo',

		     # Parameters that are now handled by UI::HTML

		     'archive',                  'html_archive',
		     'archive_classes',          'html_archive_classes',
		     'archive_dir',              'html_archive_dir',
		     'history_days',             'html_history_days',
		     'language',                 'html_language',
		     'last_reset',               'html_last_reset',
		     'last_update_check',        'html_last_update_check',
		     'localui',                  'html_local',
		     'page_size',                'html_page_size',
		     'password',                 'html_password',
		     'send_stats',               'html_send_stats',
		     'skin',                     'html_skin',
		     'test_language',            'html_test_language',
                     'ui_port',                  'html_port',
		     'update_check',             'html_update_check'
    );

    if ( defined( $upgrades{$parameter} ) && $version eq '19' ) {
        return $upgrades{$parameter};
    } else {
        return $parameter;
    }
}

  
    #
    # Main
    #

    #
    # Check the popfile.cfg file
    #

    if ( (-e $fn) && (-w $fn)) {
        ck_pf_config;
    } elsif (-e $fn) {
        push @errors, "popfile.cfg is not writable (is it marked read only?)\n";
        ck_pf_config;
    } else {
        push @errors, "popfile.cfg doesn't exist (are you running from the correct directory?)\n";
    }

    #
    # Determine if we are on version 0.19.x
    #

    defined ($cfg{bayes_corpus}) ? ($version = '19') : ($version = '18');
    $version eq '19' ? (print "Popfile v 0.19.0 or greater detected\n") : (print "Popfile v 0.18.x or less detected\n");

    #
    # See if an instance of POPFile is running
    #

    my $pid;
    if (-e "$cfg{upgrade_parameter('piddir',$version)}/popfile.pid") {
        open FILE, "<$cfg{upgrade_parameter('piddir',$version)}/popfile.pid" or die "Unable to open popfile.pid :$!";
        while (<FILE>) {
            $pid = $_;
        }
        close FILE;
        print "Found POPFile running as PID $pid\n";
    } else {
        print "Did not find a running instance of POPFile\n";
    }



    #
    # Check the corpus
    #

    my $corpus = $cfg{upgrade_parameter('corpus',$version)} || "corpus";

    push @errors, "corpus dir '$corpus' does not exist\n" unless -d $corpus;

    $corpus .= "/*";

    my @buckets = glob ($corpus);

    if (scalar @buckets == 0) {
        push @errors, "No buckets found in corpus dir '$corpus'\n";
    }

    foreach my $bucket (@buckets) {
        my $line = 0;
        if (-e "$bucket/table") {
            if (-w "$bucket/table") {
                open FILE, "<${bucket}/table" or die "Unable to open bucket $bucket table file :$!";
                while (<FILE>) {
                    s/[\r\n]//g;
                    if ( /__CORPUS__ __VERSION__ (\d+)/ ) {
                        next;
                    }
                    if ($_) {
                        $line++;
                        my @w = split /\s/,$_;
                        if (scalar( $#w) > 1 ) {
                            push @errors,"Corpus bucket '$bucket' line $line has a problem '$w[0] $w[1] $w[2]' (imbedded spaces not legal)\n";
                        } else {
                            unless ( $w[1] =~ /^\d{1,9}$/ ) {
                                push @errors,"Corpus bucket '$bucket' line $line has missing or non integer word count '$w[0] ($w[1])'\n";
                            }
                        }
                    }
                }
                close FILE;
                print "Note: $bucket/table corpus is empty\n" unless $line;
            } else {
                push @errors, "$bucket/table was not writable or doesn't exist\n";
            }
        }
        push @errors,"$bucket/params was not writable or doesn't exist\n" unless (-w "$bucket/params");
        # Per John C, color is optional, so don't squawk if it doesn't exist
        if (-e "$bucket/color") {
            push @errors,"$bucket/color was not writable\n" unless (-w "$bucket/color");
        }
        if (-e "$bucket/magnets") {
            if (-w "$bucket/magnets") {
                # See if there are magnets defined
                if ( open MAGNETS, "<$bucket/magnets" ) {
                    while ( <MAGNETS> )  {
                        s/[\r\n]//g;
             
                        # Because of a bug in v0.17.9 and earlier of POPFile the text of
                        # some magnets was getting mangled by certain characters having
                        # a \ prepended.  Code here removes the \ in these cases to make
                        # an upgrade smooth.
            
                        if ( /^([^ ]+) (.+)$/ )  {
                            my $type  = $1;
                            my $value = $2;
                            $value =~ s/\\(\?|\*|\||\(|\)|\[|\]|\{|\}|\^|\$|\.)/$1/g;
                            push @errors, "$bucket Magnet type '$type' is invalid for '$value'\n" unless $type =~ /(from)|(to)|(subject)|(cc)/i;
                            push @errors, "$bucket Magnet value '$value' has a leading space\n" unless $value =~ /^[^\s]/;
                            push @errors, "$bucket Magnet value '$value' has a trailing space\n" unless $value =~ /[^\s]$/;
                        } else {
             
                            # This branch is used to catch the original magnets in an
                            # old version of POPFile that were just there for from
                            # addresses only 
            
                            if ( /^(.+)$/ ) {
                                 my $value = $1;
                                 $value =~ s/\\(\?|\*|\||\(|\)|\[|\]|\{|\}|\^|\$|\.)/$1/g;
                                 print "$bucket magnet is oldstyle $1\n";
                            }
                        }
                    }
                    close MAGNETS;
                } else {
                    push @errors,"$bucket/magnets unable to open magnet file for reading: $!\n";
                }
            } else {
                push @errors,"$bucket/magnets was not writable\n" unless (-w "$bucket/magnets");
            }
        }
    }

    #
    # Check the key config file entries
    #

    if (defined $cfg{upgrade_parameter('port',$version)}) {
       ck_port(upgrade_parameter('port',$version),$cfg{upgrade_parameter('port',$version)});
       # Open the socket used to receive request for POP3 service
    
       my $socket = IO::Socket::INET->new( Proto     => 'tcp',
                                    $cfg{upgrade_parameter('localpop',$version)} == 1 ? (LocalAddr => 'localhost') : (), 
                                    LocalPort => $cfg{upgrade_parameter('port',$version)},
                                    Listen    => SOMAXCONN,
                                    Reuse     => 1 );
                                    
       if ( !defined( $socket ) ) {
           push @errors, $@;
           push @errors, <<EOM;
\nCouldn't start the POP3 proxy because POPFile could not bind to the 
POP3 listen port $cfg{upgrade_parameter('port',$version)}. This could be because there is another service 
using that port or because you do not have the right privileges on 
your system (On Unix systems this can happen if you are not root 
and the port you specified is less than 1024).

EOM
       } else {
           close ($socket);
       }
    } else {
       push @errors, "Did not find a '" . upgrade_parameter('port',$version) . "' entry (you must have a listening port)\n";
    }

    if (defined $cfg{upgrade_parameter('sport',$version)}) {
       ck_port(upgrade_parameter('sport',$version),$cfg{upgrade_parameter('sport',$version)});
    } elsif (defined $cfg{upgrade_parameter('server',$version)} && $cfg{upgrade_parameter('server',$version)} ) {
       push @errors, "Did not find a '" . upgrade_parameter('sport',$version) . "' entry (required when '" . upgrade_parameter('server',$version) . "' is specified)\n";
    }

    if (defined $cfg{upgrade_parameter('smtp_port',$version)}) {
       ck_port(upgrade_parameter('smtp_port',$version),$cfg{upgrade_parameter('smtp_port',$version)});
    }

    if (defined $cfg{upgrade_parameter('ui_port',$version)}) {
       ck_port(upgrade_parameter('ui_port',$version),$cfg{upgrade_parameter('ui_port',$version)});
    } else {
       push @errors, "Did not find a '" . upgrade_parameter('ui_port',$version) . "' entry (you must have a UI port defined)\n";
    }

    if (defined $cfg{upgrade_parameter('smtp_chain_port',$version)}) {
       ck_port(upgrade_parameter('smtp_chain_port',$version),$cfg{upgrade_parameter('smtp_chain_port',$version)});
    }

    if (defined $cfg{upgrade_parameter('timeout',$version)}) {
       ck_numb_range(upgrade_parameter('timeout',$version),$cfg{upgrade_parameter('timeout',$version)},0,500);
    } else {
       push @errors, "Did not find a '" . upgrade_parameter('timeout',$version) . "' entry (you must have a timeout defined)\n";
    }

    if (defined $cfg{upgrade_parameter('page_size',$version)}) {
       ck_numb_range(upgrade_parameter('page_size',$version),$cfg{upgrade_parameter('page_size',$version)},1,500);
    } else {
       push @errors, "Did not find a '" . upgrade_parameter('page_size',$version) . "' entry (should be from 20 to 500, higher numbers degrade performance)\n";
    }

    if (defined $cfg{upgrade_parameter('localpop',$version)}) {
       ck_numb_range(upgrade_parameter('localpop',$version),$cfg{upgrade_parameter('localpop',$version)},0,1);
    }

# as far as I can tell, localsmtp isn't referenced any where in the v 0.19.0 RC3 code nor
# could I find it in the v 0.18.1 code. I am assuming that it is an artifact left
# over from an earlier code version and am removing this check. SWL May 24, 2003
#    if (defined $cfg{upgrade_parameter('localsmtp',$version)}) {
#       ck_numb_range(upgrade_parameter('localsmtp',$version),$cfg{upgrade_parameter('localsmtp',$version)},0,1);
#    }

    if (defined $cfg{upgrade_parameter('localui',$version)}) {
       ck_numb_range(upgrade_parameter('localui',$version),$cfg{upgrade_parameter('localui',$version)},0,1);
    }

    if (defined $cfg{upgrade_parameter('separator',$version)}) {
       unless ($cfg{upgrade_parameter('separator',$version)} =~ /[:,\]\[~!@#$%^&*()+|]/ ) {
           push @errors, upgrade_parameter('separator',$version) . " is invalid '$cfg{upgrade_parameter('separator',$version)}'\n";
       }
    }


    #
    # Check the message directory
    #


    my $msgdir = $cfg{upgrade_parameter('msgdir',$version)} || "messages/";

    push @errors, "message dir '$msgdir' does not exist\n" unless -d $msgdir;

    $msgdir.= 'popfile*=*.msg';

    my @messages = glob ($msgdir);

    if (scalar @messages == 0) {
        push @errors, "No messages found in message dir '$msgdir'\n";
    }

    foreach my $fn (@messages) {
        unless (-w $fn) {
            push @errors, "message '$fn' was not writable\n";
        }
        my $cf = $fn;
        $cf =~ s/\.msg$/.cls/i;
        if (-e $cf ) {
           unless (-w $cf) {
               push @errors, "message '$cf' was not writable\n";
           }
        } else {
            push @errors, "message '$fn' missing corresponding .cls file '$cf'\n";
        }
    }


    #
    # Report any errors or warnings found
    #

    unless (scalar @errors == 0) {
        print "\nFOUND PROBLEMS, read this report carefully\n\n";
        foreach my $line (@errors) {
            print $line;
        }
        exit(1);
    } else {
        print "No errors or warnings detected.\n";
        exit(0);
    }