Apache2::ClickPath::Store - use Apache2::ClickPath sessions to store

 LoadModule perl_module ".../mod_perl.so"
 PerlLoadModule Apache2::ClickPath::Store
 ClickPathStoreDirectory "some_directory"
 ClickPathStorePath "/uri"
 ClickPathStoreTimeout 300
 ClickPathStoreCleanupInterval 60

  +-------------------------+
  |     +----------------+  |
  |     | Cluster        |  |
  |     |                |  |
  |     | +-------------+|  | access the server's very own
  |     | | Server 1    ||  | information store
  |     | |             ||  |
  |     | |        *--------+
  |     | | StoreClient ||
  |     | |        *--------+
  |     | |.............||  |
  |     | | <Loc /store>||  | access a foreign
  +------>|  Info Store ||  | information store
        | | </Loc>      ||  |
        | +-------------+|  |
        |                |  |
        | ...            |  |
        |                |  |
        | +-------------+|  |
        | | Server N    ||  |
        | |.............||  |
        | | <Loc /store>||  |
  +------>|  Info Store ||  |
  |     | | </Loc>      ||  |
  |     | +-------------+|  |
  |     +----------------+  |
  +-------------------------+

   here work
   Apache2::ClickPath and
   Apache2::ClickPath::StoreClient
  +----------------+
  | Cluster        |                   and here
  |                |                   Apache2::ClickPath::Store
  | +-------------+|                  +------------+
  | | Server 1    ||                  |            |
  | |             ||    info store    |            |
  | |        *----------------------->|   Info     |
  | |             ||      access      |            |
  | +-------------+|  +-------------->|   store    |
  |                |  |               |            |
  | ...            |  |               |            |
  |                |  |               +------------+
  | +-------------+|  |
  | | Server N    ||  |
  | |             ||  |
  | |        *--------+
  | |             ||
  | +-------------+|
  +----------------+

package Apache2::ClickPath::Store;

use 5.008;
use strict;
use warnings;
no warnings qw(uninitialized);

use APR::Pool ();
use Apache2::RequestRec ();
use Apache2::RequestUtil ();
use Apache2::ServerRec ();
use Apache2::ServerUtil ();
use Apache2::RequestRec ();
use Apache2::RequestIO ();
use Apache2::Connection ();
use Apache2::Module ();
use Apache2::CmdParms ();
use Apache2::Directive ();
use Apache2::Log ();
use Apache2::Const -compile => qw(DECLINED OK NOT_FOUND
				  SERVER_ERROR HTTP_BAD_REQUEST HTTP_GONE
				  OR_ALL RSRC_CONF
				  TAKE1 RAW_ARGS NO_ARGS
				  LOG_DEBUG);
use APR::Const -compile => qw(SUCCESS);
use CGI v3.08 -compile=>qw(param);
use File::Spec ();
use File::Path qw{rmtree};
use Cwd ();
use Perl::AtEndOfScope;
use Fcntl qw/:flock/;

our $VERSION = '1.9';

our $cleanupdefault=60;

my @directives=
  (
   {
    name         => 'ClickPathStorePath',
    func         => __PACKAGE__ . '::ClickPathStorePath',
    req_override => Apache2::Const::RSRC_CONF,
    args_how     => Apache2::Const::TAKE1,
    errmsg       => 'ClickPathStorePath uri',
   },
   {
    name         => 'ClickPathStoreDirectory',
    func         => __PACKAGE__ . '::ClickPathStoreDirectory',
    req_override => Apache2::Const::RSRC_CONF,
    args_how     => Apache2::Const::TAKE1,
    errmsg       => 'ClickPathStoreDirectory local-directory',
   },
   {
    name         => 'ClickPathStoreTimeout',
    func         => __PACKAGE__ . '::ClickPathStoreTimeout',
    req_override => Apache2::Const::RSRC_CONF,
    args_how     => Apache2::Const::TAKE1,
    errmsg       => 'ClickPathStoreTimeout seconds',
   },
   {
    name         => 'ClickPathStoreCleanupInterval',
    func         => __PACKAGE__ . '::ClickPathStoreCleanupInterval',
    req_override => Apache2::Const::RSRC_CONF,
    args_how     => Apache2::Const::TAKE1,
    errmsg       =>
      'ClickPathStoreCleanupInterval seconds (default: '.$cleanupdefault.')',
   },
  );
