view release on metacpan or  search on metacpan

AuthTkt.pm  view on Meta::CPAN

#
# Module to generate authentication tickets for mod_auth_tkt apache module.
#

package Apache::AuthTkt;

use 5.005;
use Carp;
use MIME::Base64;
use strict;
use vars qw($VERSION $AUTOLOAD);

$VERSION = 2.1;

my $me = 'Apache::AuthTkt';
my $PREFIX = 'TKTAuth';
my %DEFAULTS = (
    digest_type                 => 'MD5',
    cookie_name                 => 'auth_tkt',
    back_arg_name               => 'back',
    timeout                     => 2 * 60 * 60,
    timeout_min                 => 2 * 60,
    timeout_refresh             => 0.5,
    guest_login                 => 0,
    guest_user                  => 'guest',
    ignore_ip                   => 0,
    require_ssl                 => 0,
    cookie_secure               => 0,
);
my %BOOLEAN = map { $_ => 1 } qw(
    TKTAuthGuestLogin TKTAuthIgnoreIP TKTAuthRequireSSL TKTAuthCookieSecure
);
# Default TKTAuthDomain to host part of HTTP_HOST, or SERVER_NAME
($DEFAULTS{TKTAuthDomain}) = split /:/, $ENV{HTTP_HOST} || '';
$DEFAULTS{TKTAuthDomain} ||= $ENV{SERVER_NAME};
my %ATTR = map { $_ => 1 } qw(
    conf secret secret_old digest_type
    cookie_name back_cookie_name back_arg_name domain cookie_expires
    login_url timeout_url post_timeout_url unauth_url 
    timeout timeout_min timeout_refresh token debug
    guest_login guest_user ignore_ip require_ssl cookie_secure
);
#my %TICKET_ARGS = map { $_ => 1 } 

# digest_type => [ module, function ]
my %DIGEST_TYPE = (
    MD5     => [ 'Digest::MD5', 'md5_hex' ],
    SHA256  => [ 'Digest::SHA', 'sha256_hex' ],
    SHA512  => [ 'Digest::SHA', 'sha512_hex' ],
);

# Helper routine to convert time units into seconds
my %units = (
  s => 1,
  m => 60,
  h => 3600,
  d => 86400,
  w => 7 * 86400,
  M => 30 * 86400,
  y => 365 * 86400,
);
sub convert_time_seconds
{
    my $self = shift;
    local $_ = shift;
    return $1 if m/^\s*(\d+)\s*$/;
    my $sec = 0;
    while (m/\G(\d+)([shdwmMy])\b\s*/gc) {
        my $amt = $1;
        my $unit = $2 || 's';
        $sec += $amt * $units{$unit};
#       print STDERR "$amt : $unit : $sec\n";
    }
    return $sec;
}

# Parse (simplistically) the given apache config file for TKTAuth directives
sub parse_conf
{
    my $self = shift;
    my ($conf) = @_;

    my %seen = ();
    open CF, "<$conf" or
        die "[$me] open of config file '$conf' failed: $!";

    # Take settings from first instance of each TKTAuth directive found
    local $/ = "\n";
    while (<CF>) {
        if (m/^\s*(${PREFIX}\w+)\s+(.*)/) {
            $seen{$1} = $2 unless exists $seen{$1};
        }
    }

    close CF;
    die "[$me] TKTAuthSecret directive not found in config file '$conf'"
        unless $seen{TKTAuthSecret};

    # Set directives as $self attributes
    my %merge = ( %seen );
    for my $directive (keys %merge) {
        local $_ = $directive;
        s/^TKTAuth(\w)/\L$1/;
        s/([a-z])([A-Z]+)/\L$1_$2/g;
        $merge{$directive} =~ s/^"([^"]+)"$/$1/ if $merge{$directive};
        if ($BOOLEAN{$directive}) {
            $merge{$directive} = 0 
                if $merge{$directive} =~ m/^(off|no|false)$/i;
            $merge{$directive} = 1 
                if $merge{$directive} =~ m/^(on|yes|true)$/i;
        }
        elsif (defined $merge{$directive}) {
            $merge{$directive} =~ s/^\s+//;
            $merge{$directive} =~ s/\s+$//;
        }
        if ($directive eq 'TKTAuthCookieExpires' || $directive eq 'TKTAuthTimeout') {
          $self->{$_} = $self->convert_time_seconds($merge{$directive});
        }
        # Don't allow TKTAuthDebug to turn on debugging here
        elsif ($directive ne 'TKTAuthDebug') {
          $self->{$_} = $merge{$directive};
        }
    }
}

