view release on metacpan or  search on metacpan

lib/Apache/Roaming.pm  view on Meta::CPAN

use File::Spec ();
use File::Path ();
use File::Basename ();
use Symbol ();
use URI::Escape ();


package Apache::Roaming;

$Apache::Roaming::VERSION = '0.1003';


=pod

=head1 NAME

    Apache::Roaming - A mod_perl handler for Roaming Profiles


=head1 SYNOPSIS

      # Configuration in httpd.conf or srm.conf
      # Assuming DocumentRoot /home/httpd/html

      PerlModule Apache::Roaming
      <Location /roaming>
        PerlHandler Apache::Roaming->handler
        PerlTypeHandler Apache::Roaming->handler_type
        AuthType Basic
        AuthName "Roaming User"
        AuthUserFile /home/httpd/.htusers
        require valid-user
        PerlSetVar BaseDir /home/httpd/html/roaming
      </Location>

  In theory any AuthType and require statement should be possible
  as long as the $r->connection()->user() method returns something
  non trivial.


=head1 DESCRIPTION

With Apache::Roaming you can use your Apache webserver as a Netscape
Roaming Access server. This allows you to store you Netscape
Communicator 4.5 preferences, bookmarks, address books, cookies etc.
on the server so that you can use (and update) the same settings from
any Netscape Communicator 4.5 that can access the server.

The source is based on mod_roaming by Vincent Partington
<vincentp@xs4all.nl>, see

    http://www.xs4all.nl/~vincentp/software/mod_roaming.html

Vincent in turn was inspired by a Perl script from Frederik
Vermeulen <Frederik.Vermeulen@imec.be>, see

    http://www.esat.kuleuven.ac.be/~vermeule/roam/put

Compared to Apache::Roaming, this script doesn't need mod_perl. On
the other hand it doesn't support the MOVE method, thus you need
to set the li.prefs.http.useSimplePut attribute in your Netscape
preferences. Due to the missing MOVE method, it may be even slower
than Apache::Roaming and perhaps a little bit less stable.


The modules features are:

=over 8

=item *

GET, HEAD, PUT, DELETE and MOVE are handled by the module. In particular
the Non-standard MOVE method is implemented, although Apache doesn't know
it by default. Thus you need no set the li.prefs.http.useSimplePut
attribute to true.

=item *

Directories are created automatically.

=item *

The module is subclassable, so that you can create profiles on the fly
or parse and modify the user preferences. See L<Apache::Roaming::LiPrefs(3)>
for an example subclass.

=back


=head1 INSTALLATION

First of all you need an Apache Web server with mod_perl support. The
TypeHandler must be enabled, so you need to set PERL_TYPE=1 when
running Makefile.PL. For example, I use the following statements to
build Apache:

    cd mod_perl-1.16
    perl Makefile.PL APACHE_SRC=../apache_1.3.X/src DO_HTTPD=1 \
        USE_APACI=1 PERL_METHOD_HANDLERS=1 PERL_AUTHEN=1 \
        PERL_CLEANUP=1 PREP_HTTPD=1 PERL_STACKED_HANDLERS=1 \
	PERL_FILE_API=1
    cd ../apache-1.3.3
    ./configure --activate-module=src/modules/perl/libperl.a
    make
    make install
    cd ../mod_perl-1.16
    make
    make install

See the mod_perl docs for details.

Once the web server is installed, you need to create a directory for
roaming profiles, I assume /home/httpd/html/roaming in what follows,
with /home/httpd/html being the servers root directory. Be sure, that
this directory is writable for the web server, better for the web
server only. For example I do

    mkdir /home/httpd/html/roaming
    chown nobody /home/httpd/html/roaming
    chgrp nobody /home/httpd/html/roaming
    chmod 700 /home/httpd/html/roaming

with I<nobody> being the web server user.

Access to the roaming directory must be restricted and enabled via
password only. Finally tell the web server, that Apache::Roaming is
handling requests to this directory by adding something like this
to your srm.conf or access.conf:

    PerlModule Apache::Roaming
    <Location /roaming>
      PerlHandler Apache::Roaming->handler
      PerlTypeHandler Apache::Roaming->handler_type
      AuthType Basic

lib/Apache/Roaming.pm  view on Meta::CPAN

    }

    $user;
}


=pod

=head2 CheckDir

  $ar_req->CheckDir();

(Instance method) Once the user is authenticated, this method should
determine whether the user is permitted to access the requested URI.
The current implementation verifies whether the user is accessing
a file in the directory $basedir/$user. If not, a Perl exception is
thrown with $ar_req->{'status'} set to FORBIDDEN.

=cut

sub CheckDir {
    my $self = shift;
    my $file = $self->{'file'};
    my $basedir = $self->{'basedir'};
    my $dir = $file;
    my $user = $self->{'user'};
    my $prevdir;

    while (($dir = File::Basename::dirname($dir))
	   and  (!$prevdir  or  ($dir ne $prevdir))) {
	if ($basedir eq $dir) {
	    my $userdir;
	    $userdir = File::Basename::basename($prevdir) if $prevdir;
	    if (!$prevdir  or  $userdir ne $user) {
		$self->{'status'} = Apache::Constants::FORBIDDEN();
		die "Access to $file not permitted for user $user";
	    }
	    return;
	}
	$prevdir = $dir;
    }
    $self->{'status'} = Apache::Constants::FORBIDDEN();
    die "Access to $file not permitted for user $user";
}


=pod

=head2 GET, PUT, MOVE, DELETE

  $ar_req->GET();
  $ar_req->PUT();
  $ar_req->MOVE();
  $ar_req->DELETE();

(Instance Methods) These methods are called finally for performing the
real action. With the exception of GET, they call I<Success> finally
for reporting Ok.

Alternative method names are possible, depending on the name of the
requested file. For example, if you request the file I<liprefs> via
GET, then it is checked whether your sublass has a method I<GET_liprefs>.
If so, this method is called rather than the default method I<GET>.
The alternative method names are obtained by removing all non-alpha-
numeric characters from the files base name. That is, if you request
a file I<pab.na2>, then the alternative name is I<pabna2>. Note, these
method names are case sensitive!

=cut

sub GET {
    my $self = shift;
    my $file = $self->{'file'};
    my $r = $self->{'request'};

    if (! -f $file) {
	$self->{'status'} = Apache::Constants::NOT_FOUND();
	die "No such file: $file";
    }
#    return Apache::DECLINED();
    my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime) = stat _;
    my $fh = Symbol::gensym();
    if (!open($fh, "<$file")  ||  !binmode($fh)) {
  	die "Failed to open file $file: $!";
    }
    $r->set_last_modified($mtime);
    $r->content_type('text/plain');
    $r->no_cache(1);
    $r->header_out('content_length', $size);
    $r->send_http_header();
    if (!$r->header_only()) {
  	$r->send_fd($fh) or die $!;
    }
    return Apache::OK();
}


sub PUT {
    my $self = shift;
    my $file = $self->{'file'};
    my $r = $self->{'request'};

    $self->MkDir($file);

    my $fh = Symbol::gensym();

    open($fh, ">$file")
	or die "Failed to open $file: $!";
    binmode($fh)
	or die "Failed to request binmode for $file: $!";

    my $size = $r->header_in('Content-length');
    $r->hard_timeout("Apache->read");
    while ($size > 0) {
	my $buf = '';
	my $rdn = $r->read_client_block($buf, ($size < 1024) ? $size : 1024);
	if (!defined($rdn)) {
	    die "Error while reading $file from client: $!";
	}
	print $fh ($buf)
	    or die "Error while writing to client: $!";
	$size -= $rdn;