
package Text::Wigwam::Directives::auth;

    use strict;
    use warnings;
    no warnings 'uninitialized';
    our $VERSION = '0.01';

    use Text::Wigwam::Const qw(:all);

# -------------------------------------------------------------------------
# constructor
# -------------------------------------------------------------------------

# write a more general constructor

sub _proto_new { [ ] }
sub _new { return &new_auth(@_); }
sub  new_auth { return EvilAuth->new("dbi:Pg:dbname=auth;host=192.168.200.200", "postgres", "", &headers(@_) ); }

#sub _proto_end { [ BLESSED ] }
#sub _end { return &end_auth( $_[0]->get_arg ); }
#sub end_auth { $_[0]->disconnect; return; }

# -------------------------------------------------------------------------
# user-oriented methods
# -------------------------------------------------------------------------

# user exists?

#sub _proto_user_exists { [ BLESSED, STRING ] }
#sub _user_exists { return &user_exists( $_[0]->get_arg, $_[0]->get_arg ); }
#sub  user_exists { return $_[0]->user_exists($_[1]); }

# create user

#sub _proto_create_user { [ BLESSED, STRING, STRING ] }
#sub _create_user { return &create_user( $_[0]->get_arg, $_[0]->get_arg, $_[0]->get_arg ); }
#sub  create_user { return $_[0]->create_user( $_[1], $_[2] ); }

# delete user

#sub _proto_delete_user { [ BLESSED, STRING ] }
#sub _delete_user { return &delete_user( $_[0]->get_arg, $_[0]->get_arg ); }
#sub  delete_user { return $_[0]->delete_user($_[1]); }

# see if a password is valid

#sub _proto_verify_pass { [ BLESSED, STRING, STRING ] }
#sub _verify_pass { return &verify_pass( $_[0]->get_arg, $_[0]->get_arg, $_[0]->get_arg ); }
#sub  verify_pass { return $_[0]->verify_pass($_[1], $_[2]); }

# change password

#sub _proto_change_pass { [ BLESSED, STRING, STRING ] }
#sub _change_pass { return &change_pass($_[0]->get_arg, $_[0]->get_arg, $_[0]->get_arg); }
#sub  change_pass { return $_[0]->change_pass($_[1], $_[2]); }

# -------------------------------------------------------------------------
# cookie stuff
# -------------------------------------------------------------------------

#sub _proto_verify_cookie { [ BLESSED, STRING, STRING ] }
#sub _verify_cookie { return &verify_cookie( $_[0]->get_arg, $_[0]->get_arg, $_[0]->get_arg ); }
#sub  verify_cookie { $_[1] =~ s/%3B/;/g; return $_[0]->weak_token( $_[1] ) eq $_[2]; }

#sub _proto_set_cookie { [ BLESSED, STRING ]; }
#sub _set_cookie { return &set_cookie(&headers, $_[0]->get_arg, $_[0]->get_arg); }
#sub  set_cookie {
#    my $enc_user = $_[2]; $enc_user =~ s/;/%3B/g;
#    $_[0]->add("Set-Cookie", $_[1]->user_cookie( $enc_user ));
#    $_[0]->add("Set-Cookie", $_[1]->auth_cookie( $_[2] ));
#    return;
#}

#sub _proto_zap_cookie { [ BLESSED ] }
#sub _zap_cookie { return &zap_cookie( &headers, $_[0]->get_arg ); }
#sub  zap_cookie {
#    $_[0]->add( "Set-Cookie", $_[1]->user_cookie() );
#    $_[0]->add( "Set-Cookie", $_[1]->auth_cookie() );
#    return;
#}

sub headers{ return $_[0]->get_global( 'global' )->{http}{Headers}; }

##############################################################################
# Ammended stuff
##############################################################################

sub _proto_logon_user { [ BLESSED, STRING ]; }
sub _logon_user { return &logon_user( $_[0]->get_arg, $_[0]->get_arg ); }
sub  logon_user { return $_[0]->logon_user($_[1]); }

sub _proto_fetch_user_profile{ [ BLESSED, STRING ]; }
sub _fetch_user_profile{ return &fetch_user_profile( $_[0]->get_arg, $_[0]->get_arg ); }
sub  fetch_user_profile { return $_[0]->fetch_user_profile( $_[1] ); }

# trim spaces from a string

sub _proto_trim{ [ STRING ]; }
sub _trim{ return &trim( $_[0]->get_arg ); }
sub trim{
    my $val = shift;
    $val =~ s/^\s+//g;
    $val =~ s/(.*?)\s+$/$1/g;
    return $val;
}

# check username for validity

sub _proto_valid_username{ [ STRING ]; }
sub _valid_username{ return &valid_username( $_[0]->get_arg ); }
sub xvalid_username{
    my $illegal = quotemeta( '^#%&\/|+=~<>,`{}[] ?();:$*' );
    return $_[0] =~ /^[a-zA-Z0-9][^$illegal]{2,}$/;
}
sub valid_username{ return $_[0] =~ /^[_a-zA-Z0-9]{3,}$/; }



package EvilAuth;

use Digest::MD5;
use DBI;
use strict;

# update the last_logon timestamp...
# update password set last_logon=now() where username='Dan';

# create auth table:
#CREATE TABLE "password" (
#    username character varying(80),
#    "password" character varying(80),
#    first_logon timestamp without time zone DEFAULT now(),
#    last_logon timestamp without time zone DEFAULT now(),
#    prev_logon timestamp without time zone
#);

# ALTER TABLE ONLY "password" ADD CONSTRAINT password_username_key UNIQUE (username);

# -------------------------------------------------------------------------
# constructor
# -------------------------------------------------------------------------

