view release on metacpan or  search on metacpan

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

(Class Method) This is the modules constructor, called by the I<handler>
method. Instances of Apache::Request have the following attributes:

=over 8

=item basedir

The roaming servers base directory, as an absolute path. You set this
using a PerlSetVar instruction, see L<INSTALLATION> above for an
example.

=item file

This is the path of the file being created (PUT), read (GET), deleted
(DELETE) or moved (MOVE). It's an absolute path.

=item method

The requested method, one of HEAD, GET, PUT, MOVE or DELETE.

=item request

This is the Apache request object.

=item status

If a method dies, it should set this value to a return code like
SERVER_ERROR (default), FORBIDDEN, METHOD_NOT_ALLOWED, or something
similar from Apache::Constants. See L<Apache::Constants(3)>.
The I<handler> method will catch Perl exceptions for you and generate
an error page.

=item user

Name the user authenticated as.

=back

=cut

sub new {
    my $proto = shift;
    my $self = { @_ };
    bless($self, (ref($proto) || $proto));
    $self;
}


=pod

=head2 Authenticate

  $ar_req->Authenticate();

(Instance Method) This method is checking whether the user has authorized
himself. The current implementation is checking only whether user name
is given via $r->connection()->user(), in other words you can use simple
basic authentication or something similar.

The method should throw an exception in case of problems.

=cut

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

    # Check whether the user is authenticated.
    my $user = $self->{'user'};
    if (!$user) {
	$self->{'status'} = Apache::Constants::FORBIDDEN();
	die "Not authenticated as any user";
    }

    $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();