Apache2::Module::add(__PACKAGE__, \@directives);

sub postconfig {
  my($conf_pool, $log_pool, $temp_pool, $s) = @_;

  for( $s=Apache2::ServerUtil->server; $s; $s=$s->next ) {
    my $cfg=Apache2::Module::get_config( __PACKAGE__, $s );
    if( $cfg ) {
      if( exists $cfg->{ClickPathStorePath} ) {
	$s->add_config( ['<Location '.$cfg->{ClickPathStorePath}.'>',
			 'SetHandler modperl',
			 'PerlResponseHandler '.__PACKAGE__.'::handler',
			 '</Location>'] );
      } else {
	$s->add_config( ['SetHandler modperl',
			 'PerlResponseHandler '.__PACKAGE__.'::handler'] );
      }
    }
  }

  return Apache2::Const::OK;
}

sub setPostConfigHandler {
  my $h=Apache2::ServerUtil->server->get_handlers('PerlPostConfigHandler')||[];
  unless( grep $_==\&postconfig, @{$h} ) {
    Apache2::ServerUtil->server->push_handlers
	('PerlPostConfigHandler'=>\&postconfig);
  }
}

sub ClickPathStorePath {
  my($I, $parms, $arg)=@_;
  local $_;

  Apache2::Module::get_config( __PACKAGE__, $parms->server )
      ->{"ClickPathStorePath"}=$arg;
  setPostConfigHandler;

  return;
}

sub ClickPathStoreDirectory {
  my($I, $parms, $arg)=@_;

  $arg=File::Spec->catfile( Apache2::ServerUtil::server_root, $arg )
    unless( File::Spec->file_name_is_absolute( $arg ) );
  Apache2::Module::get_config( __PACKAGE__, $parms->server )
      ->{"ClickPathStoreDirectory"}=$arg;
  setPostConfigHandler;

  return;
}

sub ClickPathStoreTimeout {
  my($I, $parms, $arg)=@_;
  local $_;

  Apache2::Module::get_config( __PACKAGE__, $parms->server )
      ->{"ClickPathStoreTimeout"}=$arg;
  setPostConfigHandler;

  return;
}

sub ClickPathStoreCleanupInterval {
  my($I, $parms, $arg)=@_;
  local $_;

  Apache2::Module::get_config( __PACKAGE__, $parms->server )
      ->{"ClickPathStoreCleanupInterval"}=$arg;
  setPostConfigHandler;

  return;
}

sub cleanup {
  my ($c, $cfg)=@{$_[0]};

  my $d=$cfg->{"ClickPathStoreDirectory"};
  my $tmout=$cfg->{"ClickPathStoreTimeout"};
  my $interval=$cfg->{"ClickPathStoreCleanupInterval"}||$cleanupdefault;
  my $time=time;

  unless( -f "$d/#lastcleanup" ) {
    open my $f, ">$d/#lastcleanup"
      or do {
	$c->base_server->log->error('['.__PACKAGE__."] Cannot create $d/#lastcleanup: $!");
	return;
      };
    undef $f;
  }

  open my $f, "<$d/#lastcleanup"
    or do {
      $c->base_server->log->error('['.__PACKAGE__."] Cannot open $d/#lastcleanup: $!");
      return;
    };

  flock $f, LOCK_EX|LOCK_NB or return; # another cleanup is running

  my $lasttime=(stat "$d/#lastcleanup")[9];

  if( $time-$lasttime>$interval ) {
    utime $time, $time, "$d/#lastcleanup";

    opendir my $D, $d
      or do {
	$c->base_server->log->error('['.__PACKAGE__."] Cannot opendir $d: $!");
	return;
      };
    my @l=readdir $D;
    closedir $D;

    $c->base_server->log->debug("Cleaning up $d");

    foreach my $el (@l) {
      next if( $el=~/^\.\.?$/ ); # skip . and ..
      next if( $el eq '#lastcleanup' );

      # cleanup is done in 2 stages. At first the directory name is
      # prepended a hash sign (#) and another cleanup interval
      # is waited to let pending requests be served. Then at stage 2 the
      # directory is removed.
      if( $time-(stat $d.'/'.$el)[9]>$tmout ) {
	if( $el=~/^#/ ) {
	  # stage 2
	  $c->base_server->log->info('['.__PACKAGE__."] $d/$el has expired: deleting");
	  rmtree $d.'/'.$el;
	} else {
	  # stage 1
	  $c->base_server->log->info('['.__PACKAGE__."] $d/$el has expired: marking for deletion");
	  rename "$d/$el", "$d/#$el"
	    or do {
	      $c->log->error('['.__PACKAGE__."] Cannot rename $d/$el to $d/#$el: $! -- deleting $el");
	      rmtree $d.'/'.$el;
	    };
	}
      }
    }
  }
}

