#!/usr/bin/perl -wT
BEGIN {
    use CGI::Carp qw(carpout);
    open(LOG, ">>/home/limbicregion/nodetracker/nodetracker.log") or
       die("Unable to open nodetracker.log: $!\n");
    carpout(LOG);
}
use strict;
use MLDBM qw(DB_File Storable);
use CGI ':standard';
use CGI::Carp 'fatalsToBrowser';
use Fcntl;
use LWP::UserAgent;
use XML::Simple;

my $base = '/home/limbicregion/nodetracker/';
my $pm = 'http://www.perlmonks.org/index.pl?node_id=';
my $user_db = $base . 'user_db';
my $page = param('page') || 'login';

my %dispatch = (
    action => \&action, 
    login  => \&login, 
    main   => \&main_page, 
);

$dispatch{$page}->();

sub action {
    validate_user();
    my $db_file = $base . param('username'); 
    tie (my %db, "MLDBM", $db_file, O_CREAT|O_RDWR, 0600)
        or die "Can't open $db_file $!\n";

    my ($action, $node) = (param('action'), param('node'));
    die "Something went terribly wrong" if ! $action;

    if ($action eq 'Add Tracked Node') {
        if (! $db{$node}) {
            my ($tree, $success) = get_node_tree($node);
            $db{$node} = $tree if $success;
        }
        set_main();
        print redirect(self_url);
    }
    elsif ($action eq 'Delete Tracked Node') {
        delete $db{ param('node') };
        set_main();
        print redirect(self_url);
    }
    elsif ($action eq 'List Tracked Node(s)') {
        set_main();
        gen_report(\%db, "Tracked Nodes", \%db, 1);
    }
    else {
       set_main();
        if ($db{$node}) {
            my ($temp, $success) = get_node_tree($node);
            my %changes;
            my (@old_nodes, @new_nodes);
            if (param('direct_only')) {
                @old_nodes =  @{ $db{$node}{base_nodes} };
                @new_nodes =  @{ $temp->{base_nodes} };
            }
            else {
                @old_nodes = grep /^\d+$/, keys %{$db{$node}};
                @new_nodes = grep /^\d+$/, keys %{$temp};
            }
            @changes{@new_nodes} = ();
            delete @changes{@old_nodes};
            my $title = "New Replies for " .  a( { href=>"$pm$node"}, $node);
            gen_report(\%changes, $title, $temp);
            $db{$node} = $temp if $success;
        }
        else {
            print redirect(self_url);
        }
    }
}


sub build_keys {
    my ($tree, $record) = @_;
    for my $key (keys %{$tree}) {
        if ($key eq 'id') {
            $record->{$tree->{id}} = {};
        }
        elsif ($key =~ /^\d+$/) {
            $record->{$key} = {};
            build_keys ($tree->{$key}, $record);
        }
        elsif ($key eq 'node') {
            build_keys ($tree->{'node'}, $record);
        }
    }
}

sub gen_report {
    my ($hash, $title, $db, $fudge) = @_;
    print header,
    start_html( -title => 'PerlMonks Node Tracker', -bgcolor => "#ffffcc" ),
    div( { -align => "center" },
        h1($title),
        p(
            a( { href=>self_url}, "Main Menu" ),
       ),
        table(
            {
            -bgcolor     => "#000000",
            -border      => "0",
            -cellpadding => "2",
            -cellspacing => "1",
            },
            Tr( { -style => "background-color:#CCCCCC" },
                th( ['Node', 'Description', 'Author', 'Node Type', 'Created'] ),
            ),
            Tr( { -style => "background-color:#CCCCCC" },
                [
                    map {
                        my $r = $fudge ? $db->{$_}{$_} : $db->{$_};
                        td([
                        a({href=>"${pm}$_", target=>'_blank'}, $_),
                        $r->{content},
                        a({href=>"${pm}$r->{author_user}", target=>'_blank'}, $r->{author_name}),
                        $r->{nodetype},
                        $r->{createtime},
                        ])
                    } sort keys %{$hash}
                ]
            ),
        ),
        p(
            a( { href=>self_url}, "Main Menu" ),
        ),
    ),
    end_html;
}

