# -----------------------------------------------------------------------------------------------
# Title:  Web Infrastructure Test Script
# Author: Dean Stringer (deeknow @ pobox.com)
# Description/Purpose:
#
#    Uses Test::More to perform a heap of web infrastructure and service tests on
#    the local host to check the health of the web system. 'Use's lots of dependency
#    Perl modules in ways we typically use them in CGI and shell scripts to see
#    if theyre present and operating OK
#
#    Calling switches:
#	-e	run EMail tests only
#	-s	run MySQL tests only
#	-w	run Web fetches only
#	-x	run XML tests only
#
#   local /etc/hosts overrides
#     need these to test a local domain (change IP to local machine address)
#	10.0.0.1           mydomain.com
#
# -----------------------------------------------------------------------------------------------
# Possible Mods:
#    - DAV PUT or property fetch
#    - smbmounts
#    - SCP from/to remote place
#    - SASE CMS something
#    - xsltproc
#    - XML::Writer
#    - do LWPPosts or whateva to enugh PHP scritps that cover PHP PEAR modules
#        (eg /language/intranet/quotation.php)
# -----------------------------------------------------------------------------------------------
use strict;
use vars qw(
    $xmlString
    $htmlString
    $htmlPage
    $dateString
    $dbh
    $sth
    $cookie
    $hostSuffix
    );

my %hostSuffixes = (
    'test.com' => '-test',
    'live.com' => '',
);
$hostSuffix = $hostSuffixes{ $ENV{HOSTNAME} };


use Getopt::Std;  # used in loads of cron/command-line scripts
our( $opt_w, $opt_x, $opt_d, $opt_e, $opt_c, $opt_h, $opt_v);
getopts('wxdechv');

# if any switches are set then we're in conditional mode
# so only run selected test batches
my $conditional = 1;

if ($opt_h) {
    print "Syntax: perl $0 [switches]\n" . 
        "\t-e\t(e)mail tests only\n" .
        "\t-d\t(d)atabase tests only\n" .
        "\t-w\t(w)eb tests only\n" .
        "\t-x\t(x)ml tests only\n" .
        "\t-x\t(v)ersion checks and dependencies only\n" .
        "";
    exit;
}

if ($opt_v) {
    checkVersions();
    exit;
}

use Test::More;
if ($opt_e) { plan tests => 4 }
elsif ($opt_d) { plan tests => 6 }
elsif ($opt_w and $opt_c) { plan tests => 14 }
elsif ($opt_w) { plan tests => 10 }
elsif ($opt_x) { plan tests => 13 }
else { plan tests => 47; # run 'em all
	$conditional = 0;
}

# generic modules, needed by many so load now
use_ok('HTML::Entities');


if (! $conditional) {
	# these are all generic tests we dont wanna group any special way
	ok(test_filesExist(), 'Dependency files check');
	use_ok('CGI');
	use_ok('Date::Calc');
	ok(test_date(), 'Date functions');
}

if ($opt_c) {    # prompt for a username/password pair and generate a Cookie
    use_ok('Term::ReadKey');
    use_ok('HTTP::Cookies');
}

# my[s]ql tests
if ($opt_d || ! $conditional) {
	use_ok('DBI');
	ok(test_DBI_connect(), 'DBI connect');
	ok(test_DBI_insert(), 'MySQL insert');
	ok(test_DBI_select(), 'MySQL select');
}

# [w]eb tests
if ($opt_w || ! $conditional) {
	use_ok('HTML::Parser');
	use_ok('HTML::TokeParser');
	use_ok('LWP::Simple');
    ok(test_contentTypes(), 'Content Types');
	ok(test_LWP_fetch(), 'LWP webpage fetch');
    use_ok('LWP::UserAgent');
	ok(test_redirects(), 'LWP redirect checks');
	ok(test_LWP_POST(), 'LWP POST');
}

if (! $conditional) {
	ok(test_HTML_Parser(), 'HTML Parse');
	use_ok('CGI::Carp');
	ok(test_Carp(), 'Carp warning logged');
	use_ok('BrowserDetect');
	use_ok('Digest::MD5');
	ok(test_MD5(), 'MD5 Digest generation');
	use_ok('SOAP::Lite');
	ok(test_SOAP(), 'SOAP request');
	use_ok('GD');
	ok('test_GD', 'GD image creation');
	use_ok('HTML::Template');
}