sub handler {
  my $r=shift;

  my $restorecwd=Perl::AtEndOfScope->new( sub{chdir shift}, Cwd::getcwd );

  my $cfg=Apache2::Module::get_config( __PACKAGE__, $r->server );

  my $d=$cfg->{"ClickPathStoreDirectory"};

  if( $cfg->{"ClickPathStoreTimeout"} ) {
    # Call cleanup at the end of a connection. So keep-alive requests
    # are served at full speed.
    $r->connection->pool->cleanup_register( \&cleanup, [$r->connection, $cfg] )
      unless( $r->connection->keepalives );
  }

  my ($what, $session, $k, $v, $param);

  if( $r->main and		# is subreq
      $param=$r->pnotes( 'Apache2::ClickPath::StoreClient::storeparams' ) ) {
    ($what, $session, $k, $v)=@{$param}{qw{a s k v}};
  } else {
    $CGI::Q=CGI->new( $r );
    $what=CGI::param( 'a' );
    $session=CGI::param( 's' );
    $k=CGI::param( 'k' );
    $v=CGI::param( 'v' );
  }
  $d.='/'.$session;

  $session=~m!^[^/]+$! or return Apache2::Const::HTTP_BAD_REQUEST;
  $k=~m!^\w+$! or return Apache2::Const::HTTP_BAD_REQUEST;

  my $time=time;
  if( $what eq 'set' ) {
    unless( chdir $d ) {
      mkdir $d or do {
	$r->log->error( '['.__PACKAGE__."] Cannot create directory $d: $!" );
	return Apache2::Const::SERVER_ERROR;
      };
      chdir $d or do {
	$r->log->error( '['.__PACKAGE__."] Cannot chdir to $d: $!" );
	return Apache2::Const::SERVER_ERROR;
      };
    }
    utime $time, $time, '.';	# update times to prevent cleanup
    open my $f, ">$k" or do {
      $r->log->error( '['.__PACKAGE__."] Cannot write $d/$k: $!" );
      return Apache2::Const::SERVER_ERROR;
    };
    print $f $v or do {
      $r->log->error( '['.__PACKAGE__."] Cannot write $d/$k: $!" );
      return Apache2::Const::SERVER_ERROR;
    };
    close $f;
    $r->content_type( 'text/plain' );
    $r->print( 'ok' );
    return Apache2::Const::OK;
  } elsif( $what eq 'get' ) {
    chdir $d or return Apache2::Const::NOT_FOUND;
    utime $time, $time, '.';	# update times to prevent cleanup
    return Apache2::Const::NOT_FOUND unless( -f $k );
    $r->content_type( 'application/octet-stream' );
    # catch non-existent file
    eval {$r->sendfile( $k );};
    if( $@ ) {
      $r->log->error( '['.__PACKAGE__."] Cannot sendfile $d/$k: $!" );
      return Apache2::Const::NOT_FOUND;
    }
    return Apache2::Const::OK;
  } else {
    return Apache2::Const::NOT_FOUND;
  }
}

1;

__END__