".$ex->toString."\n"; if ($sessionId) { print "
Session-id: $sessionId
\n"; } print ""; } else { print "Status: 500\n\n"; print "died with $@"; if ($sessionId) { print "Session-id: $sessionId
\n"; } } } } sub new { my ($proto, $reader) = @_; my $class = ref $proto || $proto; my $self = {}; bless ($self, $class); # constructor parameters $self->{READ} = $reader; $self->{WRITE} = new W3C::Util::W3CDebugCGI(undef, undef, {-noStore => 1}); $self->{FILE_pending} = File::Spec->catfile($FILE_path, $FILE_pending); $self->{FILE_users} = File::Spec->catfile($FILE_path, $FILE_users); $self->{FILE_groups} = File::Spec->catfile($FILE_path, $FILE_groups); $self->{GROUP_default} = $GROUP_default; $self->{EMAIL_from} = $EMAIL_from; $self->readProperties(); # attach to user database my $userDatabase = $self->{PROPERTIES}->getI('auth.database.class') || $DEFAULT_dbClass; my $parameters = $self->{PROPERTIES}->getI('auth.database.parms') || $DEFAULT_dbParms; my $evalMe = "use $userDatabase; \$self->{USER_RECORDS} = new $userDatabase(-errorHandler => \$self, $parameters);"; eval $evalMe; if ($@) {&throw()} return $self; } sub error { my ($self, $exception) = @_; my $message = $self->standardError($exception->getMessage); &throw(new W3C::Http::HttpMessageException(-httpMessage => $message)); } sub readProperties { my ($self) = @_; # load a properties file if available eval { $self->{PROPERTIES} = new W3C::Util::Properties('annotate.prop'); $self->{SELF_URI} = $self->{READ}->uriFromProperties($self->{PROPERTIES}, $SCRIPT_HOME_URI_PROP); my $filePath = $self->{PROPERTIES}->getI('file.path'); if (defined $filePath) { $self->{FILE_pending} = $self->constructPath($FILE_pending, $filePath); $self->{FILE_users} = $self->constructPath($FILE_users, $filePath); $self->{FILE_groups} = $self->constructPath($FILE_groups, $filePath); } else { $filePath = $FILE_path; } if (my $file = $self->{PROPERTIES}->getI('file.pending')) { $self->{FILE_pending} = $self->constructPath($file, $filePath); } if (my $file = $self->{PROPERTIES}->getI('file.users')) { $self->{FILE_users} = $self->constructPath($file, $filePath); } if (my $file = $self->{PROPERTIES}->getI('file.groups')) { $self->{FILE_groups} = $self->constructPath($file, $filePath); } if (my $str = $self->{PROPERTIES}->getI('group.default')) { $self->{GROUP_default} = $str; } if (my $str = $self->{PROPERTIES}->getI('email.from')) { $self->{EMAIL_from} = $str; } if (my $str = $self->{PROPERTIES}->getI('html.navbar')) { # require quoted string for now; later we might read from files if ( $str =~ m/^".*" *$/ ) { $str =~ s/^"(.*)" *$/\1/; $self->{HTML_navbar} = $str; } } }; if ($@) {if (my $ex = &catch('W3C::Util::FileNotFoundException')) { $self->{PROPERTIES} = new W3C::Util::Properties(); $self->{SELF_URI} = $self->{READ}->url; } else {&throw()}} } sub constructPath { my ($self, $file, $filePath) = @_; require File::Spec; my $ret = $file; if (!File::Spec->file_name_is_absolute($ret)) { $ret = File::Spec->catfile($filePath, $file); } if (!File::Spec->file_name_is_absolute($ret)) { $ret = File::Spec->catfile($ENV{'HOME'}, $filePath, $file); } return $ret; } sub execute { my ($self) = @_; my $ret = undef; if ($self->{READ}->paramUTF8('editWithPassword')) { $ret = $self->parseUserFields(1); } elsif ($self->{READ}->paramUTF8('parseUserFields')) { $ret = $self->parseUserFields(0); } elsif ($self->{READ}->paramUTF8('confirmUser')) { my $user = $self->{READ}->paramUTF8('user'); my $record = $self->accessDBM($self->{FILE_pending}, $user, $RW_read); if (defined $record) { $ret = $self->confirmUser(); } else { $ret = $self->paintUser($user, ['No pending updates.']); } } elsif ($self->{READ}->paramUTF8('paintConfirm')) { my $user = $self->{READ}->paramUTF8('user'); my $record = $self->accessDBM($self->{FILE_pending}, $user, $RW_read); if (defined $record) { my $nonce = $self->{READ}->paramUTF8('nonce'); $ret = $self->paintConfirmUser('', $user, $nonce); } else { $ret = $self->paintUser($user, ['No pending updates.']); } } else { my $user = $self->{READ}->paramUTF8('user'); $ret = $self->paintUser($user, []); # not defined for new user } return $ret; } sub makeErrorString { my ($self, $errors) = @_; if (@$errors > 0) { my $heading = @$errors > 1 ? '$_
"} @$errors)); } return undef; } sub paintUser { my ($self, $user, $errors) = @_; my $selfUri = $self->{READ}->trimmedPath(); my $userRecord = new W3C::Annotations::UserRecord(); # variables constructed from user record my ($checked_byEmail, $checked_byName, $checked_byBoth); # get existing user record if there is one if (defined $user) { if (my $record = $self->accessDBM($self->{FILE_users}, $user, $RW_read)) { $userRecord = W3C::Annotations::UserRecord::parseUserEntry($user, $record); if (($userRecord->getOptions & $OPTIONS_idByEmail) == $OPTIONS_idByEmail) { if (($userRecord->getOptions & $OPTIONS_idByName) == $OPTIONS_idByName) { $checked_byBoth = 'checked="yes"'; } else { $checked_byEmail = 'checked="yes"'; } } elsif (($userRecord->getOptions & $OPTIONS_idByName) == $OPTIONS_idByName) { $checked_byName = 'checked="yes"'; } } else { my $message = $self->standardError("There is no record for user \"$user\"."); &throw(new W3C::Http::HttpMessageException(-httpMessage => $message)); } } my $tGiven = $userRecord->getGiven; my $tFamily = $userRecord->getFamily; my $tEmail = $userRecord->getEmail; my $tUser = $userRecord->getUser; # assign defaults for form input my $userDisabled = $user ? 'disabled="disabled"' : ''; my $hiddenUser = $user ? "\n" : ''; my $optionalUser = ''; my $emailDisabled = ''; if (!$CONFIG_emailIsUser) { $optionalUser = "user name:You may request authorization to access the $serviceDesc by completing this form.
We require that you tell us your name and email address; these will be associated with every annotation you store in our service. (You tell us below which of these to return when the database is queried.) The email address you specify is the username you will enter when your browser prompts for a username and password.
$optionalUser
given name:
family name:
email address:
You may choose your own password to be used with the username/email:
password:
confirm password:
Your name and email address are part of the annotation property data that we store in the database. As a condition for use of this service you agree to accurately identify yourself in all annotations you make. If you wish, you may have the service omit either your name or your email information when it serves the annotations you author. If you choose to omit either one you are explicitly granting us permission to include the other in the annotation data we serve.
W3C may identify my annotations by:
email only
name only
both name and email
By submitting this request for access to the W3C public annotation test service, you indicate your agreement with the W3C Public Annotea Service Acceptable Use and Privacy Policy. After you submit this request, a message with a one-time token will be sent to the email address you entered above. The message will also contain a link to a form similar to this form in which you must enter this one-time token. Your access will be enabled after you complete that second form with the proper token.
Thank you for your interest in the Annotea service.
$passwordInput
EOF ; my $title = $user ? "Edit User $user" : 'New User Access Request'; return $self->standardMessage(200, $title, $body); } sub parseUserFields { my ($self, $expectCurPassword) = @_; my @errors = (); my $userRecord = new W3C::Annotations::UserRecord(); my ($password, $authPassword); # map from user information to the account name my $user = $CONFIG_emailIsUser ? $self->{READ}->paramUTF8('email') : $self->{READ}->paramUTF8('user'); # get any existing record for this user if (my $record = $self->accessDBM($self->{FILE_users}, $user, $RW_read)) { $userRecord = W3C::Annotations::UserRecord::parseUserEntry($user, $record); } my $authenticatedPassword = undef; # fill in rest of userRecord according to the user's input # current password if ($expectCurPassword) { if ($authPassword = $self->{READ}->paramUTF8('curPassword')) { my $cryptedPassword = crypt($authPassword, $userRecord->getHashed); if ($cryptedPassword eq $userRecord->getHashed) { $authenticatedPassword = $authPassword; } else { push (@errors, "You supplied an incorrect password."); } } else { push (@errors, "You need to supply the current password."); } } # requested new password if ($password = $self->{READ}->paramUTF8('password')) { if ($password =~ m/^[^\:]{4,}$/) { # authenticate the user against their current password # The path to this is: # User uses the new user form rather than the user edit form. # User enters an account name that is already in the DB. # User enters their current password in the password field. if (!$expectCurPassword && defined $userRecord->getHashed) { my $cryptedPassword = crypt($password, $userRecord->getHashed); if ($cryptedPassword eq $userRecord->getHashed) { $authenticatedPassword = $password; } } } else { push (@errors, "Password \"$password\" is badly formatted."); } } elsif (defined $authenticatedPassword) { # user authenticated - default to the one submitted $password = $authenticatedPassword; } else { push (@errors, "You need to supply a password."); } # password confirmation (typo checker) if (my $confirmPassword = $self->{READ}->paramUTF8('passwordConfirm')) { if ($confirmPassword eq $password) { } else { push (@errors, "Password confirmation does not match entered password."); } } elsif (!defined $authenticatedPassword) { push (@errors, "You need to confirm your password (enter it twice)."); } # given if (my $given = $self->{READ}->paramUTF8('given')) { if ($given =~ m/^.+$/) { $userRecord->setGiven($given); } else { push (@errors, "Given name \"$given\" is badly formatted."); } } else { push (@errors, "You need to supply a given name."); } # family if (my $family = $self->{READ}->paramUTF8('family')) { if ($family =~ m/^.+$/) { $userRecord->setFamily($family); } else { push (@errors, "Family name \"$family\" is badly formatted."); } } else { push (@errors, "You need to supply a family name."); } # email if (my $email = $self->{READ}->paramUTF8('email')) { if ($email =~ m/\A(\w|-|_|\+|\.|\%|\#|\!)+@(\w|-)+(\.(\w|-)+)+\Z/) { $userRecord->setEmail($email); } else { push (@errors, "Email address \"$email\" is badly formatted."); } } else { push (@errors, "You need to supply a email address."); } # alter the options according to the user's selections my $options = 0; # override any current options if (my $prefsIdent = $self->{READ}->paramUTF8('prefsIdent')) { if ($prefsIdent & $OPTIONS_idByEmail) { $options |= $OPTIONS_idByEmail; } if ($prefsIdent & $OPTIONS_idByName) { $options |= $OPTIONS_idByName; } } $userRecord->setOptions($options); if (!($options & ($OPTIONS_idByEmail | $OPTIONS_idByName))) { push (@errors, "You must indicate an identification preference (email or name or both)."); } if (@errors) { my @body = (); foreach my $error (@errors) { push (@body, "$error
\n"); } push (@body, "Please use your BACK button to correct and then resubmit.
\n"); return $self->standardMessage(200, 'Input error: ', join ('', @body)); } else { my $salt = $userRecord->getHashed; if (!defined $salt || $salt eq '') { $salt = join '', ('.', '/', 0..9, 'A'..'Z','a'..'z')[rand 64, rand 64]; } $userRecord->setPassword($password); $userRecord->setHashed(crypt($password, $salt)); if (defined $authenticatedPassword) { my $userEntry = $userRecord->buildUserEntry(); return $self->storeConfirmedUser($user, $userEntry); } else { return $self->storePendingUser($user, $salt, $userRecord); } } } sub confirmUser { my ($self) = @_; my @errors = (); my $user = $self->{READ}->paramUTF8('user'); if (defined $user) { if ($user =~ m/^[^\:]+$/) { } else { push (@errors, "Account name \"$user\" is badly formatted."); } } else { push (@errors, "You need to supply an account name."); } my $nonce = $self->{READ}->paramUTF8('nonce'); if (defined $nonce) { if ($nonce =~ m/^[^\:]+$/) { } else { push (@errors, "Confirmation token \"$nonce\" is badly formatted."); } } else { push (@errors, "You need to supply a nonce."); } if (@errors) { my @body = (); foreach my $error (@errors) { push (@body, "$error
\n"); } return $self->standardMessage(500, 'Input error: ', join ('', @body)); } else { my $ret; eval { $ret = $self->checkNonce($user, $nonce); }; if ($@) {if (my $ex = &catch('RetryException')) { my $errorString = $self->makeErrorString([$ex->getMessage]); return $self->paintConfirmUser($errorString, $user, $nonce); } else {&throw()}} return $ret; } } sub storePendingUser { my ($self, $user, $salt, $userRecord) = @_; my $now = time(); if (!defined $userRecord->getCreate) { $userRecord->setCreate($now); } my $nonce = crypt($now, $salt); $userRecord->setNonce($nonce); $userRecord->setModify($now); my $pendingEntry = $userRecord->buildPendingEntry(); $self->accessDBM($self->{FILE_pending}, $user, $pendingEntry); my $linkUser = CGI::escape($user); my $formURI = $self->{READ}->trimmedUri(); my $returnUri = $formURI."?paintConfirm=1&user=$linkUser"; my $linkNonce = CGI::escape($nonce); # my $withNonce = $formURI."?confirmUser=1&user=$linkUser&nonce=$linkNonce"; my $withNonce = $formURI."?paintConfirm=1&user=$linkUser&nonce=$linkNonce"; my $family = $userRecord->getFamily; my $given = $userRecord->getGiven; my ($serviceLink, $serviceDesc) = $self->getService(); my $mailBody = <Access authorization for $user requested. A confirmation token has been sent to $email.
"; return $self->paintConfirmUser($preface, $user); } sub paintConfirmUser { my ($self, $preface, $user, $nonce) = @_; my $selfUri = $self->{READ}->trimmedPath(); my $linkUser = CGI::escape($user); my $returnUri = $self->{READ}->trimmedUri()."?paintConfirm=1&user=$linkUser"; my $body = <To complete the update to your W3C Public Annotea Service access, please enter the confirmation token you received by email in the space below.
Account name:
Confirmation token:
You may bookmark this location to return here later.
EOF ; my $ret = $self->standardMessage(200, "Awaiting confirmation token", $body); return $ret; } sub mailText { my($self, $toList, $fromList, $subject, $mesg) = @_; # my $cmd = "| /usr/lib/sendmail -f$replyTo $emailId,$cc,$replyTo >/dev/null 2>&1"; my $to = join(',', @$toList); my $from = join(',', @$fromList); # print "Your account name is $user. Your password is what you entered in the access request form. You may use this account when prompted by your browser (or other user agent) to access the $serviceDesc. Have fun!.
You may edit your access preferences, including changing your password, at any time by returning to the access request form or by bookmarking a link to the pre-filled request form. If you forget your password, you may follow the same procedure to enter a new one.
EOF ; my $ret = $self->standardMessage(200, "Access Confirmed", $body); } sub getService { my ($self) = @_; my $serviceLink = $self->{PROPERTIES}->getI('auth.service.link') || $DEFAULT_serviceLink; my $serviceDesc = $self->{PROPERTIES}->getI('auth.service.desc') || $DEFAULT_serviceDesc; return ($serviceLink, $serviceDesc); } sub accessDBM { my ($self, $file, $key, $value) = @_; $self->{USER_RECORDS}->accessDB($file, $key, $value); } sub standardError { my ($self, $errorString) = @_; return $self->standardMessage(500, 'Error', "$errorString
"); } sub standardMessage { my ($self, $statusCode, $title, $markup) = @_; my $body = <$REVISIONDATE
EOF ; my $message = new W3C::Http::Message(-statusCode => $statusCode, -headers => [['Content-Type', 'text/html;charset=utf-8']], -body => $body); return $message; } __END__ =head1 NAME access W3C::Annotations::cgibin::access - CGI interface for creating user accounts =head1 SYNOPSIS http://