#!/usr/bin/perl

use strict;
use warnings;
use English qw( -no_match_vars );
use File::Basename;
use Getopt::Long;
use Gramene::Config;
use HTML::Lint;
use Mail::Sendmail;
use Pod::Usage;
use Readonly;
use WWW::Mechanize::Timed;
use YAML qw(Load);

$| = 1;

Readonly my $VERSION   
    => sprintf '%d.%02d', qq$Revision: 1.14 $ =~ /(\d+)\.(\d+)/;

my %parents         = ();
my %failed          = ();
my %previously_seen = ();

my $cfile   =       Gramene::Config->new;
my %options = (
    'noisy'      => 0, 
    'validate'   => 0,
    'send_email' => 0,
    'site'       => $cfile->get('link_checker')->{'site'},
    'man'        => 0,
    'version'    => 0,
    'email_from' => $cfile->get('link_checker')->{'email_from'},
    'email_to'   => $cfile->get('link_checker')->{'email_to'},
    'depth'      => 10_000_000,	#stop checking after a depth of 10,000,000 (essentially, "don't stop")
    'content_test_file'  => $cfile->get('link_checker')->{'content_test_file'},
    'white_list_file'      => $cfile->get('link_checker')->{'white_list_file'},
    'black_list_file'      => $cfile->get('link_checker')->{'black_list_file'},
);

GetOptions(
    \%options,
    'noisy',
    'validate',
    'send_email',
    'to_console',
    'site=s',
    'email_from=s',
    'email_to=s',
    'content_test_file=s',
    'white_list_file=s',
    'black_list_file=s',
    'depth=i',
    'help',
    'man',
    'version',
);

if ( $options{'help'} || $options{'man'} ) {
    pod2usage({
        -exitval => 0,
        -verbose => $options{'man'} ? 2 : 1
    });
}; 

if ( $options{'version'} ) {
    my $prog = basename( $PROGRAM_NAME );
    print "$prog v$VERSION\n";
    exit 0;
}
my ($global_tests, $url_tests) = ({}, {});

if ( $options{'content_test_file'} ) {
    open (my $test_fh, "<", $options{'content_test_file'}) or die "Could not open $options{'content_test_file'}";
    local $/ = undef;
    my $file_contents = <$test_fh>;
    close $test_fh;
    ($global_tests, $url_tests) = Load($file_contents);
}

my ($noisy, $validate, $send_email, $site, $from, $to, $depth) = @options{qw(noisy validate send_email site email_from email_to depth)};