sub new {
    my ($type, $dbref, $dbuser, $dbpass, $headers) = @_;
    return bless {
        'dbref'     => $dbref,
        'dbuser'    => $dbuser,
        'dbpass'    => $dbpass,
        'mysalt'    => 'Yes I Am ',
        'headers'   => $headers,
    }, $type;
}

sub  verify_cookie { $_[1] =~ s/%3B/;/g; return $_[0]->weak_token( $_[1] ) eq $_[2]; }

sub valid_username{ return $_[0] =~ /^[_a-zA-Z0-9]{3,}$/; }

sub  zap_cookie {
    $_[0]->{headers}->add( "Set-Cookie", $_[0]->user_cookie() );
    $_[0]->{headers}->add( "Set-Cookie", $_[0]->auth_cookie() );
    return;
}

sub  set_cookie {
    my $enc_user = $_[1]; $enc_user =~ s/;/%3B/g;
    $_[0]->{headers}->add("Set-Cookie", $_[0]->user_cookie( $enc_user ));
    $_[0]->{headers}->add("Set-Cookie", $_[0]->auth_cookie( $_[1] ));
    return;
}

sub trim{
    my ($self, $val) = @_;
    $val =~ s/^\s+//g;
    $val =~ s/(.*?)\s+$/$1/g;
    return $val;
}

# -------------------------------------------------------------------------
# database connect / disconnect
# -------------------------------------------------------------------------

sub connect {
    my $au = shift;
    if (!$au->{'dbobj'}) {
        $au->{'dbobj'} =
            DBI->connect($au->{'dbref'}, $au->{'dbuser'}, $au->{'dbpass'})
              or die $DBI::errstr;
    }
    return;
}

sub disconnect {
    my $au = shift;
    if ($au->{'dbobj'}) {
        $au->{'dbobj'}->disconnect;
        delete $au->{'dbobj'};
    }
    return;
}

# -------------------------------------------------------------------------
# basic user functions
# -------------------------------------------------------------------------

# user exists

sub user_exists {
    my ($au, $user) = @_; $au->connect;
    return $au->{'dbobj'}->selectrow_array(
        "SELECT count(*) FROM password WHERE username='$user';"
    );
}

# -------------------------------------------------------------------------

# fetch password

sub fetch_pass {
    my ($au, $user) = @_;
    return $au->{'dbobj'}->selectrow_array(
        "SELECT password FROM password WHERE username='$user';"
    );
}

# verify password

sub verify_pass {
    my ($au, $user, $fake) = @_; $au->connect;
    return (!$au->user_exists($user) ? 0 : $fake eq $au->fetch_pass($user));
}

# -------------------------------------------------------------------------

# delete password

sub delete_pass {
    my ($au, $user) = @_;
    $au->{'dbobj'}->do("DELETE FROM password WHERE username='$user';");
    return "user deleted";
}

# delete user

sub delete_user {
    my ($au, $user) = @_; $au->connect;
    return (!$au->user_exists($user)
        ? "user '$user' does not exist"
        : $au->delete_pass($user)
    );
}

# -------------------------------------------------------------------------

# insert (new) password

sub insert_pass {
    my ($au, $user, $pass) = @_;
    $au->{'dbobj'}->do(
        "INSERT INTO password (username, password) VALUES ('$user', '$pass');"
    );
    return "new user added";
}

sub create_user {
    my ($au, $user, $pass) = @_; $au->connect;
    return ($au->user_exists($user)
        ? "user already exists"
        : $au->insert_pass($user, $pass)
    );
}

# -------------------------------------------------------------------------

# update (old) password

sub update_pass {
    my ($au, $user, $pass) = @_;
    $au->{'dbobj'}->do(
        "UPDATE password SET password='$pass' WHERE username='$user';"
    );
    return "user updated";
}

sub change_pass {
    my ($au, $user, $pass) = @_; $au->connect;
    return (!$au->user_exists($user)
        ? "user '$user' does not exist"
        : $au->update_pass($user, $pass)
    );
}

# -------------------------------------------------------------------------
# cookie stuff
# -------------------------------------------------------------------------

#sub weak_token { return Digest::MD5->md5_hex($_[0]->{'mysalt'}, $_[1]); }
sub weak_token { return Digest::MD5::md5_hex( $_[0]->{'mysalt'}, $_[1] ); }

sub user_cookie {
    return ($_[1]
        ? "USER=".$_[1]."; path=/;"
        : "USER=; path=/; expires=Thu, 01-Jan-70 00:00:01 GMT"
    );
}

sub auth_cookie {
    return ($_[1]
        ? "AUTH=".$_[0]->weak_token( $_[1] )."; path=/;"
        : "AUTH=; path=/; expires=Thu, 01-Jan-70 00:00:01 GMT"
    );
}

sub fetch_user_profile {
    my ($au, $user) = @_;
    return $au->{'dbobj'}->selectrow_hashref(
        "SELECT username, first_logon, prev_logon, extract ( epoch from first_logon ) as unique_id0, trunc(extract ( epoch from first_logon )) as unique_id1 , trunc(extract ( epoch from first_logon )) || username as unique_id2 , username || trunc(extract ( epoch from first_logon )) as unique_id3, username || ':' || trunc(extract ( epoch from first_logon )) as unique_id4, trunc(extract ( epoch from first_logon ))  || ':' || username as unique_id5 FROM password WHERE username=".$au->{'dbobj'}->quote($user).";"
    );
}

sub logon_user {
    my ($au, $user) = @_; $au->connect;
    return $au->{'dbobj'}->do(
        "update password set prev_logon=last_logon, last_logon=now() where username=".$au->{'dbobj'}->quote($user).";"
    );
}

1;
