libticket-simple-perl 0.0.2-4 / usr / share / perl5 / Ticket / Simple.pm

# +=========================================================================+
# || Ticket::Simple                                                        ||
# || A basic ticket system                                                 ||
# +=========================================================================+
# Id:     $Id$
# Rev:    $Revision$
# Source: $Source$
# Date:   $Date$
# URL:    $HeadURL$

package Ticket::Simple;

use strict;
use warnings;
use Carp qw(confess);
use Class::Std;
use Digest::MD5 qw(md5_hex);
use Log::Log4perl qw(get_logger :levels);
use Readonly;
use Time::HiRes qw(gettimeofday);

{    # begin insite out class

    # PRIVATE METHODS
    # - seed
    # PUBLIC METHODS
    # - create_ticket

    use version; our $VERSION = qv('v0.0.2');
    use re 'taint';    # Keep data captured by parens tainted
    delete @ENV{qw(PATH IFS CDPATH ENV BASH_ENV)};    # Make %ENV safe

    # CONST
    Readonly::Scalar my $EMPTY_STRING  => q{};
    Readonly::Scalar my $TICKET_LENGTH => 32;
    Readonly::Scalar my $SEED_LENGTH   => 1282;
    Readonly::Array my @RND_SEED_CHARS =>
        ( 'A' .. 'Z', 'a' .. 'z', 0 .. 9, qw(! @ $ % &) );
    Readonly::Scalar my $SEED => seed();
    Readonly::Scalar my $TTL  => 600;                 # in sec

    # OBJ
    ## no critic
    my %ttl_of : ATTR( init_arg =>'ttl' :get<ttl> :set<ttl> :default(600));

    # GLOBAL
    my %cred = ();

    # define a closure for log4perl
    my $ifdef = sub {
        my $v = shift;
        return sub { return $v if defined $v; return 'UNDEF'; };
    };

    sub now {

        my ( $self, $p_r ) = @_;
        my $l = get_logger(__PACKAGE__);

        my ( $seconds, $microseconds ) = gettimeofday;
        $l->debug("time now [$seconds] seconds");
        $l->debug("time now [$microseconds] micro-seconds");

        my $now = "$seconds.$microseconds";
        $l->debug("time now [$now] time");

        return $now;
    }

    sub create_ticket {

        my ( $self, $p_r ) = @_;
        my $msg = 'parameter [login] is missing in sub call [create_ticket]';
        my $login = exists $p_r->{login} ? $p_r->{login} : confess $msg;
        my $time = exists $p_r->{time} ? $p_r->{time} : $self->now;

        my $l = get_logger(__PACKAGE__);

        # prepare
        $l->debug("input parameter login: [$login]");
        $l->debug("global parameter SEED: [$SEED]");

        my $ttl
            = (     exists $ttl_of{ ident $self}
                and defined > $ttl_of{ ident $self}
                and $ttl_of{ ident $self} > 0 )
            ? $ttl_of{ ident $self}
            : $TTL;
        $l->debug( 'ttl: ', $ttl );

        # main
        my ( $seconds, $microseconds ) = split m{\.}mx, $time;
        $l->debug("time [$seconds] seconds");
        $l->debug("time [$seconds] micro-seconds");
        my $valid = $seconds + $ttl . ".$microseconds";
        $l->debug("valid until [$valid] seconds.micro-seconds");

        my $ticket = md5_hex( join $EMPTY_STRING, $valid, $SEED, $login );
        $l->info("new ticket [$ticket]");

        return ( $ticket, $valid );
    }

    sub wipe_ticket {

        my ( $self, $p_r ) = @_;
        my $msg = 'parameter [login] is missing in sub call [wipe_ticket]';
        my $login = exists $p_r->{login} ? $p_r->{login} : confess $msg;

        $self->store_ticket(
            { login => $login, ticket => $EMPTY_STRING, valid => 0 } );

        return 1;

    }

    sub destroy_ticket {

        my ( $self, $p_r ) = @_;
        my $msg = 'parameter [login] is missing in sub call [destroy_ticket]';
        my $login = exists $p_r->{login} ? $p_r->{login} : confess $msg;

        $self->store_ticket(
            { login => $login, ticket => undef, valid => undef } );

        return 1;

    }

    sub fetch_ticket {

        my ( $self, $p_r ) = @_;
        my $msg = 'parameter [login] is missing in sub call [fetch_ticket]';
        my $login = exists $p_r->{login} ? $p_r->{login} : confess $msg;

        my $ticket = $cred{$login}->{ticket};
        my $valid  = $cred{$login}->{valid};

        return ( $ticket, $valid );
    }

    sub store_ticket {

        my ( $self, $p_r ) = @_;
        my $m = 'parameter [login] is missing in sub call [store_ticket]';
        my $l = exists $p_r->{login} ? $p_r->{login} : confess $m;
        $m = 'parameter [ticket] is missing in sub call [store_ticket]';
        my $t = exists $p_r->{ticket} ? $p_r->{ticket} : confess $m;
        $m = 'parameter [valid] is missing in sub call [store_ticket]';
        my $v = exists $p_r->{valid} ? $p_r->{valid} : confess $m;
        my $go = get_logger(__PACKAGE__);

        # undef can be stored also (see destroy)
        $go->debug( 'login: ',  { filter => $ifdef->($l) } );
        $go->debug( 'ticket: ', { filter => $ifdef->($t) } );
        $go->debug( 'value: ',  { filter => $ifdef->($v) } );
        $cred{$l} = { ticket => $t, valid => $v, };

        return 1;
    }

    sub is_ticket_equal_stored {

        my ( $self, $p_r ) = @_;
        my $msg = 'parameter [login] is missing in sub call [store_ticket]';
        my $login = exists $p_r->{login} ? $p_r->{login} : confess $msg;
        $msg = 'parameter [ticket] is missing in sub call [store_ticket]';
        my $ticket = exists $p_r->{ticket} ? $p_r->{ticket} : confess $msg;

        my ( $stored_ticket, $valid )
            = $self->fetch_ticket( { login => $login } );

        if ( $stored_ticket eq $ticket ) {
            return 1;
        }
        else {
            return 0;
        }

    }

    sub is_ticket_valid_now {

        my ( $self, $p_r ) = @_;
        my $msg = 'parameter [login] is missing in sub call [store_ticket]';
        my $login = exists $p_r->{login} ? $p_r->{login} : confess $msg;
        $msg = 'parameter [ticket] is missing in sub call [store_ticket]';
        my $ticket = exists $p_r->{ticket} ? $p_r->{ticket} : confess $msg;

        my $r = $self->is_ticket_valid(
            { login => $login, ticket => $ticket, time => $self->now } );

        return $r;

    }

    sub is_ticket_valid {

        my ( $self, $p_r ) = @_;
        my $m = 'param. [login] is missing in sub call [is_ticket_valid]';
        my $l = exists $p_r->{login} ? $p_r->{login} : confess $m;
        $m = 'param. [ticket] is missing in sub call [is_ticket_valid]';
        my $t = exists $p_r->{ticket} ? $p_r->{ticket} : confess $m;
        $m = 'param. [time] is missing in sub call [is_ticket_valid]';
        my $j = exists $p_r->{time} ? $p_r->{time} : confess $m;

        my $go = get_logger(__PACKAGE__);

        my ( $s, $v ) = $self->fetch_ticket( { login => $l } );
        if (    defined $s
            and defined $t
            and $s eq $t
            and length $t == $TICKET_LENGTH
            and defined $j
            and defined $v
            and $j <= $v
            and $j > 0 )
        {
            return 1;    # SUCCESS
        }
        else {
            $go->debug(
                'login: ',
                {
                    filter => sub { return $l if defined $l }
                }
            );
            $go->debug( 'login: ',         { filter => $ifdef->($l) } );
            $go->debug( 'got ticket: ',    { filter => $ifdef->($t) } );
            $go->debug( 'stored ticket: ', { filter => $ifdef->($s) } );
            $go->debug( 'got valid: ',     { filter => $ifdef->($j) } );
            $go->debug( 'stored valid: ',  { filter => $ifdef->($v) } );
            return 0;    # FAILURE

        }
        return 0;        # FAILURE
    }

    sub seed : PRIVATE {

        # sub will be executed in readonly section!
        Log::Log4perl::init_once( log_cfg() );
        my $l = get_logger(__PACKAGE__);

        # Calculating secret random seed for this session
        # "S ISp&FtR0z$EU!We8DvpUzC26D0RE1pVW8vSXp9at5RUwXk
        # WesmQvJY!w!LrLHdo^wB7f6lr7U9PGPTYhxTI!PhKjXhMmZZK
        # ckIi^Qbl&g^$Qir!9S5LIoo!J1bX*OHVw"

        srand;
        my @chars = @RND_SEED_CHARS;
        my $seed  = join q{},
            @chars[ map { rand @chars } ( 1 .. $SEED_LENGTH ) ];

        $l->debug("new seed [$seed]");

        return $seed;
    }

    sub log_cfg {

        my $cfg = <<'EOF';
  log4perl.category.Ticket::Simple = WARN, S
  log4perl.appender.S        = Log::Log4perl::Appender::ScreenColoredLevels
  log4perl.appender.S.stderr = 0
  log4perl.appender.S.layout = Log::Log4perl::Layout::PatternLayout
  log4perl.appender.S.layout.ConversionPattern = %d{yyyy-MM-dd+HH:mm:ss} %M <%L>: %m%n
EOF

        return \$cfg;
    }

}    # end insite out class