# [x]ml tests
if ($opt_x || ! $conditional) {
	use_ok('XML::RSS');
	is(test_RSS(), 1, 'Creating RSS object');
	use_ok('XML::Parser');
	ok(test_XML_Parser(), 'XML::Parser parse');
	use_ok('XML::XPath');
	ok(test_XML_XPath(), 'XPath query');
	use_ok("XML::LibXML");
	use_ok("XML::LibXSLT");
	ok(test_LibXML_Parser(), "XML::LibXML parse");
	use_ok("XML::Sablotron");
	ok(test_sablotron(), 'Sablotron');
	#print $xmlString;
}

# [e]mail tests
if ($opt_e || ! $conditional) {
	use_ok('MIME::Lite');
	ok(test_MIMELite(), 'MIME::Lite email send');
}

sub checkVersions {
# run thru all the modules we know we use and check their versions are at
# least some minimal value. also report on modules that each of these are
# dependent on (ignoring some common/core modules we dont care about or
# assume exist)
    use Module::Info;
    my %moduleInfo = (
        'CGI' => 3.05,
        'CGI::Carp' => 1.28,
        'Date::Calc' => 5.4,
        'Digest::MD5' => 2.33,
        'DBI' => 1.46,
        'GD' => 2.19,
        'Getopt::Std' => 1.05,
        'HTTP::Cookies' => 1.39,
        'HTML::Entities' => 1.27,
        'HTML::Parser' => 3.38,
        'HTML::Template' => 2.7,
        'HTML::TokeParser' => 2.28,
        'LWP::Simple' => 1.41,
        'LWP::UserAgent' => 2.033,
        'MIME::Lite' => 3.01,
        'Module::Info' => 0.27,
        'SOAP::Lite' => 0.6,
        'Term::ReadKey' => 2.21,
        'Test::More' => 0.5,
        'XML::LibXML' => 1.58,
        'XML::LibXSLT' => 1.57,
        'XML::Parser' => 2.34,
        'XML::RSS' => 1.05,
        'XML::XPath' => 1.13,
    );
    print "Checking versions...\n";
    my $notOK = 0;
    my @coreToIgnore = ( 'IO::File', 'vars', 'strict', 'Exporter', 'DynaLoader',
                'AutoLoader', 'overload', 'Carp', 'warnings', 'constant');
    my @usedMods = sort keys %moduleInfo;
    foreach my $modName (@usedMods) {
        my $mod = Module::Info->new_from_module($modName) || die "Cant find $modName";
        print "$modName -> v" . $mod->version;
        if ($mod->version >= $moduleInfo{$modName}) {
            print "   ok\n";
        } else {
            print "   NOT OK!!! - expecting v$moduleInfo{$modName}\n";
            $notOK++;
        }
        my @used = $mod->modules_used;
        foreach my $dependency (sort @used) {
            my $thisOneCore = 0;
            # dont care about the common core modules being use'd so dont show them
            foreach (@coreToIgnore) {
                if ($dependency eq $_) { $thisOneCore++; last; }
            }
            foreach (@usedMods) {
                if ($dependency eq $_) { $thisOneCore++; last; }
            }
            unless ($thisOneCore) { print "\t- $dependency\n"; }
        }
    }
    if ($notOK == 0) { print "\nALL VERSIONS OK\n"; } 
    else { print "\n$notOK MODULES ARE INCORRECT VERSION\n"; }
    
}

sub test_sablotron {
	# simple command line transform which outputs a count value of '3'
	my $file = 'sabtest.txt';
	system("/usr/local/bin/sabcmd Test.xslt Test.xml > $file");
	unless (open(INFILE, "< $file")) {
		return 0;
	} 
	my $count = <INFILE>;
	close (INFILE);
	return 0 unless $count == '3';
	return 1;
}