sub get_node_tree {
    my $node = shift;
    my $UA = LWP::UserAgent->new;
    my $url_1 = $pm . '180684&id=' . $node;
    my $response = $UA->request(HTTP::Request->new(GET => $url_1));
    die "Unable to contact PerlMonks" if ! $response->is_success;
    my $tree = XMLin($response->content);
    my %record;
    $record{base_nodes} = [ keys %{$tree->{node}} ] if $tree->{node};
    build_keys($tree, \%record);
    my @nodes = grep /^\d+$/, keys %record;
    my $url_2 = $pm . '37150&nodes=';
    $url_2 .= join ',' , @nodes;
    $response = $UA->request(HTTP::Request->new(GET => $url_2));
    die "Unable to contact PerlMonks" if ! $response->is_success;
    $tree = XMLin($response->content);
    if (ref $tree->{NODE} eq 'ARRAY') {
        for my $entry (@{$tree->{NODE}}) {
            $record{$entry->{node_id}} = $entry;
        }
    }
    else {
        $record{$node} = $tree->{NODE};
    }
    return \%record, $record{$node}->{lastupdate} ? 1 : 0;
}

sub login {
    print header,
    start_html( -title => 'PerlMonks Node Tracker', -bgcolor => "#ffffcc" ),
    div( { -align => "center" },
        h1( "Login to your account" ),
        start_form(
            {
            -action  => "nodetracker.cgi",
            -enctype => "application/x-www-form-urlencoded",
            -method  => "post"
            }
        ),
        table(
            {
            -bgcolor     => "#000000",
            -border      => "0",
            -cellpadding => "2",
            -cellspacing => "1",
            },
            Tr( { -style => "background-color:#CCCCCC" },
                td( strong( "User Name:" ) ),
                td( input( {
                        -maxlength => "30",
                        -name      => "username",
                        -size      => "30",
                        -type      => "text"
                } ), ),
            ),
            Tr( { -style => "background-color:#CCCCCC" },
                td( strong( "Password:" ) ),
                td( input( {
                        -maxlength => "30",
                        -name      => "password",
                        -size      => "30",
                        -type      => "password"
                } ), ),
            ),
            Tr(
                td( { -colspan => "2", -style => "background-color:#CCCCCC" },
                    input ( { -name => "newaccount", -type => "checkbox" } ),
                    " New Account ",
                ),
            ),
        ),
        p(
            input( { -type => "submit", -value => "Login" } ),
            " ",
            input( {-type => "reset" } ),
            " ",
            input( { -type => "hidden", -name => "page", -value => "main" } ),
        ),
        a( { href=>"readme.txt", target=>"_blank"}, "Help" ),
        end_form,
    ),
    end_html;
}

sub main_page {
    new_account() if param('newaccount');
    validate_user();
    print header,
    start_html( -title => 'PerlMonks Node Tracker', -bgcolor => "#ffffcc" ),
    div( { -align => "center" },
        h1( "Main Menu" ),
        start_form(
            {
            -action  => "nodetracker.cgi",
            -enctype => "application/x-www-form-urlencoded",
            -method  => "post"
            }
        ),
        table(
            {
            -bgcolor     => "#000000",
            -border      => "0",
            -cellpadding => "2",
            -cellspacing => "1",
            },
            Tr( { -style => "background-color:#CCCCCC" },
                td( strong( "Action:" ) ),
                td( scrolling_list(
                    -name    => 'action',
                    -values  => [
                                'Add Tracked Node',
                                'Delete Tracked Node',
                                'List Tracked Node(s)',
                                'Report Tracked Node',
                                ],
                    -size    => 1,
                    -default => 'Report Tracked Node',
                ), ),
            ),
            Tr( { -style => "background-color:#CCCCCC" },
                td( strong( "Node ID:" ) ),
                td( input( {
                        -maxlength => "6",
                        -name      => "node",
                        -size      => "7",
                        -type      => "text"
                } ), ),
            ),
            Tr(
                td( { -colspan => "2", -style => "background-color:#CCCCCC" },
                    input ( { -name => "direct_only", -type => "checkbox" } ),
                    " Direct Replies Only ",
                ),
            ),
            Tr(
                td( { -colspan => "2", -style => "background-color:#CCCCCC" },
                    input ( {
                        -name => "updates",
                        -type => "checkbox",
                        -disabled => 1,
                    } ),
                    " Content Change/Update ",
                ),
            ),
        ),
        p(
            input( { -type => "submit", -value => "Do it" } ),
            " ",
            input( {-type => "reset" } ),
            " ",
            input(
                {
                -type  => "hidden",
                -name  => "password",
                -value => param('password')
                }
            ),
            " ",
            input(
                {
                -type  => "hidden",
                -name  => "username",
                -value => param('username')
                }
            ),
            " ",
            input(
                {
                -type  => "hidden",
                -name  => "page",
                -value => "action", 
                }
            ),
        ),
        a( { href=>"readme.txt", target=>"_blank"}, "Help" ),
        end_form,
    ),
    end_html;
}