1;
__END__

=pod

=for stopwords Christian Kuelker log_cfg

=head1 NAME

Ticket::Simple - A basic ticket system.

=head1 VERSION

version v0.0.2

=head1 SYNOPSIS

 my $ts=Ticket::Simple->new();

or

 my $ts=Ticket::Simple->new({ttl=>600});


=head1 DESCRIPTION

Provides a simple ticket system for  creating, storing, fetching, comparing
user assigned tickets.


=head1 SUBROUTINES/METHODS

=head2 create_ticket

=head2 wipe_ticket

=head2 destroy_ticket

=head2 fetch_ticket

=head2 is_ticket_equal_stored

=head2 is_ticket_valid

=head2 is_ticket_valid_now

Test if the ticket was issued

=head2 now

=head2 seed

=head2 store_ticket

=head2 log_cfg

=head2 set_ttl

=head2 get_ttl

=head1 DIAGNOSTICS



=head1 CONFIGURATION AND ENVIRONMENT

No external configuration needed.

=head1 DEPENDENCIES

  Carp;
  Class::Std
  Digest::MD5
  Log::Log4perl
  Readonly
  Time::HiRes
  version

=head1 INCOMPATIBILITIES

Not known.

=head1 BUGS AND LIMITATIONS

Not known.

=head1 AUTHOR

Christian Kuelker E<lt>christian.kuelker@cipworx.orgE<gt>

=head1 LICENSE AND COPYRIGHT

Copyright (C) 2009 by Christian Kuelker

This program is free software; you can redistribute it and/or
modify it under the terms of the GNU General Public License as
published by the Free Software Foundation; either version 2, or (at
your option) any later version.

This program is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
General Public License for more details.

You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
02111-1307 USA

=cut