package CompoSite;

# CompoSite, a Perl module to server web pages from BlockBin.
# This file contains the main Compose handler.
# Copyright (C) 2001 Tom Rathborne
# Copyright (C) 2001 Convoke Communications Corp.
#
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA

# Documentation --------------------------------------------------------------

=head1 NAME

CompoSite - Apache PerlHandler interface for BlockBin

=head1 SYNOPSIS

In Apache config:

PerlModule Foo::Bar

<Location /dyn>
    SetHandler perl-script
    PerlHandler Foo:Bar
</Location>

In Foo::Bar package:

%Handlers = { foo => sub { my ($page, $fh, $argsq) = @_; ... do stuff ... } };
%Config = { ... stuff ... };

sub handler {
    my $req = shift || die "Couldn't get Apache request: $!";
    CompoSite::Compose ($req, \%Handlers, $Config{'default'},
                        $Config{'tdir'}, $Config{'tcache'});
};

=head1 DESCRIPTION

CompoSite constructs HTML pages via BlockBin and handles arbitrary
sub-sections of files on disk.

FIXME - more details req'd.

=head1 AUTHOR

Tom Rathborne <tomr@aceldama.com>

=cut

# Environment setup ----------------------------------------------------------

#require v5.6.0;
use strict;
$^W = 1;

use Apache              ();
use Apache::Constants   qw(:http);
use Apache::Request     ();
use Apache::Util        ();
use HTTP::Date          ();
use IO::File            ();

use Tie::DB_FileLock    ();
use Tie::TSHashDir      ();
use Tie::TSHashMirror   ();
use BlockBin         ();
use CompoSite::Util     ();

# The CompoSite request handler ----------------------------------------------

sub Compose {
    my ($req, $handlers, $defaults, $tdir, $tcache) = @_;

    my $fname = $req->filename;

    if (-d $fname) {
      # TODO - is this complete?
        if ($req->path_info ne '/') { # add trailing slash
            my $newloc = $req->uri;
            $newloc =~ s#([^/])/*$#$1/#g;
            my $args = $req->args || '';
            $newloc .= ('?' . $args) if $args ne '';
            $req->header_out ('Location', $newloc);
            return HTTP_MOVED_PERMANENTLY;
        }

      # TODO - use DocumentIndex from Apache config, *duh*
        $fname .= '/index.html';
    }

  # TODO - clean up URI a bit more, multi-slash elimination etc.

  # TODO - use user-specified 404 handler
    return HTTP_NOT_FOUND unless -f $fname;

    my $status = HTTP_OK;
    $req->status ($status);
    $req->content_type ('text/html');
    $req->header_out ('Last-Modified', HTTP::Date::time2str((stat($fname))[9]))
        unless -x $fname;
    $req->send_http_header;
    return $status if $req->header_only;

    # Check for mirror-cache potential
    my $cache = undef;
    my $cfn = undef;

    if (!-x $fname) {
        $cfn = $fname;
        $cfn =~ s/\/([^\/]+)$/\/.cache__$1/;

        if (!-e $cfn or
            check_timestamps ($cfn, $fname, $tcache)) {
            $cache = new IO::File (">$cfn.$$") || undef;
        } elsif (my $cfh = new IO::File ("<$cfn")) {
            $req->send_fd ($cfh); # quick dump!
            return $status;
        }
    }

    # Get arguments
    my $args = merged_args ($req, $defaults);

    # Start page renderer
    my $page = init_dir_db_page ($req, $cache, $tdir, $tcache);

    $page->global ($defaults);

    my $fh;

    eval {
      # TODO - handle open failure nicely
        $fh = new IO::File ("<$fname") or die 'trying to open file';

        handle_file ($handlers, $page, $fh, $args);
    };

    $fh->close;

  # FIXME - we should indicate a 500 server error
    # Handle errors
    if ($@) {
        # don't save mirror on error
        $cache->close if $cache;
        $cache = undef;
        unlink "$cfn.$$";

        # print error
        $page->print ('<h2>Error</h2>') if $page->header ({ Title => 'Error' });
        $page->print ('<pre>Died ' . Apache::Util::escape_html($@) . '</pre>');
    }

    $page->footer ($args);

    undef $page;

  # FIXME - are we detecting user-hit-stop errors??
    if (defined $cache) { # on success, store new mirror
        $cache->close;
        rename "$cfn.$$", $cfn;
    }

    return $status;
}

# Processing subroutines -----------------------------------------------------

sub handle_file ($$$$) {
    my ($handlers, $page, $fh, $args) = @_;

    my $handler;

    while (my $line = <$fh>) {
        if ($line =~ /^--USE--\s*(.*)$/) {
            $handler = $1;
            while (defined $handler and $handler ne '') {
                if (exists $handlers->{$handler}
                    and ref $handlers->{$handler} eq 'CODE') {
                    $handler = &{$handlers->{$handler}}($page, $fh, $args);
                } else {
                    $handler = CompoSite::Util::next_part($fh); # skip to next
                }
            }
        }
    }
}

# Auxilliary subroutines -----------------------------------------------------

sub merged_args ($$) { # form %args from $req
    my ($req, $def) = @_;

    my %args = $req->method eq 'GET'  ? ($req->args, %$def) :
               $req->method eq 'POST' ? ($req->content, $req->args, %$def) : ();
    $args{'path_info'} = $req->path_info;
    $args{'uri'} = $req->uri;

    return \%args;
}

sub init_dir_db_page ($$$$) { # tie it all up
    my ($req, $mir, $dirpath, $cachedb) = @_;
    my (%tdir, %tdbf, %template);

    tie %tdir, 'Tie::TSHashDir', $dirpath, '.html' or die;
    tie %tdbf, 'Tie::DB_FileLock', $cachedb or die;

    tie %template, 'Tie::TSHashMirror', \%tdir, \%tdbf, 1 or die;

    my $printer = defined $mir
        ? sub { $mir->print (@_); $req->print (@_); }
        : sub { $req->print (@_) };

    return new BlockBin (\%template, $printer);
}

sub check_timestamps {
    my $target = shift;
    my $cachetime = (stat($target))[9];

    foreach my $file (@_) {
        return 1 if (stat ($file))[9] > $cachetime; # something is newer!
    }

    return 0; # nothing is newer
}

1;

# EOF ------------------------------------------------------------------------