sub new_account {
    tie (my %user, "MLDBM", $user_db, O_CREAT|O_RDWR, 0600)
        or die "Can't open $user_db: $!\n";
    my ($name, $pass) = (param('username'), param('password'));
    if (! $user{$name}) {
        $user{$name} = $pass;
        return;
    }
    print header,
    start_html( -title => 'PerlMonks Node Tracker', -bgcolor => "#ffffcc" ),
    div( { -align => "center" },
        h1( "Sorry - Account already exists" ),
        p(
            a( { href=>"nodetracker.cgi"}, "Try Again?" ),
            " ",
            a( { href=>"readme.txt", target=>"_blank"}, "Help" ),
        ),
    ),
    end_html;
    exit;
}

sub set_main {
    param('action' => 'Report Tracked Node'); 
    param('page' => 'main'); 
}

sub validate_user {
    tie (my %user, "MLDBM", $user_db, O_CREAT|O_RDWR, 0600)
        or die "Can't open $user_db: $!\n";
    my ($name, $pass) = (param('username'), param('password'));
    return if $user{$name} && $user{$name} eq $pass;
    print redirect("nodetracker.cgi");
}

close LOG;

##</code><code>##

Security:
    The password database is stored in the clear.  While it would require a
    local account and some ingenuity, I strongly suggest you NOT reuse any of
    existing password.  I am not going to explain how, but it is also possible
    for a "bad" person with a local account to wipe out the database(s).  If
    the project gets a following, I will take steps to mitigate the risk.

Stability:
    This is extremely pre-alpha and buggy.  It was my first attempt at:
    Parsing XML
    Using MLDBM
    Generating HTML (as you can see by this readme.txt)
    etc.

Names/Passwords:
    Accounts are on a first come first serve basis.  If you have forgotten
    your account/password, you can try /msg Limbic~Region at PerlMonks.
    You will not be notified if your login credentials are incorrect.  You
    will simply be returned to the login screen.

Reports:
    There are currently two options for reports.  One allows you to get any 
    new replies for a thread that you are tracking.  The second allows you to
    get only direct replies to the node.  An important thing to realize is
    the database will be updated for all children regardless of the report.
    This means if you first try "direct replies" and then "all", you will
    not likely get anything on the second report.  Even if you do, it will
    only be any newnodes that were added since the last report.  If desired,
    I can fix this.

Content Change:
    Currently, there is no way to determine if a node has changed without 
    storing a checksum.  This would require recursively going through all
    nodes in a thread to determine if there have been any updates.  I don't
    think the added strain is justified.  If this changes, I will likely
    add support if this project gains popularity.

Load for PerlMonks:
    Every time a user adds a node to be tracked or generates a report for a
    tracked node, two calls to PerlMonks is made.  If the "gods" determine
    this is too much, the project will be shut down immediately.

Bugs/Patches/Comments:
    I am sure there are a lot of bugs.  All bug reports, patches, comments,
    and suggestions are welcome.  /msg me at PerlMonks

License/Copyright
    Copyright Joshua Gatcomb 2003.  License same as Perl