sub test_GD {
    # the GD library is used in a couple of apps, we could create an
    # image and save to file here and maybe attach to the MIME::Lite
    # message later, but this will do for now
    my $im = new GD::Image(100,100) || return 0;
    return 1;
}

sub test_SOAP {
my $paperDetails = SOAP::Lite
    -> uri('/TimeTable')	# class name must match the Package
    -> proxy('http://my-soap-server.com/cgi-bin/soap/tt/server.cgi')
    -> getPaperTitle('COMP123');
    my @params = $paperDetails->paramsout();
    return 0 unless (scalar @params > 1);   # expecting two params 
    return 1;
}

sub test_MIMELite {
    my $recepient = 'yourname@yoursite.com';
    my $msg = new MIME::Lite
        From     => 'testname@yoursite.com',
        To       => $recepient,
        Subject  => "$0 test [$dateString]",
        Type	=> 'text',
        Data    => "Here is a test message sent from the $0 script";
    $msg->send() || return 0;
    print "Please check for email send to $recepient\n";
    return 1;
}

sub test_MD5 {
    my $textDigest = Digest::MD5::md5_hex('GeorgeBush');
    my $expectedHash = 'cd39803b50c2d962d9b06e23b6ec57ff';
    return 0 unless $textDigest eq $expectedHash;
    return 1;
}


sub test_XML_XPath {
    # use 'exists' to do an XPath query on the title that should be present
    # in the RSS XML file we generated earlier
    my $xp = XML::XPath->new(xml => $xmlString);
    return 0 unless $xp->exists('/rdf:RDF/channel/title');
    return 1;
}

sub test_Carp {
    # normally this would be routed to the Apache error log, but as we're
    # running this from the command-line we'll probably see it on STDERR
    # in the console
    warn(": test warning");
    return 1;
}


sub test_LWP_fetch {
    # fetch default index page HTML from localhost port 80
    # should see an entry in the Apache access log with a
    # useragent string like "lwp-trivial/1.41"
    # my $fetchedHTML = get('http://localhost/');
    
    my %localhostExpectedTitles = (
        'myserver-1.com' => '1 Home Page',
        'myserver-2.com' => '2 Home Page',
    );

    my %pages = (
       localhost => { 
		url => 'http://' . $ENV{HOSTNAME},
		title => $localhostExpectedTitles{ $ENV{HOSTNAME} }
	},
       site2 => {
		url => 'http://www' . $hostSuffix . '/',
		title => 'The Main Site'
	},
       site1 => {
		url => 'http://site1' . $hostSuffix . '/',
		title => 'The Department of Silly alks'
	},

    );
    foreach my $page (keys %pages) {
        my $fetchedHTML = get($pages{$page}->{url});
    	unless (defined $fetchedHTML) {
		print "Failed to fetch $pages{$page}->{url}\n";
		return 0;
        }	
        my $title = test_HTML_Parser($fetchedHTML) || '';
		unless ($title eq $pages{$page}->{title}) {
			print "Title mismatch: expected '$pages{$page}->{title}' ... received '$title'\n";
            }
    }
    return 1;
}


sub test_LWP_POST {

    my %pages = (
        script1 => {
            url => 'http://www' . $hostSuffix . '.mysite.com/cgi-bin/script.cgi',
            title => 'Response from CGI',
            form => {
                year => '2005',
                details => 'all',
                search => 'some string',
            }
        },
        script2 => {
            url => 'http://www' . $hostSuffix . '.mysite.com/cgi-bin/script.pl',
            title => 'Form Processed',
            form => {
                subject => 'TestBot Message',
                recipient => 'me@mysite.com',
                content => 'did this arrive?',
            }
        },
    );
    my $browser = LWP::UserAgent->new();
    $browser->timeout(10);
    
    my $returnResult = 1;

    foreach my $page (keys %pages) {
        my $response = $browser->post($pages{$page}->{url}, $pages{$page}->{form});
        if ($response->is_error) {
            print "Failed to fetch $pages{$page}->{url}\n";
            $returnResult = 0;
        }
        my $title = test_HTML_Parser($response->content) || '';
		unless ($title eq $pages{$page}->{title}) {
			print "Title mismatch: expected '$pages{$page}->{title}' ... received '$title'\n";
			$returnResult = 0;
        }
    }
    return $returnResult;
}

