#!/usr/bin/perl -Tw
#-----------------------------------------------------------------#
#  my_portal
#  pudge
#  See POD after __END__
#
#  Created:       Chris Nandor (pudge@pobox.com)       09 Nov 1999
#  Last Modified: Cesar Mendoza (mendoza@kitiara.org)  29 Feb 2000
#-----------------------------------------------------------------#
use strict;
use AnyDBM_File;
use CGI ':all';
use CGI::Carp 'fatalsToBrowser';
use Data::Dumper;
use Date::Parse;
use Date::Format;
use Fcntl;
use File::Basename;
use Getopt::Std;
use LWP::Simple qw[mirror is_error];
use Symbol;
use Time::Local;
require XML::RSS;

$ENV{PATH} = '';

#==================
# set defaults
#==================

my %conf = (
    prog => '/cgi-bin/my_portal.pl',  # $ENV{SCRIPT_NAME}
    admin => 'mendoza@kitiara.org',
    src => 'http://www.news.perl.org/my_portal/my_portal.plx',
    dir => '/usr/local/my_portal/portal',
    cookieDom => 'www.kitiara.org',
    cookieNam => 'KitiaraNews',
    cookieExp => '+1y',
    cookiePath => '/cgi-bin/my_portal.pl',
    embeded => 1,
    logger => '/cgi-bin/go/',
    defaults => {
        1  => '1,1', 2  => '3,1',
        3  => '1,8', 4  => '1,2',
        5  => '3,2', 6  => '2,2',
        7  => '3,3', 8  => '1,4',
		9  => '1,3', 10 => '2,3',
		11 => '3,4', 12 => '2,1',
        back   => '#FFFFFF',
        fore   => '#CCCCFF',
        btext  => '#000000',
        ftext  => '#000000',
        'link' => '#000088',
        vlink  => '#880000',
        showdesc => 'CHECKED',
        save_cookie => 'CHECKED',
    	desc => {
        	1  => 0, 2  => 0,
	        3  => 0, 4  => 0,
	        5  => 0, 6  => 1,
	        7  => 0, 8  => 0,
			9  => 0, 10 => 0,
			11 => 0, 12 => 0
	    },
    },
);

$conf{imgurl} = "/portal_img";
$conf{imgdir} = "$conf{dir}/img";
$conf{rdfdir} = "$conf{dir}/rdf";
$conf{rdff}   = "$conf{dir}/rdfs";
$conf{userf}  = "$conf{dir}/users";

unless ($ENV{SERVER_SOFTWARE}) {
    do_cl();
    exit;
}

tie my %rdfs,  'AnyDBM_File', $conf{rdff},  O_RDONLY, 0444 or die $!;
$conf{rdfs}  = \%rdfs;

#==================
# do main
#==================
while (my $cgi = new CGI) {

    if ($conf{embeded}) {
        print tableHeader();
        print display_channels($conf{defaults});
		print tablefooter();
		exit;
	}

    if ($cgi->param('dumpusers')) {
        tie my %users, 'AnyDBM_File', $conf{userf}, O_RDWR|O_CREAT, 0644 or die $!;
        print header('text/plain');
        print Dumper \%users;
        untie %users;
        exit;
    }
    my($user) = $cgi->cookie(-name => $conf{cookieNam});
    $user ||= '';
    my $prefs = get_prefs($user);

    my($un, $pw) = ($cgi->param('un'), $cgi->param('pw'));
    if ($cgi->param('dologin') && $un && $pw) {
        my $nuser = join '|', crypt($pw, $un), $un;
        my $ok = userOK($un, $pw);

        $user = $ok ? $nuser : '';
        $prefs = get_prefs($user, ($ok ? $prefs : undef));

        print myhead($cgi, $user, $prefs, 1),
            ($ok ? '' : <<EOT),
    <TR><TD COLSPAN="3" ALIGN="CENTER">
        <H2>Incorrect password for user $un</H2>
    </TD></TR>
EOT
            display_channels($prefs);

    } else {
        ($user, $prefs) = set_config($cgi, $user, $prefs) if $cgi->param('set');

        if ($cgi->param('login')) {
            print myhead($cgi, $user, $prefs);
            print show_login($user, $prefs);

        } elsif ($cgi->param('config')) {
            print myhead($cgi, $user, $prefs);
            print show_config($user, $prefs);

        } else {
            print myhead($cgi, $user, $prefs, 1);
            print display_channels($prefs);
        }
    }

    print myfoot();

    exit;
}


