#!/usr/local/bin/perl
#
# A personal or trusted-group Weblog utility.
#
# by David M. Chess
# Committed to the public domain, 1999
# http://www.davidchess.com/
# glog@davidchess.com
#
# Needs:
# - More input-checking
# - A preview screen before posting
# - Archiving / dumping (manual and automatic)
# - Date and time symbols richer than just &when;
#
use strict;
##############
#
# These are the variables you need to fill in
# for your particular setup. See documentation,
# if any, for details, or just read the comments.
#
##############
my $logtitle = "Web log"; # Title used in forms, default templates, etc
my $logtoken = "glog"; # Short name for use in cookies
my $logurl = ""; # URL of the log itself
my $cgiurl = ""; # URL of this script
my $password = ""; # The main password for adding log entries
my $pass2 = ""; # Extra password required to delete
# entries (leave empty to not require one)
my $logfile = ""; # /dir/filename of the html log file to generate;
# must be writable by this script
my $itmfile = ""; # /dir/filename of the file to use for storing
# raw item data; must be r/w by this script
my $maxtext = 2000; # maximum length of a long text description
my $maxlink = 45; # how much to shave the url down to when making
# link text, if the user doesn't give any
my $scrub_text = 1; # Whether or not to remove &'s, <'s, and >'s,
# and insert s for blank lines
##############
#
# Optionally, you can twiddle these variables to change
# some little details of the appearance of some screens.
# For more detailed tailoring, see below.
#
##############
my $bgcolor = "#000033"; # Background color for screens
my $textcolor = "white"; # Text color for ordinary screens
my $errorcolor = "red"; # Text color for error screens
my $linkcolor = "#FFFF33"; # Text color for unvisited links
my $vlinkcolor = "#9999FF"; # Text color for visited links
##############
#
# End of setup variables. To override the default
# HTML templates for the various screens and stuff,
# change these next few routines to return something;
# see (but don't change) the default versions further
# down for examples.
#
##############
# The template for the HTML of the log itself; the symbol "&body;" in
# the returned string will be replaced by the HTML representing the
# log entries. See default_log_template() below for an example.
sub custom_log_template {
return "";
}
# The template for the HTML representing one entry. Symbols:
# &url; == the URL-to-be-logged, as given on the form
# &link; == the text for the link to the URL
# &text; == the description, as given on the form
# &from; == the name of the contributor, as given on the form
# &home; == the home or mailto URL of the contributor
# &when; == the time the entry was logged, as yyyy/mm/dd hh:mm:ss
# &via; == the remote host the entry was entered from
# See default_entry_template() below for an example.
sub custom_entry_template {
return "";
}
##############
#
# Default templates for the overall log page, and
# the individual entries within it. To modify how
# the log page looks, copy the contents of these to the
# custom_*_template() routines above, and alter them as
# you wish. There's no need to alter the default_*_template()
# routines, since if the custom ones return anything, they
# aren't even called.
#
##############
# Return the default log HTML page template. If custom_log_template()
# returns anything, this will not be called.
sub default_log_template {
return <<"EOD";
$logtitle
$logtitle
[Post]
EOD
}
# The default template for a single entry. If custom_entry_template()
# returns anything, this will not be called.
sub default_entry_template {
return <<"EOD";
&link;
&text;
posted &when; by &from;; via &via;
EOD
}
##############
#
# End of setup variables and functions. Change
# anything below here at your own risk.
#
##############
############################################################
#
# A few notes: the entire HTML log file is rebuilt from the
# raw data and the current template whenever POST is pushed;
# this is nice because you can change the template and the
# entire page updates at once. It can also be slow, but
# how many times will it happen per second, after all?
#
# The raw data (the URL, text, sender, sender home URL, time,
# and a "deleted" flag) is stored in the datafile one entry
# per line, each line containing the relevent variables
# uuencoded and separated by |'s (which aren't in the uuencode
# output-space). It's sort of a silly representation, but I
# like it for that very reason! The oldest item is stored
# first. In memory, the whole thing is read into an array(ref),
# each element of which is a reference to the obvious hash.
# They're also stored oldest-first, because the array index
# is used as the entry-number for deletion, and I didn't want
# entry numbers to change every time a new posting goes in
# (because that could easily lead to misdeletions). So when
# generating the pretty HTML page, the list has to be reversed,
# so it can be newest first. But that's OK.
#
# "Deleting" an item actually just sets the "deleted" key to
# the value 1. So it's still in there, but the routine that
# generates the pretty page just doesn't show it. We could
# eventually add an "undelete", a "view deleted items", and so
# on.
#
# See the documentation, if any, for some discussion of the
# security aspects. The only security is provided by the
# passwords, of which there are by design only two. Tell
# everyone that you want to be able to post what the posting
# password is. One poster can trivially masquerade as another;
# don't give the password to anyone jerky enough to do that
# (or give the password to the whole world, and assume that
# forgery will happen). One could add per-user passwords,
# but that would mean having user-administration functions
# and similar cr*d; if you want all that, talk to the guys
# at memepool or slashdot or wherever about licensing or
# cloning whatever it is that they use.
#
# OK, on with the code...
############################################################
# Read everything we were passed in from form, querystring, or cookie
my $stuff = decode_form();
# Do anything that requires a special header. At the moment,
# that means setting or clearing the cookie. The checks for
# $ENV{REMOTE_ADDR} are so that we produce pure HTML if called
# outside the CGI environment (i.e. for local testing.).
if ($stuff->{clear}) {
my $xtime = some_future_time();
print "Set-cookie: $logtoken=; path=/; expires=$xtime\n"
if $ENV{REMOTE_ADDR};
} elsif ($stuff->{record}) {
my $cookieval = make_cookie_text($stuff);
my $xtime = some_future_time();
print "Set-cookie: $logtoken=$cookieval; path=/; expires=$xtime\n"
if $ENV{REMOTE_ADDR};
}
# We always return HTML (see comment above about REMOTE_ADDR)
print "Content-type: text/html\n\n" if $ENV{REMOTE_ADDR};
# Check for script setup errors, report and abort if any exist
if (not $logurl) {
print error_page('The $logurl variable is not set in the glog script'); exit;
}
if (not $cgiurl) {
print error_page('The $cgiurl variable is not set in the glog script.'); exit;
}
if (not $password) {
print error_page('The $password variable is not set in the glog script.'); exit;
}
if (not $logfile) {
print error_page('The $logfile variable is not set in the glog script.'); exit;
}
if (not $itmfile) {
print error_page('The $itmfile variable is not set in the glog script.'); exit;
}
# Now look at which SUBMIT button was pressed, to decide what to do
if (defined $stuff->{postnew}) {
do_newurl($stuff); # POST button
} elsif (defined $stuff->{deleteold}) {
do_delete($stuff); # DELETE button
} elsif (defined $stuff->{clear}) {
do_clear($stuff); # CLEAR COOKIES button
} else {
do_form($stuff); # No button; show input form
}
exit;
# Return the HTML for a page reporting the given serious error message.
# This should probably be explicitly tailorable. Feel free to mess with
# it if you don't like the as-coded error page.
sub error_page {
my $msg = shift;
return <<"EOD";
glog error
Error
$msg
EOD
}
# Present the initial form to the user. This should probably be
# explicitly tailorable, also. Feel free to mess with it if you
# don't like how it looks, but be careful not to change any of
# the semantics, field names, etc! This routine expects to receive
# a hashref to all the data received from form, query string, cookie,
# as returned by decode_form().
sub do_form($) {
my $stuff = shift;
# Extract the data supplied in the cookie, if any
my $c_handle = $stuff->{c_handle} || "";
my $c_home = $stuff->{c_home} || "";
my $c_password = $stuff->{c_password} || "";
# Note about what's allowed
my $html_note = ($scrub_text) ?
"note that no HTML or &-symbols will work" :
"full HTML allowed, so be careful!";
# Print the form. It's a little messy, I admit...
print <<"EOD";
$logtitle -- input form
$logtitle -- input form
EOD
}
# Add a new item to the database and the pretty file.
sub do_newurl {
my $stuff = shift;
local *FH;
# Avoid -w warnings, just in case
$stuff->{text} = " " if not defined $stuff->{text};
$stuff->{handle} = "anonymous" if not defined $stuff->{handle};
$stuff->{home} = " " if not defined $stuff->{home};
$stuff->{link} = "" if not defined $stuff->{link};
# Validate various inputs
if ($stuff->{password} ne $password) {
print error_page("That isn't the right posting password."); exit;
}
if (length($stuff->{text})>$maxtext) {
print error_page("Please keep descriptions under $maxtext characters!"); exit;
}
# Apply scrubbing, if it's turned on
if ($scrub_text) {
$stuff->{link} =~ s/\&/\&\;/g;
$stuff->{link} =~ s/\{link} =~ s/\>/\>\;/g;
$stuff->{text} =~ s/\&/\&\;/g;
$stuff->{text} =~ s/\{text} =~ s/\>/\>\;/g;
$stuff->{text} =~ s/\n\n/\n\n/g;
$stuff->{text} =~ s/\r\n\r\n/\r\n
\r\n/g;
}
my $rawdata = read_raw($itmfile); # Get the existing items
if (not open FH, ">$logfile") {
print error_page("Could not open $logfile for writing."); exit;
}
# Note that if the user presses the "POST" button, but leaves the
# URL field blank, the pretty file will be refreshed from the
# current raw data and template. This is useful when making
# template changes.
# Anyway, if there *is* a url specified, add an item to the
# raw data array, and save away the array
if ($stuff->{url}) {
push @$rawdata, { url => $stuff->{url},
text => $stuff->{text},
time => time(),
handle => $stuff->{handle},
home => $stuff->{home},
deleted => 0,
via => ($ENV{REMOTE_HOST} || "(unknown)"),
link => $stuff->{link} };
if (not write_raw($itmfile,$rawdata)) {
print error_page("Could not open $itmfile for writing."); exit;
}
}
# Generate the pretty page, and save it away
print FH make_log_page($rawdata);
close FH;
# Print success. This is another page that should be tailorable;
# feel free to mess with this next paragraph, if you're careful.
print <<"EOD";
$logtitle -- Posted
EOD
# Same for this one
if ($stuff->{url}) {
print qq#Your new log entry was posted to $logtitle.#;
} else {
print qq#$logtitle was refreshed.#;
}
print "\n";
}
# Delete an entry. Note that, as explained above, this just sets
# the "deleted" key. And, of course, regens the HTML log page.
# Note also that the item number, as recorded in HTML comments
# by make_log_page() and as entered by the user in the Delete
# part of the input form, is *one origin*. This is because I
# want all valid ones to be "true" in Perl terms. Silly, eh?
sub do_delete($) {
my $stuff = shift;
my $rawdata = read_raw($itmfile);
# Input validation
if ($stuff->{password} ne $password) {
print error_page("That's not the right password."); exit;
}
if ($pass2 && ($stuff->{pass2} ne $pass2)) {
print error_page("That's not the right password."); exit;
}
if (not $stuff->{itemnumber}) {
print error_page("You have to give a valid item number to delete."); exit;
}
if (not open FH, ">$logfile") {
print error_page("Could not open $logfile for writing."); exit;
}
if ($stuff->{itemnumber} > scalar @$rawdata) {
print error_page("There is no item with that number."); exit;
}
# Note the "-1", since item numbers are 1-origin, but the array is 0-origin
$rawdata->[$stuff->{itemnumber}-1]->{deleted} = 1;
# Record the new raw data
if (not write_raw($itmfile,$rawdata)) {
print error_page("Could not open $itmfile for writing."); exit;
}
# And regen the pretty page
print FH make_log_page($rawdata);
close FH;
# Another hardcoded page that you can mess with carefully if
# you want to.
print <<"EOD";
$logtitle -- Deleted
That log entry was deleted from $logtitle.
EOD
}
# Tell the user his cookie has been cleared; the actual
# clearing happened way earlier, back in the header-generation
# section.
sub do_clear {
# Another hardcoded page that you can mess with carefully if
# you want to.
print <<"EOD";
$logtitle -- Cleared
Your cookie for $logtitle has been cleared.
EOD
}
# Create a new HTML log page from the raw-data array-thing.
# Just substitutes the HTML for the given array of entries
# into the proper template.
sub make_log_page {
my $rawdata = shift;
my $page_template = custom_log_template() || default_log_template();
my $entry_template = custom_entry_template() || default_entry_template();
my $entrydata = "";
my $i = 1 + scalar @$rawdata;
# Call fill_entry_template to generate the HTML for the entries.
foreach (reverse @$rawdata) {
$i--;
next if $_->{deleted};
$entrydata .= "\n\n";
$entrydata .= fill_entry_template($entry_template,$_);
}
# Fill that into the proper page template.
$page_template =~ s/\&body\;/$entrydata/e;
return $page_template; # and we're done!
}
# Do substitions into the given entry template, from the given entry,
# in the obvious way.
sub fill_entry_template($$) {
my $template = shift;
my $entry = shift;
my $printtime = printable_time($entry->{time});
# Default the link text, if not given
my $link = $entry->{link} || length_limit($entry->{url},$maxlink);
$template =~ s/\&url\;/$entry->{url}/ge;
$template =~ s/\&text\;/$entry->{text}/ge;
$template =~ s/\&from\;/$entry->{handle}/ge;
$template =~ s/\&home\;/$entry->{home}/ge;
$template =~ s/\&when\;/$printtime/ge;
$template =~ s/\&via\;/$entry->{via}/ge;
$template =~ s/\&link\;/$link/ge;
return $template;
}
# The One True Date Format! Use it everywhere!
sub printable_time($) {
my @now = gmtime(shift());
return sprintf "%04d/%02d/%02d %02d:%02d:%02d GMT",
1900+$now[5],$now[4]+1,@now[3,2,1,0];
}
# Read and write an array of hashes representing the existing items.
# Should just use Data::Dumper, but not everyone has it installed,
# and it does require a rather insecure eval(). So we'll just uuencode!
sub read_raw($) {
my $infile = shift;
local *FH;
my $answer = [];
my ($urlu,$textu,$timeu,$fromu,$homeu,$deleu,$viau,$linku);
my $entry = {};
open FH, "<$infile" or return $answer; # It's OK if it doesn't exist yet
while () {
($urlu,$textu,$timeu,$fromu,$homeu,$deleu,$viau,$linku) = split /\|/;
$entry = { url => unpack('u',$urlu),
text => unpack('u',$textu),
time => unpack('u',$timeu),
handle => unpack('u',$fromu),
home => unpack('u',$homeu),
deleted => unpack('u',$deleu),
via => unpack('u',$viau),
link => unpack('u',$linku) };
push @$answer, $entry;
}
close FH;
return $answer;
}
sub write_raw($) {
my $outfile = shift;
my $data = shift;
local *FH;
my $outline;
open FH, ">$outfile" or return ""; # That's an error!
foreach (@$data) {
$outline= pack('u',$_->{url})."|".
pack('u',$_->{text})."|".
pack('u',$_->{time})."|".
pack('u',$_->{handle})."|".
pack('u',$_->{home})."|".
pack('u',$_->{deleted})."|".
pack('u',$_->{via})."|".
pack('u',$_->{link});
# IMHO, pack('u') should not stick in \n's!
$outline =~ s/\n//g;
print FH "$outline \n";
}
close FH;
return 1; # All OK.
}
# These three routines just support decode_form(), which returns a
# hash containing all keywords and values passed in in form fields
# or the query string, or the Magic Cookie.
sub decode_form {
my $query = defined($ENV{QUERY_STRING}) ? $ENV{QUERY_STRING} : "";
my $answer = parse_stuff({},$query);
my @form_input = ;
chomp @form_input;
$answer = parse_stuff($answer,(join " ",@form_input)); # or ""?
my $cookies = defined($ENV{HTTP_COOKIE}) ? $ENV{HTTP_COOKIE} : "";
$answer = parse_magic_cookie($answer,$logtoken,$cookies);
return $answer;
}
sub parse_stuff {
my $answer = shift;
my ($key,$value);
my @input = split /&/ , shift();
foreach (@input) {
($key,$value) = (/(.*)=(.*)/);
$answer->{lc $key} = fix_url_encoding($value);
}
return $answer;
}
sub fix_url_encoding {
my $string = shift;
$string =~ s/\+/ /g;
$string =~ s/\%([0-9A-Fa-f]{2})/pack("C",hex($1))/ge;
return $string;
}
sub parse_magic_cookie {
my $answer = shift;
my $magic = shift;
my $jar = shift;
my $key;
my $stuff = undef;
my @lines = split /;/, $jar;
# Look for the magic cookie
foreach ( @lines ) {
if (/\s*([^\=]*)\=(.*\S)\s*$/) {
($key,$stuff)=($1,$2);
last if $key eq $magic;
}
}
if ($stuff) {
$stuff =~ s/[\r\n]//g;
my ($handleu, $homeu, $passwordu);
($handleu, $homeu, $passwordu) = split /\|/, $stuff;
$answer->{c_handle} = pack('H*',$handleu);
$answer->{c_home} = pack('H*',$homeu);
$answer->{c_password} = pack('H*',$passwordu);
}
return $answer;
}
# Return some time in the future, when the datecookie should expire,
# in the required silly antique RFC822 format.
sub some_future_time {
return silly_date_format_gmt(time() + 60*60*24*366); # awhile
}
# Given a time as from time(), return it in the Antique Date Format used
# by Expires: and Last-modified: and so on. NOTE that Internet Explorer
# requires, but ignores, the day-of-the-week token. Sigh!
sub silly_date_format_gmt {
my $thistime = shift;
my @a = gmtime($thistime); # awhile
return sprintf "%s, %02d %s %04d %02d:%02d:%02d GMT",
(qw(Sun Mon Tue Wed Thu Fri Sat))[$a[6]],
$a[3],
(qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec))[$a[4]],
1900+$a[5],@a[2,1,0];
}
# Encode certain things in the hash into a cookie filling. Even uuencode
# doesn't fit inside the legal cookie-value space, so we'll punt entirely
# and use unpack('H*'), which does. This makes for a long cookie!
sub make_cookie_text($) {
return (join "", unpack('H*',$stuff->{handle}))."|".
(join "",unpack('H*',$stuff->{home}))."|".
(join "",unpack('H*',$stuff->{password}));
}
# If a string is too long, make it into [start]...[end]
sub length_limit ($$) {
my $s = shift;
my $limit = shift;
return $s if length($s)<=$limit;
my $x = ($limit-3)/2;
return substr($s,0,$x)."...".substr($s,0-$x);
}