# Process constructor args
sub init
{
    my $self = shift;
    my %arg = @_;

    # Check for invalid args
    for (keys %arg) {
        croak "[$me] invalid argument to constructor: $_" unless exists $ATTR{$_};
    }

    # Parse config file if set
    if ($arg{conf}) {
        $self->parse_conf($arg{conf});
    }

    # Store/override from given args
    $self->{$_} = $arg{$_} foreach keys %arg;

    croak "[$me] bad constructor - 'secret' or 'conf' argument required"
        unless $self->{conf} || $self->{secret};
    croak "[$me] invalid digest_type '" . $self->{digest_type} . "'"
        unless $DIGEST_TYPE{ $self->{digest_type } };

    $self;
}

# Constructor
sub new
{
    my $class = shift;
    my $self = { %DEFAULTS };
    bless $self, $class;
    $self->init(@_);
}

# Setup autoload accessors/mutators
sub AUTOLOAD {
    my $self = shift;
    my $attr = $AUTOLOAD;
    $attr =~ s/.*:://;
    die qq(Can't locate object method "$attr" via package "$self")
        unless $ATTR{$attr};
    @_ and $self->{$attr} = $_[0];
    return $self->{$attr};
}

sub DESTROY {}

sub errstr
{

AuthTkt.pm  view on Meta::CPAN

Tickets are generated using the ticket() method with named parameters:

    # Generate ticket
    $ticket = $at->ticket(uid => $username);

Ticket returns undef on error, with error information available via
the errstr() method:
 
    $ticket = $at->ticket or die $at->errstr;

ticket() accepts the following arguments, all optional:

=over 4

=item uid

uid, username, or other user identifier for this ticket. There is no
requirement that this be unique per-user. Default: 'guest'.

=item ip_addr

IP address associated with this ticket. Default: if $at->ignore_ip
is true, then '0.0.0.0', otherwise $ENV{REMOTE_ADDR};

=item tokens

A comma-separated list of tokens associated with this user. Typically
only used if you are using the mod_auth_tkt TKTAuthToken directive.
Default: none.

=item data

Arbitrary user data to be stored for this ticket. This data is included
in the MD5 hash check. Default: none.

=item base64

Flag used to indicate whether to base64-encode the ticket. Default: 1.

=item ts

Explicitly set the timestamp to use for this ticket. Only for testing!

=back


As an alternative to ticket(), the cookie() method can be used to 
return the generated ticket in cookie format. cookie() returns undef 
on error, with error information available via the errstr() method:

    $cookie = $at->cookie or die $at->errstr;

cookie() supports all the same arguments as ticket(), plus the 
following:

=over 4

=item cookie_name

Cookie name. Should match the TKTAuthCookieName directive, if you're
using it. Default: $at->cookie_name, or 'auth_tkt'.

=item cookie_domain

Cookie domain. Should match the TKTAuthDomain directive, if you're
using it. Default: $at->domain.

=item cookie_path

Cookie path. Default: '/'.

=item cookie_secure

Flag whether to set the 'secure' cookie flag, so that the cookie is 
returned only in HTTPS contexts. Default: $at->require_ssl, or 0.

=back

=head2 TICKET PARSING AND VALIDATION

You may parse and validate existing tickets with the validate_ticket() 
method. It takes as its first parameter the ticket to be validated, and
then an optional list of named parameter overrides 
(e.g. ip_addr => 'x.x.x.x'). If the ticket is valid, validate_ticket 
returns a hashref with the following key/value pairs:

=over 4

=item digest

=item ts

=item uid

=item tokens

=item data

=back

validate_ticket() will return undef if any errors with the ticket value 
are encountered.

The validate_ticket() method algorithm is analogous to the function with
the same name in the mod_auth_tkt C module.

There is also a parse_ticket() method available that parses the ticket
without running it through the validation phase, and returns the same
data as validate_ticket(). This is only safe to use where you are certain
that the ticket has been validated elsewhere. In general it's considerably
safer to just use validate_ticket.


=head2 DIGEST TYPES

As of version 2.1.0, mod_auth_tkt supports multiple digest types. The
following digest_types are currently supported:

=over 4

=item MD5

The current default, for backwards compatibility. Requires the Digest::MD5
perl module.

=item SHA256

Requires the Digest::SHA perl module.

=back