view release on metacpan or  search on metacpan

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

# $Id: AuthTypeKey.pm 1887 2005-11-10 20:37:21Z btrott $

package Apache::AuthTypeKey;
use strict;

our $VERSION = '0.03';

use Authen::TypeKey;
use mod_perl;
use constant MP2 => $mod_perl::VERSION >= 1.99;
BEGIN {
    require base;
    if (MP2) {
        require Apache2::Const;
        Apache2::Const->import(-compile => qw( SERVER_ERROR ));
        base->import(qw( Apache2::AuthCookie ));
    } else {
        require Apache::Constants;
        Apache::Constants->import(qw( SERVER_ERROR ));
        base->import(qw( Apache::AuthCookie ));
    }
}

sub authen_cred {
    my($self, $r, @cred) = @_;
    my $token = $r->dir_config('TypeKeyToken');
    unless ($token) {
        $r->log_error('TypeKeyToken is required');
        return;
    }
    my $tk = Authen::TypeKey->new;
    $tk->token($token);
    $tk->version(1.1);
    my $key = $r->args;
    my $q = Apache::AuthTypeKey::Query->new($key);
    my $res = $tk->verify($q);
    unless ($res) {
        $r->log_error('TypeKey verification failed: ' . $tk->errstr);
    }
    $q->delete('destination');
    $res ? $q->as_string : undef;
}

sub authen_ses_key {
    my($self, $r, $key) = @_;
    my $token = $r->dir_config('TypeKeyToken');
    unless ($token) {
        $r->log_reason('TypeKeyToken is required');
        return MP2 ? Apache::SERVER_ERROR() : Apache::Constants::SERVER_ERROR();
    }
    my $tk = Authen::TypeKey->new;
    $tk->token($token);
    $tk->version(1.1);
    ## When checking the validity of the session key, we need to skip the
    ## expiration check on the signature.
    $tk->skip_expiry_check(1);
    my $res = $tk->verify(Apache::AuthTypeKey::Query->new($key));
    $res ? $res->{name} : undef;
}

## This is needed for 2 reasons:
## 1. Authen::TypeKey currently expects a Query-type object.
## 2. Apache->args breaks on '=' signs in the key/value pairs.
package Apache::AuthTypeKey::Query;
use URI::Escape qw( uri_escape uri_unescape );

sub new {
    my $class = shift;
    my($key) = @_;
    my %p;
    for my $p (split /&/, $key) {
        my($k, $v) = split /=/, $p, 2;
        $p{uri_unescape($k)} = uri_unescape($v);
    }
    bless \%p, $class;
}

sub param  { $_[0]{$_[1]}        }
sub delete { delete $_[0]{$_[1]} }

sub as_string {
    my $q = shift;
    my @s;
    while (my($k, $v) = each %$q) {
        push @s, uri_escape($k) . '=' . uri_escape($v);
    }
    join '&', @s;
}

1;
__END__

=head1 NAME

Apache::AuthTypeKey - Apache authorization handler using TypeKey

=head1 SYNOPSIS

    ## In httpd.conf or .htaccess:
    PerlModule Apache::AuthTypeKey
    PerlSetVar TypeKeyPath /
    PerlSetVar TypeKeyLoginScript /login.pl

    ## These documents require user to be logged in.
    <Location /protected>
    AuthType Apache::AuthTypeKey
    AuthName TypeKey
    PerlAuthenHandler Apache::AuthTypeKey->authenticate
    require valid-user
    PerlSetVar TypeKeyToken your_token
    </Location>

    ## This is the _return URL that the login.pl script should point to.
    <Location /login-protected>
    AuthType Apache::AuthTypeKey
    AuthName TypeKey
    SetHandler perl-script