sub test_contentTypes {
    my %pages = (
       html => {
		url => 'http://www' . $hostSuffix . '.mysite.com/',
		type => 'text/html'
        },
       png => {
		url => 'http://www' . $hostSuffix . '.mysite.com/thing.png',
		type => 'image/png'
        },
       gif => {
		url => 'http://www' . $hostSuffix . '.mysite.com/thing.gif',
		type => 'image/gif'
        },
       xml => {
		url => 'http://www' . $hostSuffix . '.mysite.com/thing.xml',
		type => 'text/xml'
        },        
       txt => {
		url => 'http://www' . $hostSuffix . '.mysite.com/thing.txt',
		type => 'text/plain'
        },     
       ppt => {
		url => 'http://www' . $hostSuffix . '.mysite.com/thing.ppt',
		type => 'application/vnd.ms-powerpoint'
        },     


    );
    my $returnResult = 1;
	foreach my $page (keys %pages) {
        # head() returns an array, 1st element is the content_type which is what we wanna test
        my @results = head( $pages{$page}->{url}  );
        my $contentType = $results[0];
        if ($pages{$page}->{type} ne $contentType) {
            print "Error fetching: " . $pages{$page}->{url} . "\n" . 
                "Type was '" . $contentType . "'" .
                ", expecting '" . $pages{$page}->{type} . "'\n";
            $returnResult = 0;
        }
    }
    return $returnResult;

}

sub test_redirects {  
    my %pages = (
       page404 => {
		url => 'http://www' . $hostSuffix . '.mysite.com/bogus.html',
		status => '404'
	},
       page403 => {
		url => 'http://www' . $hostSuffix . '.mysite.com/perl-bin/',
		status => '403'
	},
       redirect1 => {
		url => 'http://www' . $hostSuffix . '.mysite.com/redirect.shtml',
		status => '301'
	}
    );
    my $returnResult = 1;
    my $browser = LWP::UserAgent->new();
    $browser->timeout(10);
    #$browser->max_redirect(0);
    $browser->agent('My TestBot');
    foreach my $page (keys %pages) {
        # create a request object coz we wanna use it in the simple_request following
        my $req = HTTP::Request->new( GET => $pages{$page}->{url} );
        # use simple_request coz we dont want to redirect, we wanna see the initial response
        my $response = $browser->simple_request( $req  );
            if ($pages{$page}->{status} ne $response->code) {
                print "Error fetching: " . $pages{$page}->{url} . "\n" . 
                    "Status was '" . $response->code . "'" .
                    ", expecting '" . $pages{$page}->{status} . "'\n";
                $returnResult = 0;
            }
            if (($pages{$page}->{status} =~ /301|304/) and ! $response->is_redirect) {
                print "Should be redirecting but is not.\n";
            }
    }
    return $returnResult;
}

sub doAuthFetch {
    my %pages = (
       webteamAdmin => {     # SSI/Apache check
		url => 'http://www' . $hostSuffix . '.mysite.com/admin/',
		title => "Auth Requiring Page"
	},
       userDetailsPHP => {     # PHP check
		url => 'http://www' . $hostSuffix . '.mysite.com/edit.php',
		title => "Auth Requiring PHP Page"
	},
       weblinks => {     # Perl/CGI check
		url => 'http://www' . $hostSuffix . '.mysite.com/edit.cgi',
		title => "Auth Requiring CGI Page"
	},
    );
    my $browser = LWP::UserAgent->new();
    $browser->timeout(10);

    my $cookie_jar = HTTP::Cookies->new( autosave => 1);
    $cookie_jar->set_cookie( '', 'Cookie', $cookie, '/', 'mysite.com', '80', 
                0, 0, 100, 0, {} );
    #print "cookie" . $cookie_jar->as_string;
    $browser->cookie_jar($cookie_jar);

    foreach my $page (keys %pages) {
        my $response = $browser->get( $pages{$page}->{url}  );
        if ($response->is_error()) {
            print "Couldnt fetch page\n";
            print $response->status_line;
            return 0;
        } else {
            my $fetchedHTML = $response->content();
            unless (my $title = test_HTML_Parser($fetchedHTML)) {
                print "no title found\n";
            } else {
                unless ($title eq $pages{$page}->{title}) {
                    print "Title mismatch: expected '$pages{$page}->{title}' ... received '$title'";
                }
            }
        }
    }
    return 1;
}


