#!/usr/bin/perl

# $Id: UserRecord.pm,v 1.10 2004/06/27 07:45:43 eric Exp $

# Copyright Massachusetts Institute of technology, 2002.
# Written by Eric Prud'hommeaux

# Things that need to be done:
# 1: write it

#####
# What It Does:

use strict;

package W3C::Annotations::UserRecord::UserNotFoundException;
@W3C::Annotations::UserRecord::UserNotFoundException::ISA = qw(W3C::Util::Exception);

sub new {
    my ($proto, @parms) = @_;
    my $class = ref($proto) || $proto;
    my $self = $class->SUPER::new(@parms);
    $self->missingParm('-username') if (!exists $self->{-username});
    $self->fillInStackTrace;
    return $self;
}
sub getSpecificMessage {return 'no record found for user "'.$_[0]->getUsername.'"'.$_[0]->_getDatabaseFromString}
sub getUsername {return $_[0]->{-username}}
sub getDatabase {return $_[0]->{-database}}
sub _getDatabaseFromString {return $_[0]->{-database} ? ' from '.$_[0]->{-database} : ''}

@W3C::Annotations::UserRecord::Exception::ISA = qw(W3C::Util::Exception);

package W3C::Annotations::UserRecord::UserIdException;
@W3C::Annotations::UserRecord::UserIdException::ISA = qw(W3C::Annotations::UserRecord::Exception);

sub new {
    my ($proto, @parms) = @_;
    my $class = ref($proto) || $proto;
    my $self = $class->SUPER::new(@parms);
    $self->missingParm('-userid') if (!exists $self->{-userid});
    $self->fillInStackTrace;
    return $self;
}
sub getSpecificMessage {return 'user ID "'.$_[0]->getUserid.'" not recognized'}
sub getUserid {return $_[0]->{-userid}}

package W3C::Annotations::UserRecord::AccessException;
@W3C::Annotations::UserRecord::AccessException::ISA = qw(W3C::Annotations::UserRecord::Exception);

sub new {
    my ($proto, @parms) = @_;
    my $class = ref($proto) || $proto;
    my $self = $class->SUPER::new(@parms);
    $self->missingParm('-userid') if (!exists $self->{-userid});
    $self->fillInStackTrace;
    return $self;
}
sub getSpecificMessage {return 'user ID "'.$_[0]->getUserid.'" not recognized'}
sub getUserid {return $_[0]->{-userid}}

package W3C::Annotations::UserRecord;

# W3C perl modules
use W3C::Util::Object;
use W3C::Util::Exception;

use vars qw(@ISA @EXPORT_OK $RECORD_VERSION);
@ISA = qw(W3C::Util::NamedParmObject);
@EXPORT_OK = qw($RW_read $RW_write $STATUS_disabled $STATUS_fresh
		$STATUS_NOT_fresh $OPTIONS_idByEmail $OPTIONS_idByName
		&parseUserEntry &parsePendingEntry);

# constants - enums
use vars qw($RW_read $RW_write);
$RW_read = \ "read";
$RW_write = \ "write";
my $RW_read = $RW_read;
my $RW_write = $RW_write;



# constants - status
use vars qw($STATUS_disabled $STATUS_fresh $STATUS_NOT_fresh $OPTIONS_idByEmail $OPTIONS_idByName);
$STATUS_disabled = 0x01;
$STATUS_fresh = 0x02;
$STATUS_NOT_fresh = 0xfffffffd;
$OPTIONS_idByEmail = 0x1;
$OPTIONS_idByName = 0x2;

# We use an integer version number to label user records so we know what format
# to parse. When we change the record structure, we change the version, and
# write code to read and bootstrap previous versions.
# When changing the serialized structure of a user record:
#   $RECORD_VERSION++.
#   Add bootstrapping code for all previous versions in parseUserEntry.
#   Add a elsif ($recordVersion == --current version==) in parseUserEntry.
# These steps should be performed atomically or inconsistent records will
# be written to users and pending.

$RECORD_VERSION = 2;

sub new {
    my ($proto, @parms) = @_;
    my $class = ref($proto) || $proto;
    my $self = $class->SUPER::new(@parms);

    $self->{STATUS} = $STATUS_fresh;
    $self->{OPTIONS} = 0;

    return $self;
}

sub escape ($) {
    my ($toEscape) = @_;
    $toEscape =~ s/_/_u/g;
    $toEscape =~ s/\:/_c/g;
    return $toEscape;
}

sub unescape ($) {
    my ($toUnescape) = @_;
    $toUnescape =~ s/_c/\:/g;
    $toUnescape =~ s/_u/_/g;
    return $toUnescape;
}

