| 1 |
package CatDap::Controller::register; |
| 2 |
use Moose; |
| 3 |
use namespace::autoclean; |
| 4 |
use Email::Valid; |
| 5 |
use Data::UUID; |
| 6 |
|
| 7 |
BEGIN {extends 'Catalyst::Controller'; } |
| 8 |
|
| 9 |
=head1 NAME |
| 10 |
|
| 11 |
CatDap::Controller::register - Catalyst Controller |
| 12 |
|
| 13 |
=head1 DESCRIPTION |
| 14 |
|
| 15 |
Catalyst Controller. |
| 16 |
|
| 17 |
=head1 METHODS |
| 18 |
|
| 19 |
=cut |
| 20 |
|
| 21 |
|
| 22 |
=head2 index |
| 23 |
|
| 24 |
=cut |
| 25 |
|
| 26 |
sub index :Path :Args(0) : Form { |
| 27 |
my ( $self, $c ) = @_; |
| 28 |
my $lang = choose_language($c); |
| 29 |
|
| 30 |
#my $form = Catalyst::Controller::HTML::FormFu->form(); |
| 31 |
#$c->response->body('Matched CatDap::Controller::register in register.'); |
| 32 |
} |
| 33 |
|
| 34 |
sub check : Local { |
| 35 |
my ( $self, $c ) = @_; |
| 36 |
|
| 37 |
my %details = %{$c->request->params}; |
| 38 |
my $username = lc($c->request->params->{uid}); |
| 39 |
my @errors; |
| 40 |
$c->stash(errors => []); |
| 41 |
# Check username, start with letter, followed by letters or numbers |
| 42 |
if ($username !~ /^[a-z][a-z0-9_-]*$/) { |
| 43 |
push @errors, $c->loc('Invalid username'); |
| 44 |
} |
| 45 |
my $email = $c->request->params->{mail1}; |
| 46 |
if (! Email::Valid->address($email)) { |
| 47 |
push @errors, $c->loc('Invalid email address'); |
| 48 |
} |
| 49 |
if ($email ne $c->request->params->{mail2}) { |
| 50 |
push @errors, $c->loc('Addresses do not match'); |
| 51 |
} |
| 52 |
if (! $c->validate_captcha($c->req->param('validate'))){ |
| 53 |
push @errors, $c->loc('Incorrect validation text, please try again'); |
| 54 |
} |
| 55 |
|
| 56 |
if ( ! open( my $etcpasswd, "/etc/passwd")) { |
| 57 |
push @errors, $c->loc('Cannot check /etc/passwd, please warn system administrators'); |
| 58 |
} else { |
| 59 |
if ( grep { /^$username:/ } <$etcpasswd> ) { |
| 60 |
push @errors, $c->loc('Invalid username, already used by system'); |
| 61 |
} |
| 62 |
close($etcpasswd); |
| 63 |
} |
| 64 |
|
| 65 |
if ( grep /^$username$/, @{${$c->config}{'register'}{'login_blacklist'}}) { |
| 66 |
push @errors, $c->loc('Username is not authorized to be used'); |
| 67 |
} |
| 68 |
|
| 69 |
if ($c->request->params->{gn} !~ /^[\p{IsAlnum}'\- ]+$/) { |
| 70 |
push @errors, $c->loc( |
| 71 |
'The first name supplied contains illegal characters' |
| 72 |
); |
| 73 |
} |
| 74 |
if ($c->request->params->{sn} !~ /^[\p{IsAlnum}'\- ]+$/) { |
| 75 |
push @errors, $c->loc( |
| 76 |
'The surname supplied contains illegal characters' |
| 77 |
); |
| 78 |
} |
| 79 |
|
| 80 |
if (@errors) { |
| 81 |
$c->stash(errors => \@errors); |
| 82 |
$c->stash(template => 'register/index.tt'); |
| 83 |
return; |
| 84 |
} |
| 85 |
|
| 86 |
# check in LDAP now that we have validated username and email |
| 87 |
my $mesg = $c->model('Proxy')->search("(mail=$email)"); |
| 88 |
if ($mesg->entries()) { |
| 89 |
push @errors,$c->loc( |
| 90 |
'An account already exists with this email address' |
| 91 |
); |
| 92 |
} |
| 93 |
$mesg = $c->model('Proxy')->search("(uid=$username)"); |
| 94 |
if ($mesg->entries()) { |
| 95 |
push @errors,$c->loc('An account already exists with this username'); |
| 96 |
} |
| 97 |
|
| 98 |
if (@errors) { |
| 99 |
$c->stash(errors => \@errors); |
| 100 |
$c->stash(template => 'register/index.tt'); |
| 101 |
return; |
| 102 |
} |
| 103 |
|
| 104 |
my $dn = "uid=$username,${$c->config}{'Model::Proxy'}{'base'}"; |
| 105 |
my $ug = Data::UUID->new; |
| 106 |
my $password = $ug->create_str(); |
| 107 |
my $cn = $c->request->params->{gn} . " " . $c->request->params->{sn}; |
| 108 |
my $lang = choose_language($c); |
| 109 |
$c->log->info("Creating account for user $username"); |
| 110 |
$mesg = $c->model('Proxy')->add($dn, |
| 111 |
attr => [ |
| 112 |
objectclass => [ 'inetOrgPerson' ], |
| 113 |
sn => $c->request->params->{sn}, |
| 114 |
gn => $c->request->params->{gn}, |
| 115 |
cn => $cn, |
| 116 |
mail => $email, |
| 117 |
pwdReset => 'TRUE', |
| 118 |
userPassword => $password, |
| 119 |
preferredLanguage => $lang, |
| 120 |
] |
| 121 |
); |
| 122 |
if ($mesg->code) { |
| 123 |
push @errors,$mesg->error; |
| 124 |
$c->log->info( sprintf("Creating DN $dn failed: %s", $mesg->error) ); |
| 125 |
$c->stash(errors => \@errors); |
| 126 |
$c->stash(template => 'register/index.tt'); |
| 127 |
return ; |
| 128 |
} |
| 129 |
|
| 130 |
$c->stash( |
| 131 |
email => { |
| 132 |
'to' => $email, |
| 133 |
'from' => ${$c->config}{'emailfrom'}, |
| 134 |
'subject' => ${$c->config}{'apptitle'} . " - " . $c->loc('Activation'), |
| 135 |
'template' => 'activation.tt', |
| 136 |
}, |
| 137 |
cn => $cn, |
| 138 |
url => $c->uri_for('/user/firstlogin') . "?username=$username&key=$password", |
| 139 |
); |
| 140 |
|
| 141 |
$c->log->info("Sending activation mail for user $username to $email"); |
| 142 |
$c->forward( $c->view('Email::Template') ); |
| 143 |
if ( @{ $c->error } ) { |
| 144 |
my $errors = join "\n",@{ $c->error }; |
| 145 |
$c->log->info("Sending activation mail to $email failed: $errors"); |
| 146 |
$c->response->body($c->loc('An error occured sending the email, but your account was created. Please try the password recovery process if you entered the correct email address. Errors [_1]', $errors)); |
| 147 |
$c->error(0); # Reset the error condition if you need to |
| 148 |
} |
| 149 |
$c->stash(template => 'register/complete.tt'); |
| 150 |
} |
| 151 |
|
| 152 |
sub captcha : Local { |
| 153 |
my ($self, $c) = @_; |
| 154 |
return $c->create_captcha(); |
| 155 |
} |
| 156 |
|
| 157 |
sub choose_language : Private { |
| 158 |
my $c = shift; |
| 159 |
my $langs = join ',',@{$c->languages}; |
| 160 |
# FIXME heuristic for correcting languages, we may want a different strategy |
| 161 |
# in future in conjunction with server-side constraints with slapo-constraint. |
| 162 |
# E.g. we could have a languages container with mapping from browser locale |
| 163 |
# codes (preferredLanguage, which is multi-valued), to a single value |
| 164 |
# (e.g. mageiaselectedLanguage, or similar). Then use a uri-based constraint on |
| 165 |
# with mageiaSelectedLanguage as the attribute |
| 166 |
# Also to be considered, pushing all the languages to preferredLanguage, but |
| 167 |
# then do we use ordering? |
| 168 |
my $lang = ${$c->languages}[0]; |
| 169 |
if ($lang !~ /^\w\w\w?(-\w+)?$/) { |
| 170 |
$lang = 'en'; |
| 171 |
} |
| 172 |
# Partial list of lang-variant locales where localisation is different |
| 173 |
if ($lang !~ /^(en-gb|en-us|pt-br|no-\w+|zh-\w+)$/) { |
| 174 |
$lang =~ s/^(\w+)-\w+$/$1/; |
| 175 |
} |
| 176 |
$c->log->debug("Browser languages: $langs,using preferred language: $lang"); |
| 177 |
$c->log->debug("Selected language $lang not default " . $c->language) if $lang ne $c->language; |
| 178 |
return $lang; |
| 179 |
} |
| 180 |
|
| 181 |
=head1 AUTHOR |
| 182 |
|
| 183 |
Buchan Milne |
| 184 |
|
| 185 |
=head1 LICENSE |
| 186 |
|
| 187 |
This library is free software. You can redistribute it and/or modify |
| 188 |
it under the same terms as Perl itself. |
| 189 |
|
| 190 |
=cut |
| 191 |
|
| 192 |
__PACKAGE__->meta->make_immutable; |
| 193 |
|
| 194 |
1; |
Parent Directory
| 
Revision Log