sub getPassword {
    print "Password: ";
    use Term::ReadKey;
    ReadMode 2; # echo off
    my $thisChar = '';
    my $key = undef;
    my $pwd = '';
    while ($thisChar ne "\n") {
        while (not defined ($key = ReadKey(-1))) {
            # No key yet so loop
        }
        $thisChar = $key;
        $pwd .= $key;
    }
    ReadMode 0; # Reset tty mode before exiting
    chomp($pwd);
    print "\n";
    return $pwd;
}

sub test_HTML_Parser {
    my $html = shift;
    unless ($html) { $html = $htmlPage; }
    # parse the <title> tag from the previously generated/saved HTML page
    my $parser = HTML::TokeParser->new(\$html);
    $parser->get_tag('title');
    my $title = $parser->get_trimmed_text('/title');
    return '' unless (length($title) > 0);
    return $title;
}

sub test_date {
    # DateCalc is used by a number of apps, calling Today should be enough
    # save the date for use by some other tests
    $dateString = sprintf("%d-%d-%d", Date::Calc::Today());
    return 0 unless ($dateString);
    return 1;
}


sub test_DBI_connect {
    # make a DBI connection and select some records 
    my $database = "mydb";
    my $servername = "localhost";
    my $dataSource = "DBI:mysql:$database:$servername";
    my $username = "myuser";
    my $passwd = "mypass";
    $dbh = DBI->connect($dataSource, $username, $passwd);
    return 0 unless $dbh;
    return 1;
}


sub test_DBI_insert {
    # do a simple INSERT
    my $sql = "INSERT INTO mytable VALUES('this','that','another')";
    $sth = $dbh->prepare($sql);
    return 0 unless $sth;
    $sth->execute or return 0;
    return 1;
}

sub test_DBI_select {
    # do a simple SELECT
    my $sql = "SELECT * FROM mytable LIMIT 10";
    $sth = $dbh->prepare($sql);
    return 0 unless $sth;
    $sth->execute or return 0;
    return 0 unless ($sth->rows() > 1);
    disconnectDbase($dbh, $sth);
    return 1;
}

sub test_filesExist {
    # check that certain file-dependencies are in place, mostly stuff
    # like templates
    my %files2Check = (
	templateText3 => "/home/www/include/text3.tmpl",
	template3 => "/home/www/include/cgi3.tmpl",
	templateText4 => "/home/www/include/text4.tmpl",
	template4 => "/home/www/include/cgi4.tmpl"
    );
    foreach my $file (keys %files2Check) {
        if (! -e $files2Check{$file}) {
            print "Dependecy file $files2Check{$file} not found\n";
            return 0;
            }
    }
    return 1;
}


sub test_RSS {
    # create a standard RSS container and add an item to it,
    # saving to $xmlString var so we can access it in later tests
    my $rss = XML::RSS->new( version => '1.0' );
    my $feedName = "this feed";
    $rss->channel(
	title          => HTML::Entities::encode($feedName),
	link           => "http://www.mysite.com",
	language       => 'en-nz',
	pubDate        => $dateString
	);
    $rss->add_item(
        title       => "title",
        link        => "http://url.com",
        description => "desc"
        );
    $xmlString = $rss->as_string;
    return 1;
}

sub test_XML_Parser() {
    # try parsing the XML we built using test_RSS, this also tests operation of
    # the underlying expat engine which XML::Parse relies on
    my $parser = new XML::Parser;
    $parser->parse($xmlString) || return 0;
    return 1;
}

sub test_LibXML_Parser() {
    # try parsing the XML we built using test_RSS, this also tests operation of
    # the underlying expat engine which XML::Parse relies on
    my $parser = XML::LibXML->new();
    my $doc = $parser->parse_string($xmlString);
    return 0 unless ($doc->version() eq '1.0');
    return 1;
}