#==================
# main displays
#==================

sub show_login {
    my($user, $prefs) = @_;

    return <<EOT;
    <TR>
        <TD ALIGN="CENTER">
            <FORM METHOD="POST" ACTION="$conf{prog}">
            <P>
                Enter username and password to log in or create new login.
            </P>

            <P>
                Username: <INPUT TYPE="text" NAME="un">
                Password: <INPUT TYPE="password" NAME="pw">
            </P>

            <P>
                <INPUT TYPE="hidden" NAME="dologin" VALUE="1">
                <INPUT TYPE="submit" VALUE="Login">
            </P>
            </FORM>
        </TD>
    </TR>
EOT

}

sub show_config {
    my($user, $prefs) = @_;
    my $return = <<EOT;
    <TR>
        <TD>
<FORM METHOD="GET" ACTION="$conf{prog}">
<INPUT TYPE="hidden" NAME="set" VALUE="1">
<TABLE BORDER="0" ALIGN="CENTER">

    <TR>
        <TH WIDTH="200">Channel</TH>
        <TH>Column</TH>
        <TH>Row</TH>
    </TR>

EOT

    foreach my $i (sort {$conf{rdfs}->{$a} cmp $conf{rdfs}->{$b}} keys %{$conf{rdfs}}) {
        my($c, $l) = split m/\|/, $conf{rdfs}->{$i};
        my($m, $r) = split m/,/, $prefs->{$i} if exists $prefs->{$i};
        my $k = 'CHECKED' if exists $prefs->{$i};
        $m ||= ''; $r ||= '';

        $return .= <<EOT;
    <TR>
        <TD>
            <INPUT TYPE="checkbox" NAME="channels" VALUE="$i" $k>
            <A HREF="$l">$c</A>
        </TD>

        <TD>
            <SELECT NAME="col-$i">
                <OPTION>$m</OPTION>
                <OPTION>1</OPTION>
                <OPTION>2</OPTION>
                <OPTION>3</OPTION>
            </SELECT>
        </TD>

        <TD>
            <SELECT NAME="row-$i">
                <OPTION>$r</OPTION>
                <OPTION>1</OPTION>
                <OPTION>2</OPTION>
                <OPTION>3</OPTION>
                <OPTION>4</OPTION>
                <OPTION>5</OPTION>
                <OPTION>6</OPTION>
                <OPTION>7</OPTION>
                <OPTION>8</OPTION>
                <OPTION>9</OPTION>
            </SELECT>
        </TD>
    </TR>

EOT
    }

    $return .= <<EOT;
    <TR><TD COLSPAN="3">&nbsp;</TD></TR>

    <TR><TD COLSPAN="3">
        <INPUT TYPE="checkbox" NAME="showdesc" VALUE="CHECKED" $prefs->{showdesc}>
        Show item descriptions
    </TD></TR>

    <TR><TD COLSPAN="3">
        <INPUT TYPE="checkbox" NAME="save_cookie" VALUE="CHECKED" $prefs->{save_cookie}>
        Save cookie
    </TD></TR>

    <TR><TD>
            Background color
        </TD><TD COLSPAN="2">
            <INPUT TYPE="text" NAME="back" VALUE="$prefs->{back}">
    </TD></TR>
    <TR><TD>
            Foreground color
        </TD><TD COLSPAN="2">
            <INPUT TYPE="text" NAME="fore" VALUE="$prefs->{fore}">
    </TD></TR>
    <TR><TD>
            Text color
        </TD><TD COLSPAN="2">
            <INPUT TYPE="text" NAME="btext" VALUE="$prefs->{btext}">
    </TD></TR>
    <TR><TD>
            Link color
        </TD><TD COLSPAN="2">
            <INPUT TYPE="text" NAME="link" VALUE="$prefs->{'link'}">
    </TD></TR>
    <TR><TD>
            Visited link color
        </TD><TD COLSPAN="2">
            <INPUT TYPE="text" NAME="vlink" VALUE="$prefs->{vlink}">
    </TD></TR>

    <TR>
        <TD COLSPAN="3" ALIGN="CENTER">
            <INPUT TYPE="submit">
        </TD>
    </TR>

</TABLE>
</FORM>
        </TD>
    </TR>
EOT

    return $return;
}