if ( $site !~ m{^http://} ) {
    $site = 'http://' . $site;
}

$site = fix_link($site);

my $white_list = {};
my $black_list = {};
foreach my $set ((['white_list_file', $white_list], ['black_list_file', $black_list])) {
	my ($option, $list) = @$set;
	if ( $options{$option} ) {
		open (my $list_fh, "<", $options{$option}) or die "Could not open $options{$option}";
		local $/ = undef;
		my $file_contents = <$list_fh>;
		close $list_fh;
		my $url_array = Load($file_contents);
		%$list = map {($_, 1)} map {/^http/ ? $_ : $site . $_} @$url_array;

	}
}

my $message         =   undef;
my (@slow, @invalid, @failed, @content_errors);


my @links = ([$site, $depth]);

while (@links) {

	my $set = shift @links;

	my ($link, $depth) = @$set;

	#make any formatting mods we want to the link
	$link = fix_link($link);
	
	next if $depth <= 0;
    next if ! traceable_url($link);
    will_grab_link($link);

    push @links, grab_links($link, $depth - 1);

}

# failures are a special case. We need to format at the end, so we can ensure that we include all parents that reference this link as a failure.
if (@failed) {
	foreach my $link (@failed) {
		$link = format_failed_link($link);
	}
}

if (@slow || @invalid || @failed || @content_errors) {
    @slow    = ("No slow links found\n") if !@slow;
    @failed  = ("No failed found\n")     if !@failed;
    @content_errors = ("No content errors found\n") if ! @content_errors;
    $message .= "Slow links:\n===========\n" . join('', @slow) . "\n";
    $message .= "Failed links:\n=============\n" . join('', @failed) . "\n";
    $message .= "Validation errors:\n================\n" . join('', @invalid) . "\n" if @invalid;
    $message .= "Content errors:\n================\n" . join('', @content_errors) . "\n" if @content_errors;
}
else {
    $message = "No problems found";
}

#if we want to send the message AND we actually have one to send AND we have somewhere to send it, then send it...
if ($send_email && $message && $to && $from) {
    my %mail = (
        'To'        => $to,
        'From'      => $from,
        'Subject'   => "Gramene broken links on $site at " . localtime,
        'Message'   => $message,
    );

    sendmail(%mail) or die $Mail::Sendmail::error;
}
else {
    print "$message\n";
}

# this function has been modified. Instead of a list of links, it now returns a list of arrayrefs.
# the first element is the link, and the second is the depth at which it was found.
# if the depth hits 0, we stop
sub grab_links {
    my $link    = shift or die "Cannot grab links w/o url";
    my $depth   = shift;

    my $mech = WWW::Mechanize::Timed->new();
    
	return () if previously_seen_url($link);
    
    $mech->get($link);
    
    my $time = $mech->client_response_receive_time;
    
    link_is_slow($link, $time) if is_slow($time);
    
    if ($mech->status =~ /^2/) {
    
        if ( $mech->is_html ) {
            my $lint = HTML::Lint->new();
            $lint->parse( $mech->content );
            
            validation_errors($link, $lint->errors) if $lint->errors;
            
            if ($options{'content_test_file'}) {
            	check_contents($link, $mech->content);
            }
            
        }
            
        my @links = map {$_->URI->abs} $mech->links;
        foreach my $child (@links) {
			$child = fix_link($child);
            push @{$parents{$child}}, $link;
        }
        return map {[ $_, $depth - 1]} @links;
    }
    else {
        $failed{$link} = $mech->status;
        failed_link($link);
        return ();
    }
}

sub fix_link {
	my $link = shift;
	
	return $link if $white_list->{$link};
	
	#ice any anchors. For our purposes, they're superfluous.
	$link =~ s/#.+//;
	#nuke query strings, too. To try and cut down on links traversed.
	$link =~ s/\?.+//;
	#and drop any trailing slashes
	$link =~ s!/$!!;
	
	return $link;
}

# Returns a boolean value whether we think a link is slow or not.

sub is_slow {
    my $time = shift || 0;
    
    return $time > 2;
}

# These are the URLs that we assume we want to follow.

sub traceable_url {
    my $link = shift;

    return 0 if
        $link !~ m!$site!
        || $link =~ /^javascript:/
        || $link !~ /http/
        || $black_list->{$link}
        #|| $previously_seen{$link}++
    ;
    
    return 1;
}

sub previously_seen_url {
	my $link = shift;
	return $previously_seen{$link}++;
}

#the various IO functions
sub will_grab_link {
    my $link = shift;
    
    my $output = "Grabbing ($link)\n";
    
    print STDERR $output if $noisy;
    
    #$message .= $output if $validate;
}

sub link_is_slow {

    my $link        = shift;
    my $time        = shift;
    
    my $output      = "Slow link: $link - took $time seconds\n\n";
    
    push @slow, $output;
    
    print STDERR $output if $noisy;
}

sub validation_errors {

    my $page    = shift;
    my @errors  = @_;
    
    my $output  = "Validation errors on page $page\n";
    
    foreach my $error (@errors) {
        $output .= "\t" . $error->as_string . "\n";
    }

    $output .= "\n";
    
    if ($validate) {
        push @invalid, $output;
    }
    
    print STDERR $output if $noisy && $validate;
}

sub failed_link {
    my $link    = shift;
    
    push @failed, $link;
    
    print STDERR format_failed_link($link) if $noisy;
}

sub format_failed_link {
	my $link    = shift;
    my $output  = "FAILED $link: " . $failed{$link} . "\n";
    $output    .= "linked from:\n";
    my $seen    = {};
    foreach my $parent (grep {! $seen->{$_}++} @{$parents{$link}}) {
        $output .= "\t$parent\n";
    }

    $output .= "\n";
    
    return $output;
}

sub check_contents {
	my $link    = shift;
	my $content = shift;
	
	my @should_find     = @{ $global_tests->{'valid'} };
	my @should_not_find = @{ $global_tests->{'invalid'} };
	
	if ($url_tests->{$link}) {
		push @should_find,     @{ $url_tests->{$link}->{'valid'} };
		push @should_not_find, @{ $url_tests->{$link}->{'invalid'} };
	}
	
	my @return = ();
	
	foreach my $should (@should_find) {
		if ($content !~ /$should/) {
			push @return, "  Could not find text: $should";
		}
	}
	
	foreach my $shouldnt (@should_not_find) {
		if ($content =~ /$shouldnt/) {
			push @return, "  Incorrectly found text: $shouldnt";
		}
	}
	
	if (@return) {
		my $output = join("\n", "CONTENT ERROR: $link", @return) . "\n";
		push @content_errors, $output;
		print STDERR $output if $noisy;
	}
		
}
__END__

# ----------------------------------------------------

=head1 NAME

linkchecker.pl - check links on a website

=head1 VERSION

This documentation refers to linkchecker.pl version $Revision: 1.14 $

=head1 SYNOPSIS

  linkchecker.pl [options]

Options:

  --noisy       Prints out progress to STDERR as the program 
                is running.  Defaults to 0
  --validate    Includes HTML validation errors. Defaults to 0.
                WARNING - this can produce a lot of output
  --send_email  Will send out the results report to the address 
                specified in email_to in the linkchecker section of
                the config file If this flag isn't set, the final
                report will be printed to the console instead. This
                flag should be set in the crontab
  --email_from  The email address the report will be sent from.
                Defaults to the address in the config file
  --email_to    The email address the report will be sent to.
                This is usually a group mailing list.
                Defaults to the address in the config file
  --site        The site you want to run the checker on. Defaults 
                to the site in the link_checker section of the config
  --depth       depth to follow links to, based off of the front page. 
                --depth 2 follows links two deep, --depth 1 one, and so on.
                file
  --content_test_file This is a YAML file that contains information on text
                that you should or should NOT find at the given URL. Reads
                the file from the config file by default. See full docs for YAML
                file format.
  --white_list_file URLs are normally cleaned up a little bit. Anchors are dropped,
                query strings are dropped, and so on. The white list file is a YAML
                file that lets us provide links that should be viewed as is.
  --black_list_file a YAML file containing URLs that we don't want to visit on the
                site, for whatever reason.
  --help        Show brief help and exit
  --man         Show full documentation
  --version     Show version and exit

=head1 DESCRIPTION

Checks your links. By default, runs against the site listed in the
link_checker section of the gramene config file.

=head1 AUTHOR

Jim Thomason E<lt>thomason@cshl.eduE<gt>.

=head1 EXAMPLE YAML
---
valid:
  - Gramene
invalid:
  - Error
---
http://dev.gramene.org :
  valid:
    - Release #29
    - Gramene
  invalid:
    - Release #28
    - Gramene Sucks

The first YAML doc section contains global values. Things we should find on every
or no page. The second doc section refers to specific content at individual URLs.

See http://www.yaml.org/ for information on YAML docs.

=head1 COPYRIGHT

Copyright (c) 2007-2009 Cold Spring Harbor Laboratory

This library is free software;  you can redistribute it and/or modify 
it under the same terms as Perl itself.

=cut