sub parseUserEntry { # static
    my ($user, $entryString) = @_;
    my $self = new W3C::Annotations::UserRecord();
    $self->{USER} = $user;
    my ($firstField, $recordVersion, $rest) = split(/:/, $entryString, 3);
    if ($recordVersion == 0) {
	# early version-less version
	$self->{HASHED} = $firstField;
	$self->{VERSION} = 0;
	($self->{STATUS}, $self->{EMAIL}, $self->{FAMILY}, 
	 $self->{GIVEN}, $self->{MODIFY}, $self->{CREATE}) = split(/:/, $rest);
	$self->{CLEARTXT} = undef;
	$self->{OPTIONS} = 0;
	if ($self->{STATUS} & 0x10) {
	    $self->{OPTIONS} |= $OPTIONS_idByEmail;
	}
	if ($self->{STATUS} & 0x20) {
	    $self->{OPTIONS} |= $OPTIONS_idByName;
	}
	$self->{STATUS} &= 0x0f;
    } elsif ($recordVersion == 1) {
	$self->{HASHED} = $firstField;
	$self->{VERSION} = 1;
	($self->{STATUS}, $self->{CLEARTXT}, $self->{EMAIL}, $self->{FAMILY}, 
	 $self->{GIVEN}, $self->{MODIFY}, $self->{CREATE}) = split(/:/, $rest);
	$self->{CLEARTXT} =~ tr/a-zA-Z/n-za-mN-ZA-M/; # de-rot13
	$self->{OPTIONS} = 0;
	if ($self->{STATUS} & 0x10) {
	    $self->{OPTIONS} |= $OPTIONS_idByEmail;
	}
	if ($self->{STATUS} & 0x20) {
	    $self->{OPTIONS} |= $OPTIONS_idByName;
	}
	$self->{STATUS} &= 0x0f;
    } elsif ($recordVersion == 2) {
	$self->{HASHED} = $firstField;
	$self->{VERSION} = 2;
	($self->{STATUS}, $self->{OPTIONS}, $self->{CLEARTXT}, $self->{EMAIL}, 
	 $self->{FAMILY}, $self->{GIVEN}, $self->{MODIFY}, $self->{CREATE}) = 
	     split(/:/, $rest);
	$self->{CLEARTXT} = &unescape($self->{CLEARTXT});
	$self->{CLEARTXT} =~ tr/a-zA-Z/n-za-mN-ZA-M/; # de-rot13
	$self->{EMAIL} = &unescape($self->{EMAIL});
	$self->{FAMILY} = &unescape($self->{FAMILY});
	$self->{GIVEN} = &unescape($self->{GIVEN});
    } else {
	&throw(new W3C::Util::Exception(-message => "unsupported user record version \"$recordVersion\""));
    }
    return $self;
}

sub buildUserEntry {
    my ($self) = @_;
    my $modify = time();
    my $hashed = &escape($self->{HASHED});
    my $cleartxt = $self->{CLEARTXT};
    $cleartxt =~ tr/a-zA-Z/n-za-mN-ZA-M/; # rot13
    $cleartxt = &escape($cleartxt);
    my $email = &escape($self->{EMAIL});
    my $family = &escape($self->{FAMILY});
    my $given = &escape($self->{GIVEN});
    my $ret = "$hashed:$RECORD_VERSION:$self->{STATUS}:$self->{OPTIONS}:$cleartxt:$email:$family:$given:$modify:$self->{CREATE}";
    return $ret;
}

sub parsePendingEntry { # static
    my ($user, $entryString) = @_;
    my ($nonce, $rest) = split (/:/, $entryString, 2);
    my $self = W3C::Annotations::UserRecord::parseUserEntry($user, $rest);
    $self->{NONCE} = $nonce;
    return $self;
}

sub buildPendingEntry {
    my ($self) = @_;
    my $userEntry = $self->buildUserEntry;
    return "$self->{NONCE}:$userEntry";
}

sub getNonce {
    my ($self) = @_;
    return $self->{NONCE};
}

sub setNonce {
    my ($self, $nonce) = @_;
    $self->{NONCE} = $nonce;
}

sub getHashed {
    my ($self) = @_;
    return $self->{HASHED};
}

sub setHashed {
    my ($self, $hashed) = @_;
    $self->{HASHED} = $hashed;
}

sub getStatus {
    my ($self) = @_;
    return $self->{STATUS};
}

sub setStatus {
    my ($self, $status) = @_;
    $self->{STATUS} = $status;
}

sub getOptions {
    my ($self) = @_;
    return $self->{OPTIONS};
}

sub setOptions {
    my ($self, $options) = @_;
    $self->{OPTIONS} = $options;
}

sub getPassword {
    my ($self) = @_;
    return $self->{CLEARTXT};
}

sub setPassword {
    my ($self, $password) = @_;
    $self->{CLEARTXT} = $password;
}