sub display_channels {
    my $prefs = shift;
    my(%channels, $channels);

    for my $rdf (sort { $a->[1] <=> $b->[1] || $a->[2] <=> $b->[2]
                                            || $a->[0] <=> $b->[0] }
                 map  { [$_, split /,/, $prefs->{$_}] }
                 grep { /^\d+$/ }
                 keys %$prefs) {
        my $rss = new XML::RSS;
        eval { $rss->parsefile("$conf{rdfdir}/$rdf->[0].rdf") };
        next if $@;

        push @{$channels{$rdf->[1]}}, format_channel($rss, $prefs, $rdf->[0]);
    }

    $channels = qq[    <TR>\n];
    for (grep { exists $channels{$_} } 1..3) {
        $channels .= join '', qq[        <TD VALIGN="TOP">\n],
            join("\n<BR>\n", @{$channels{$_}}),
            qq[        </TD>\n];
    }
    $channels .= qq[    </TR>\n];

    return $channels;
}

sub format_channel {
    my($rss, $prefs, $rdf) = @_;
    my($desc, $img, @items, $items, $input, $date);

    $img = ($rss->{image}{url} && -e "$conf{imgdir}/$rdf.gif") || (-e "$conf{imgdir}/$rdf.gif") ?
        qq'<IMG SRC="$conf{imgurl}/$rdf.gif" BORDER="0"' : '';

    if ($img) {
        if ($rss->{image}{description}) {
            $img .= qq' ALT="$rss->{image}{description}"';
        } elsif ($rss->{image}{title}) {
            $img .= qq' ALT="$rss->{image}{title}"';
        }

        if ($rss->{image}{width} && $rss->{image}{height}) {
            $img .= qq' HEIGHT="$rss->{image}{height}" WIDTH="$rss->{image}{width}"';
        }

        $img .= '>';

        if ($rss->{image}{'link'}) {
            $img = qq[<A HREF="$conf{logger}$rss->{image}{'link'}">$img</A>];
        }

        $img = "<P>$img</P>";
    } else {
        $img = qq[<H2><A HREF="$conf{logger}$rss->{channel}{'link'}">$rss->{channel}{title}</A></H2>];
    }

    for my $item (@{$rss->{items}}) {
        my $i = qq[<IMG SRC="$conf{imgurl}/bullet.gif" ALIGN="top" HEIGHT="10" WIDTH="10" ALT=" * ">] .
                qq[<A HREF="$conf{logger}$item->{'link'}">$item->{title}</A>];
        $i .= " - $item->{description}" if $prefs->{desc}{$rdf} && $item->{description};
        $i .= "<BR>";
        push @items, $i;
    }

    $items = join "\n", @items;
    $date = $rss->{channel}{lastBuildDate} || $rss->{channel}{pubDate} || '';

    my @date = $date
        ? gmtime timegm localtime str2time($date)
        : localtime(time - ((-M "$conf{rdfdir}/$rdf.rdf") * 86400));

    $date = sprintf '<P><EM CLASS="small" STYLE="font-size: small; text-align: left">%s</EM></P>',
        strftime('%B %d, %Y, %H:%M EST', @date);

#     $desc = $rss->{channel}{description} || '';
#     $desc = "<P><EM>$desc</EM></P>" if $desc;

    $input = $rss->{textinput}{'link'} ? <<EOT : '';
<FORM ACTION="$rss->{textinput}{'link'}" METHOD="GET"><P>
${\($rss->{textinput}{title} || '')} <INPUT TYPE="text" NAME="$rss->{textinput}{name}" SIZE="10">
</P></FORM>
EOT

    return <<EOT;
<TABLE CELLPADDING="8" WIDTH="200" BORDER="0" CELLSPACING="0">
    <TR>
        <TD ALIGN="CENTER">
            $img
        </TD>
    </TR>
    <TR>
        <TD BGCOLOR="$prefs->{fore}">
$items
$input
$date
        </TD>
    </TR>


</TABLE>
EOT
}

