File Coverage

blib/lib/Apache/AuthTkt.pm

Criterion	Covered	Total	%
statement	138	152	90.7
branch	66	82	80.4
condition	16	21	76.1
subroutine	16	18	88.8
pod	0	9	0.0
total	236	282	83.6

#
# 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 () {
        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
{
    my $self = shift;
    $@[0] and $self->{errstr} = join ' ', @_;
    $self->{errstr};
}

# Return a mod_auth_tkt ticket containing the given user details
sub ticket
{
    my $self = shift;
    my %DEFAULTS = (
        base64 => 1,
        data => '',
        tokens => '',
    );
    my %arg = ( %DEFAULTS, %$self, @_ );
    $arg{uid} = $self->guest_user unless exists $arg{uid};
    $arg{ip_addr} = $arg{ignore_ip} ? '0.0.0.0' : $ENV{REMOTE_ADDR}
        unless exists $arg{ip_addr};
    # 0 or undef ip_addr treated as 0.0.0.0
    $arg{ip_addr} ||= '0.0.0.0';

    # Data cleanups
    if ($arg{tokens}) {
        $arg{tokens} =~ s/\s+,/,/g;
        $arg{tokens} =~ s/,\s+/,/g;
    }

    # Data checks
    if ($arg{ip_addr} !~ m/^([12]?[0-9]?[0-9]\.){3}[12]?[0-9]?[0-9]$/) {
        $self->errstr("invalid ip_addr '$arg{ip_addr}'");
        return undef;
    }
    if ($arg{tokens} =~ m/[!\s]/) {
        $self->errstr("invalid chars in tokens '$arg{tokens}'");
        return undef;
    }

    # Calculate the hash for the ticket
    my $ts = $arg{ts} || time;
    my $digest = $self->_get_digest($ts, $arg{ip_addr}, $arg{uid}, $arg{tokens},
        $arg{data}, $arg{debug});

    # Construct the ticket itself
    my $ticket = sprintf "%s%08x%s!", $digest, $ts, $arg{uid};
    $ticket .= $arg{tokens} . '!' if $arg{tokens};
    $ticket .= $arg{data};

    return $arg{base64} ? encode_base64($ticket, '') : $ticket;
}

sub _get_digest_function
{
    my $self = shift;

    die "Invalid digest_type '" . $self->digest_type . "'\n"
        unless $DIGEST_TYPE{ $self->digest_type };

    my ($module, $func) = @{ $DIGEST_TYPE{ $self->digest_type } };
    eval "require $module";
    return eval "\\&${module}::$func";
}

sub _get_digest
{
    my ($self, $ts, $ip_addr, $uid, $tokens, $data, $debug) = @_;
    my @ip = split /\./, $ip_addr;
    my @ts = ( (($ts & 0xff000000) >> 24),
               (($ts & 0xff0000) >> 16),
               (($ts & 0xff00) >> 8),
               (($ts & 0xff)) );
    my $ipts = pack("C8", @ip, @ts);
    my $raw = $ipts . $self->secret . $uid . "\0" . $tokens . "\0" . $data;
    my $digest_function = $self->_get_digest_function;
    my $digest0 = $digest_function->($raw);
    my $digest  = $digest_function->($digest0 . $self->secret);

    if ($debug) {
        print STDERR "ts: $ts\nip_addr: $ip_addr\nuid: $uid\ntokens: $tokens\ndata: $data\n";
        print STDERR "secret: " . $self->secret . "\n";
        print STDERR "raw: '$raw'\n";
        my $len = length($raw);
        print STDERR "digest0: $digest0 (input length $len)\n";
        print STDERR "digest: $digest\n";
    }

    return $digest;
}

# Return a cookie containing a mod_auth_tkt ticket
sub cookie
{
    my $self = shift;
    my %DEFAULTS = (
        cookie_name => 'auth_tkt',
        cookie_path => '/',
    );
    my %arg = ( %DEFAULTS, %$self, @_ );
    $arg{cookie_domain} ||= $self->domain;

    # Get ticket, forcing base64 for cookies
    my $ticket = $self->ticket(@_, base64 => 1) or return;

    my $cookie_fmt = "%s=%s%s%s%s";
    my $path_elt = "; path=$arg{cookie_path}";
    my $domain_elt = $arg{cookie_domain} ? "; domain=$arg{cookie_domain}" : '';
    my $secure_elt = $arg{cookie_secure} ? "; secure" : '';
    return sprintf $cookie_fmt,
           $arg{cookie_name}, $ticket, $domain_elt, $path_elt, $secure_elt;
}

# Returns a hashref representing the original ticket components
# Returns undef if there were any errors
sub validate_ticket
{
    my $self = shift;
    my $ticket = shift || croak "No ticket passed to validate_ticket";
    my %arg = ( %$self, @_ );

    $arg{ip_addr} = $arg{ignore_ip} ? '0.0.0.0' : $ENV{REMOTE_ADDR}
        unless exists $arg{ip_addr};
    # 0 or undef ip_addr treated as 0.0.0.0
    $arg{ip_addr} ||= '0.0.0.0';

    # Parse ticket
    my $info = $self->parse_ticket($ticket);

    # Validate digest
    my $expected_digest = $self->_get_digest(
        $info->{ts}, $arg{ip_addr}, $info->{uid},
        $info->{tokens}, $info->{data});

    return $info if $expected_digest eq $info->{digest};
    return undef;
}

sub parse_ticket
{
    my $self    = shift;
    my $ticket  = shift or croak "No ticket passed to parse_ticket";
    my $parts   = {};

    # Strip possible quotes
    $ticket =~ s,^"|"$,,g;

    return if length($ticket) < 40;

    # Assume $ticket is not URL-escaped but may be base64-escaped
    my $raw = $ticket =~ m/!/ ? $ticket : decode_base64($ticket);

    # If $raw still doesn't have ! then it is bogus
    return if $raw !~ m/!/;

    # Deconstruct
    my ($digest,$ts,$uid,$extra) = ($raw =~ m/^(.{32})(.{8})(.+?)!(.*)$/);
    $parts->{digest} = $digest;
    $parts->{ts}  = hex($ts);
    $parts->{uid} = $uid;
    $parts->{tokens} = '';
    $parts->{data} = '';

    # Tokens and data if present
    if (defined $extra) {
        if ($extra =~ m/!/) {
            ($parts->{tokens},$parts->{data}) = split m/!/, $extra, 2;
        }
        else {
            $parts->{data} = $extra;
        }
    }
    return $parts;
}

# Alias for compatibility with Jose/Ton's original patch
*valid_ticket = \&validate_ticket;

1;

__END__