sub getByEmail {
    my ($self) = @_;
    return ($self->getOptions & $OPTIONS_idByEmail) == $OPTIONS_idByEmail;
}

sub getByName {
    my ($self) = @_;
    return ($self->getOptions & $OPTIONS_idByName) == $OPTIONS_idByName;
}

sub getUser {
    my ($self) = @_;
    return $self->{USER};
}

sub setUser {
    my ($self, $user) = @_;
    $self->{USER} = $user;
}

sub getEmail {
    my ($self) = @_;
    return $self->{EMAIL};
}

sub setEmail {
    my ($self, $email) = @_;
    $self->{EMAIL} = $email;
}

sub getFamily {
    my ($self) = @_;
    return $self->{FAMILY};
}

sub setFamily {
    my ($self, $family) = @_;
    $self->{FAMILY} = $family;
}

sub getGiven {
    my ($self) = @_;
    return $self->{GIVEN};
}

sub setGiven {
    my ($self, $given) = @_;
    $self->{GIVEN} = $given;
}

sub getModify {
    my ($self) = @_;
    return $self->{MODIFY};
}

sub setModify {
    my ($self, $modify) = @_;
    $self->{MODIFY} = $modify;
}

sub getCreate {
    my ($self) = @_;
    return $self->{CREATE};
}

sub setCreate {
    my ($self, $create) = @_;
    $self->{CREATE} = $create;
}

sub toString {
    my ($self, $flags) = @_;
    my @ret;
    push (@ret, "nonce: $self->{NONCE}");
    push (@ret, "hashed: $self->{HASHED}");
    my $s = "";
    if ($self->{STATUS} & $W3C::Annotations::DBMUserRecords::STATUS_fresh) {
	$s .= " fresh";
    }
    if ($self->{STATUS} & $W3C::Annotations::DBMUserRecords::STATUS_disabled) {
	$s .= " disabled";
    }
    $s =~ s/^ //;
    push (@ret, "status: $self->{STATUS} [$s]");
    my $o = "";
    if ($self->{OPTIONS} & $OPTIONS_idByEmail) {
	$o .= " idByEmail";
    }
    if ($self->{OPTIONS} & $OPTIONS_idByName) {
	$o .= " idByName";
    }
    $o =~ s/^ //;
    push (@ret, "options: $self->{OPTIONS} [$o]");
    push (@ret, "user: $self->{USER}");
    push (@ret, "email: $self->{EMAIL}");
    push (@ret, "family: $self->{FAMILY}");
    push (@ret, "given: $self->{GIVEN}");
    my $t = localtime($self->{MODIFY});
    push (@ret, "modify: $self->{MODIFY} [$t]");
    my $t = localtime($self->{CREATE});
    push (@ret, "create: $self->{CREATE} [$t]");
    return join ("\n", @ret);
}

package W3C::Annotations::UserRecordSet;
use W3C::Util::Exception;

use vars qw(@ISA);
@ISA = qw(W3C::Util::NamedParmObject);

use vars qw($DEFAULT_BUSY_WAIT);
$DEFAULT_BUSY_WAIT = 20; # seconds to poll for dbm file write access

sub new {
    my ($proto, @parms) = @_;
    my $class = ref($proto) || $proto;
    my $self = $class->SUPER::new(@parms);

    if ($self->{-forceUser}) {
	return $self;
    }

    if (!exists $self->{-busyWait}) {
	$self->{-busyWait} = $DEFAULT_BUSY_WAIT;
    }

    return $self;
}

sub _throwException {
    my ($self, $ex) = @_;
    if (my $handler = $self->{-errorHandler}) {
	$handler->error($ex);
    } else {
	&throw($ex);
    }
}

sub getUserRecord {
    my ($self, $user) = @_;
    if ($self->{-forceUser}) {
	eval {
	    return new W3C::Annotations::UserRecord($self->{-forceUser}, $self->{-forceUserRecord});
	}; if ($@) {&throw()}
    }
    if (my $record = $self->accessDB($self->{-file}, $user, $RW_read)) {
	return W3C::Annotations::UserRecord::parseUserEntry($user, $record);
    }
    &throw(new W3C::Annotations::UserRecord::UserNotFoundException(-username => $user, -database => $self->{-file}));
}

1;

## DBMUserRecords: Generic interface to annotation user and group records for
#  users of the W3C Annotations project.

__END__

=head1 NAME

W3C::Annotations::UserRecord - generic user account database

=head1 SYNOPSIS

  use W3C::Annotations::UserRecord

=head1 DESCRIPTION

This module provides a standard interface to user accounts.

This module is used with the W3C::Annotations CPAN module.

=head1 AUTHOR

Eric Prud'hommeaux <eric@w3.org>

=head1 SEE ALSO

L<W3C::Annotations::cgibin::annotate>
L<W3C::Annotations::cgibin::access>

=cut