sub tableHeader {
return q(<TABLE BORDER="0" WIDTH="660" CELLPADDING="16" CELLSPACING="5">);
}

sub myhead {
    my($cgi, $user, $prefs, $refresh) = @_;

    $refresh = $refresh ? <<EOT : '';
<META HTTP-EQUIV="Refresh" CONTENT="1800; URL=http://$ENV{SERVER_NAME}$conf{prog}">
EOT

    return header(get_cookie($cgi, $user, $prefs)), <<EOT;
<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.0 Transitional//EN"
			"http://www.w3.org/TR/REC-html40/loose.dtd">
<HTML>
<HEAD>
    <TITLE>My Portal</TITLE>
    $refresh
</HEAD>
<BODY BGCOLOR="$prefs->{back}" TEXT="$prefs->{btext}" LINK="$prefs->{'link'}" VLINK="$prefs->{vlink}">

<TABLE BORDER="0" WIDTH="660">
    <TR>
        <TD COLSPAN="3" ALIGN="CENTER">
            <P>
            <IMG SRC="my-portal-head.gif" ALT="My Portal" WIDTH="243" HEIGHT="62">
            <BR CLEAR="ALL">
            [
                <STRONG><A HREF="$conf{prog}">Home</A></STRONG> |
                <STRONG><A HREF="$conf{prog}?login=1">Login</A></STRONG> |
                <STRONG><A HREF="$conf{prog}?config=1">Configure</A></STRONG> |
                <STRONG><A HREF="$conf{src}">Source</A></STRONG> |
                <STRONG><A HREF="mailto:$conf{admin}">Feedback</A></STRONG>
            ]</P>
        </TD>
    </TR>

EOT
}

sub myfoot {
    return <<EOT;

</TABLE>

    <P STYLE="text-align: center; font-size: small;">
        Hosting provided by <A HREF="http://www.perlmongers.org/">Perl Mongers</A>
    </P>

    <P STYLE="text-align: center; font-size: small;">
        &copy; Copyright 2000, Chris Nandor.  All Rights Reserved.<BR>
        Copyright of content of each channel maintained by respective owners.
    </P>

</BODY>
</HTML>
EOT
}

sub tablefooter {
    return <<EOT;

</TABLE>
<BR>
<P STYLE="text-align: center; font-size: small;">                                 
       Copyright of content of each channel maintained by respective owners.
</P>
EOT
}

#==================
# data stuff
#==================

sub save_prefs {
    my($user, $prefs) = @_;
    tie my %users, 'AnyDBM_File', $conf{userf}, O_RDWR|O_CREAT, 0644 or die $!;
    $users{$user} = join '|', %$prefs, modtime => time;
    untie %users;
}

sub get_cookie {
    my($cgi, $user, $prefs) = @_;
    my %params;

    if ($user) {
        $params{-cookie} = $cgi->cookie(
            -name    => $conf{cookieNam},
            -value   => $user,
            -domain  => $conf{cookieDom},
            -path    => $conf{cookiePath},
            $prefs->{save_cookie} ? (-expires => $conf{cookieExp}) : ()
        );
    }

    return %params;
}

sub set_config {
    my($cgi, $user, $prefs) = @_;
    $user ||= join '.', $ENV{REMOTE_ADDR}, $$, time;

    $user = join '', map { $_ ? chr : '' } split m/\%/, $user
        if $user =~ m/^\%/;

    for my $i (keys %$prefs) {
        delete $prefs->{$i} if $i =~ /^\d+$/;
    }

    # channels
    for ($cgi->param('channels')) {
        my($m, $r) = ($cgi->param("col-$_"), $cgi->param("row-$_"));
        $m = $m =~ /^\d+$/ ? $m : 3;
        $r = $r =~ /^\d+$/ ? $r : 9;
        $prefs->{$_} = "$m,$r";
    }

    # color
    for my $c (qw(back fore btext ftext link vlink)) {
        my $color = $cgi->param($c);
        $color =~ s/^\s*(.*)\s*$/$1/;
        if ($color =~ /^(?:#?[0-9a-fA-F]{6}|[a-zA-Z]+)$/) {
            $prefs->{$c} = $color;
        }
    }

    # other
    for my $c (qw(showdesc save_cookie)) {
        $prefs->{$c} = $cgi->param($c);
    }

    save_prefs($user, $prefs);
    return($user, $prefs);
}

sub get_prefs {
    my($user, $prefs) = @_;
    return $conf{defaults} unless -e $conf{userf} . '.pag';

    $user = join '', map { $_ ? chr : '' } split m/\%/, $user
        if $user =~ m/^\%/;

    tie my %users, 'AnyDBM_File', $conf{userf}, O_RDONLY, 0444 or die $!;
    return $prefs || $conf{defaults} unless $users{$user};
    my %prefs = split m/\|/, $users{$user};
    untie %users;

    for (grep !/^\d+$/, keys %{$conf{defaults}}) {
        $prefs{$_} = $conf{defaults}->{$_} unless exists $prefs{$_};
    }

    return \%prefs;
}

sub userOK {
    my($un, $pw) = @_;
    return $conf{defaults} unless -e $conf{userf} . '.pag';
    tie my %users, 'AnyDBM_File', $conf{userf}, O_RDONLY, 0444 or die $!;
    for my $u (keys %users) {
        next unless $u =~ /^(.+?)\|$un$/;
        if (crypt($pw, $1) ne $1) {
            return;
        }
    }
    1;
}

#==================
# command line stuff
#==================

sub fetch_rdf {
    my($rdf, $l) = @_;
    my $rc = mirror($l, "$conf{rdfdir}/$rdf.rdf");
    return($rc, $l) if is_error($rc);

    {
        my $file = "$conf{rdfdir}/$rdf.rdf";
        my @time = (stat $file)[8, 9];
        local $^I = '.bak';
        local @ARGV = $file;
        while (<>) {
            s/\015\012?/\012/g;
            s/\227/--/g;
            s/&(?!(?:[a-zA-Z0-9]+|#\d+);)/&amp;/g;
            print;
        }
        unlink "$file.bak";
        utime @time, $file;
    }

    my $rss = new XML::RSS;
    eval { $rss->parsefile("$conf{rdfdir}/$rdf.rdf") };
    warn "RDF $l not well-formed - $@" and return if $@;

    return($rc, $l) unless $rss->{image}{url};

    $rc = mirror($rss->{image}{url}, "$conf{imgdir}/$rdf.gif");
    return($rc, $rss->{image}{url});
}

sub do_cl {
    my %o;
    getopts('r:c:l:updf:', \%o);

    # no locking ... oh well
    if ($o{r}) {
        tie my %rdfs, 'AnyDBM_File', $conf{rdff}, O_RDWR, 0444 or die $!;
        if ($rdfs{$o{r}}) {
            $o{r} =~ /^(\d+)$/;  # untaint
            $o{r} = $1;

            for ("$conf{rdfdir}/$o{r}.rdf", "$conf{imgdir}/$o{r}.gif") {
                if (-e) {
                    unlink or warn "Can't unlink $_: $!";
                }
            }

            delete $rdfs{$o{r}};
            print "Channel $o{r} deleted\n";

        } else {
            print "No key $o{r} found\n";
        }
        untie %rdfs;

    } elsif ($o{c} && $o{l}) {
        tie my %rdfs, 'AnyDBM_File', $conf{rdff}, O_CREAT|O_RDWR, 0644 or die $!;
        my($n) = sort { $b <=> $a } keys %rdfs;
        $rdfs{++$n} = join '|', $o{c}, $o{l};
        untie %rdfs;
        print "Channel $n. $o{c} ($o{l}) added.\n";

        my($rc, $u) = fetch_rdf($n, $o{l});
        if ($rc && is_error($rc)) {
            print "Error downloading $o{c} file $u: $rc\n";
        } elsif ($rc) {
            print "Fetched $o{c} RDF file and (maybe?) img\n";
        }
        

    } elsif ($o{p}) {
        tie my %rdfs, 'AnyDBM_File', $conf{rdff}, O_RDWR, 0444 or die $!;
        for (sort { $a <=> $b } keys %rdfs) {
            printf "%3d. %-20s => %-50s\n", $_, split m/\|/, $rdfs{$_};
        }
        untie %rdfs;

    } elsif ($o{f}) {
        my @f;
        tie my %rdfs, 'AnyDBM_File', $conf{rdff}, O_RDWR, 0444 or die $!;
        if ($o{f} eq 'all') {
            @f = sort keys %rdfs;
        } else {
            @f = split m/\s+/, $o{f};
        }

        for my $rdf (@f) {
            $rdf =~ /^(\d+)$/;
            $rdf = $1;
            warn "$rdf not found" and next unless $rdfs{$rdf};
            my($c, $l) = split m/\|/, $rdfs{$rdf};

            my($rc, $u) = fetch_rdf($rdf, $l);
            if (is_error($rc)) {
                print "Error downloading $c file $u: $rc\n";
            }
        }

        untie %rdfs;

    } elsif ($o{d}) {
            print tableHeader();
            print display_channels($conf{defaults});
			print tablefooter();
    } else {
        warn <<EOT;
Usage: $0 [-r channelnumber] [-c channelname -l channellink] [-d][-p]
          [-f channelnumber]
    -r Remove channel by number
    -c Add channel name with -l channel link
    -d display the html code for all the channels
    -p Print all channels
    -f Fetch channel ('all' to get all)
EOT
    }
}

__END__

=head1 NAME

my_portal

=head1 SYNOPSIS

    my_portal [-r channelnumber] [-c channelname -l channellink] [-d][-p]
          [-f channelnumber]
    -r Remove channel by number
    -c Add channel name with -l channel link
    -d display the html code for all the channels
    -p Print all channels
    -f Fetch channel ('all' to get all)


=head1 DESCRIPTION

A CGI and command line utility to run a basic portal.  It saves user
configurations using cookies, it displays RSS channels based on those
preferences.  See XML::RSS for more info on the channels.

I won't really support this much, I haven't the time.  Take the source
and use it if you like.

I wrote this because I wanted to have a "portal" I could customize at
will, without having to worry about other portals adding the channels
I like.  I'd like to find things like weather and sports to add, but
those are more difficult.  Maybe someday.  For now, I just wanted to
put all the news channels I like on one page.

And others, I know, want the same thing.  So, you can send me channels
and I can consider them for inclusion on this site, or you can use
this source on your own site for your own use.  Whatever.  Have fun!

If you use this source for a publically available site, please consider
providing the source to the users, or linking back to this site.
Share the software, you'll be freeeeee ...

=head1 HISTORY

=over 4

=item v0.62 (29 Feb 2000)

Added option B<-d> to the command line and $conf{embeded}, this can be used to embed the html code produced on another web page. 

=item v0.61 (02 Jan 2000)

Removed "do 'XML/RSS.pm'" ... no longer needed with XML::RSS 0.08.

Did more work on usernames.

Remove meta refresh from config screen.

=item v0.60 (29 Dec 1999)

Add username and password for recalling preferences.

Reset file time with utime() after filtering added in 0.58.

=item v0.58 (17 Dec 1999)

Add filter to fetch_rdf() to fix newlines from CR or CRLF to LF.

=item v0.57 (17 Nov 1999)

Only show image if it is asked for in RSS I<and> exists on disk.

=item v0.56 (16 Nov 1999)

Delete image and RDF files on channel delete (B<-r>).

=item v0.55 (15 Nov 1999)

Small bug in B<-f> option fixed.

Added printing of date back in (uses date of RSS file on disk if
appropriate field in RSS file not filled in).

Added C<path> parameter to cookie config.

=item v0.54 (13 Nov 1999)

Even more fixes!  Wooooo!  Most of these fixes are not even worth
mentioning, really.  Cosmetic stuff, stuff to make it cleaner
and pass HTML validation, etc.

=item v0.53 (11 Nov 1999)

Some more fixes!

=item v0.52 (10 Nov 1999)

Some fixes.

=item v0.51 (10 Nov 1999)

Cosmetic changes.

=item v0.50 (09 Nov 1999)

A nice project for a day ...

=back

=head1 AUTHOR AND COPYRIGHT

Chris Nandor E<lt>pudge@pobox.comE<gt>, http://pudge.net/

Copyright (c) 2000 Chris Nandor.  All rights reserved.  This program is
free software; you can redistribute it and/or modify it under the terms
of the Artistic License, distributed with Perl.

=head1 VERSION

0.61, 02 Jan 2000