Complex.pm

   1 package Plack::Middleware::Auth::Complex;
   2
   3 use 5.014000;
   4 use strict;
   5 use warnings;
   6
   7 our $VERSION = '0.001001';
   8
   9 use parent qw/Plack::Middleware/;
  10 use re '/s';
  11
  12 use Authen::Passphrase;
  13 use Authen::Passphrase::BlowfishCrypt;
  14 use Bytes::Random::Secure qw/random_bytes/;
  15 use Carp qw/croak/;
  16 use DBI;
  17 use Digest::SHA qw/hmac_sha1_base64 sha256/;
  18 use Email::Simple;
  19 use Email::Sender::Simple qw/sendmail/;
  20 use MIME::Base64 qw/decode_base64/;
  21 use Plack::Request;
  22 use Tie::Hash::Expire;
  23
  24 sub default_opts {(
  25         dbi_connect       => ['dbi:Pg:', '', ''],
  26         select_user       => 'SELECT passphrase, email FROM users WHERE id = ?',
  27         update_pass       => 'UPDATE users SET passphrase = ? WHERE id = ?',
  28         insert_user       => 'INSERT INTO users (id, passphrase, email) VALUES (?,?,?)',
  29         mail_subject      => 'Password reset token',
  30         realm             => 'restricted area',
  31         cache_fail        => 0,
  32         cache_max_age     => 5 * 60,
  33         token_max_age     => 60 * 60,
  34         username_regex    => qr/^\w{2,20}$/as,
  35         invalid_username  => 'Invalid username',
  36         register_url      => '/action/register',
  37         passwd_url        => '/action/passwd',
  38         request_reset_url => '/action/request-reset',
  39         reset_url         => '/action/reset'
  40 )}
  41
  42 sub new {
  43         my ($class, $opts) = @_;
  44         my %self = $class->default_opts;
  45         %self = (%self, %$opts);
  46         my $self = bless \%self, $class;
  47         $self
  48 }
  49
  50 sub init {
  51         my ($self) = @_;
  52         $self->{dbh} = DBI->connect(@{$self->{dbi_connect}})              or croak $DBI::errstr;
  53         $self->{post_connect_cb}->($self) if $self->{post_connect_cb}; # uncoverable branch false
  54         $self->{insert_sth} = $self->{dbh}->prepare($self->{insert_user}) or croak $self->{dbh}->errstr;
  55         $self->{select_sth} = $self->{dbh}->prepare($self->{select_user}) or croak $self->{dbh}->errstr;
  56         $self->{update_sth} = $self->{dbh}->prepare($self->{update_pass}) or croak $self->{dbh}->errstr;
  57 }
  58
  59 sub create_user {
  60         my ($self, $parms) = @_;
  61         my %parms = $parms->flatten;
  62         $self->{insert_sth}->execute($parms{username}, $self->hash_passphrase($parms{password}), $parms{email}) or croak $self->{insert_sth}->errstr;
  63 }
  64
  65 sub get_user {
  66         my ($self, $user) = @_;
  67         $self->{select_sth}->execute($user) or croak $self->{select_sth}->errstr;
  68         $self->{select_sth}->fetchrow_hashref
  69 }
  70
  71 sub check_passphrase {
  72         my ($self, $username, $passphrase) = @_;
  73         unless ($self->{cache}) {
  74                 ## no critic (ProhibitTies)
  75                 tie my %cache, 'Tie::Hash::Expire', {expire_seconds => $self->{cache_max_age}};
  76                 $self->{cache} = \%cache;
  77         }
  78         my $cachekey = sha256 "$username:$passphrase";
  79         return $self->{cache}{$cachekey} if exists $self->{cache}{$cachekey}; # uncoverable branch true
  80         my $user = $self->get_user($username);
  81         return 0 unless $user;
  82         my $ret = Authen::Passphrase->from_rfc2307($user->{passphrase})->match($passphrase);
  83         $self->{cache}{$cachekey} = $ret if $ret || $self->{cache_fail};
  84         $ret
  85 }
  86
  87 sub hash_passphrase {
  88         my ($self, $passphrase) = @_;
  89         Authen::Passphrase::BlowfishCrypt->new(
  90                 cost => 10,
  91                 passphrase => $passphrase,
  92                 salt_random => 1,
  93         )->as_rfc2307
  94 }
  95
  96 sub set_passphrase {
  97         my ($self, $username, $passphrase) = @_;
  98         $self->{update_sth}->execute($self->hash_passphrase($passphrase), $username) or croak $self->{update_sth}->errstr;
  99 }
 100
 101 sub make_reset_hmac {
 102         my ($self, $username, @data) = @_;
 103         $self->{hmackey} //= random_bytes 512; # uncoverable condition false
 104         my $user = $self->get_user($username);
 105         my $message = join ' ', $username, $user->{passphrase}, @data;
 106         hmac_sha1_base64 $message, $self->{hmackey};
 107 }
 108
 109 sub mail_body {
 110         my ($self, $username, $token) = @_;
 111         my $hours = $self->{token_max_age} / 60 / 60;
 112         $hours .= $hours == 1 ? ' hour' : ' hours'; # uncoverable branch false
 113         <<"EOF";
 114 Someone has requested a password reset for your account.
 115
 116 To reset your password, please submit the reset password form on the
 117 website using the following information:
 118
 119 Username: $username
 120 Password: <your new password>
 121 Reset token: $token
 122
 123 The token is valid for $hours.
 124 EOF
 125 }
 126
 127 sub send_reset_email {
 128         my ($self, $username) = @_;
 129         my $expire = time + $self->{token_max_age};
 130         my $token = $self->make_reset_hmac($username, $expire) . ":$expire";
 131         my $user = $self->get_user($username);
 132         sendmail (Email::Simple->create(
 133                 header => [
 134                         From    => $self->{mail_from},
 135                         To      => $user->{email},
 136                         Subject => $self->{mail_subject},
 137                 ],
 138                 body => $self->mail_body($username, $token),
 139         ));
 140 }
 141
 142 ##################################################
 143
 144 sub response {
 145         my ($self, $code, $body) = @_;
 146         return [
 147                 $code,
 148                 ['Content-Type' => 'text/plain',
 149                  'Content-Length' => length $body],
 150                 [ $body ],
 151         ];
 152 }
 153
 154 sub reply                 { shift->response(200, $_[0]) }
 155 sub bad_request           { shift->response(400, $_[0]) }
 156 sub internal_server_error { shift->response(500, $_[0]) }
 157
 158 sub unauthorized {
 159         my ($self) = @_;
 160         my $body = 'Authorization required';
 161         return [
 162                 401,
 163                 ['Content-Type' => 'text/plain',
 164                  'Content-Length' => length $body,
 165                  'WWW-Authenticate' => 'Basic realm="' . $self->{realm} . '"' ],
 166                 [ $body ],
 167         ];
 168 }
 169
 170 ##################################################
 171
 172 sub call_register {
 173         my ($self, $req) = @_;
 174         my %parms;
 175         for (qw/username password confirm_password email/) {
 176                 $parms{$_} = $req->param($_);
 177                 return $self->bad_request("Missing parameter $_") unless $parms{$_};
 178         }
 179
 180         return $self->bad_request($self->{invalid_username}) unless $parms{username} =~ $self->{username_regex};
 181         return $self->bad_request('Username already in use') if $self->get_user($parms{username});
 182         return $self->bad_request('The two passwords do not match') unless $parms{password} eq $parms{confirm_password};
 183
 184         $self->create_user($req->parameters);
 185         return $self->reply('Registered successfully')
 186 }
 187
 188 sub call_passwd {
 189         my ($self, $req) = @_;
 190         return $self->unauthorized unless $req->user;
 191         my %parms;
 192         for (qw/password new_password confirm_new_password/) {
 193                 $parms{$_} = $req->param($_);
 194                 return $self->bad_request("Missing parameter $_") unless $parms{$_};
 195         }
 196
 197         return $self->bad_request('Incorrect password') unless $self->check_passphrase($req->user, $parms{password});
 198         return $self->bad_request('The two passwords do not match') unless $parms{new_password} eq $parms{confirm_new_password};
 199         $self->set_passphrase($req->user, $parms{new_password});
 200         return $self->reply('Password changed successfully');
 201 }
 202
 203 sub call_request_reset {
 204         my ($self, $req) = @_;
 205         return $self->internal_server_error('Password resets are disabled') unless $self->{mail_from};
 206         my $username = $req->param('username');
 207         my $user = $self->get_user($username) or return $self->bad_request('No such user');
 208         eval {
 209                 $self->send_reset_email($username);
 210                 1
 211         } or return $self->internal_server_error($@);
 212         $self->reply('Email sent');
 213 }
 214
 215 sub call_reset {
 216         my ($self, $req) = @_;
 217         my %parms;
 218         for (qw/username new_password confirm_new_password token/) {
 219                 $parms{$_} = $req->param($_);
 220                 return $self->bad_request("Missing parameter $_") unless $parms{$_};
 221         }
 222
 223         my $user = $self->get_user($parms{username}) or return $self->bad_request('No such user');
 224         return $self->bad_request('The two passwords do not match') unless $parms{new_password} eq $parms{confirm_new_password};
 225         my ($token, $exp) = split /:/, $parms{token};
 226         my $goodtoken = $self->make_reset_hmac($parms{username}, $exp);
 227         return $self->bad_request('Bad reset token') unless $token eq $goodtoken;
 228         return $self->bad_request('Reset token has expired') if time >= $exp;
 229         $self->set_passphrase($parms{username}, $parms{new_password});
 230         return $self->reply('Password reset successfully');
 231 }
 232
 233 sub call {
 234         my ($self, $env) = @_;
 235
 236         unless ($self->{init_done}) {
 237                 $self->init;
 238                 $self->{init_done} = 1;
 239         }
 240
 241         my $auth = $env->{HTTP_AUTHORIZATION};
 242         if ($auth && $auth =~ /^Basic (.*)$/i) {
 243                 my ($user, $pass) = split /:/, decode_base64($1), 2;
 244                 $env->{REMOTE_USER} = $user if $self->check_passphrase($user, $pass);
 245         }
 246
 247         my $req = Plack::Request->new($env);
 248
 249         if ($req->method eq 'POST') {
 250                 return $self->call_register($req)      if $req->path eq $self->{register_url};
 251                 return $self->call_passwd($req)        if $req->path eq $self->{passwd_url};
 252                 return $self->call_request_reset($req) if $req->path eq $self->{request_reset_url};
 253                 return $self->call_reset($req)         if $req->path eq $self->{reset_url};
 254         }
 255
 256         $env->{authcomplex} = $self;
 257         $self->app->($env);
 258 }
 259
 260 1;
 261 __END__
 262
 263 =head1 NAME
 264
 265 Plack::Middleware::Auth::Complex - Feature-rich authentication system
 266
 267 =head1 SYNOPSIS
 268
 269   use Plack::Builder;
 270
 271   builder {
 272     enable 'Auth::Complex', dbi_connect => ['dbi:Pg:dbname=mydb', '', ''], mail_from => 'nobody@example.org';
 273     sub {
 274       my ($env) = @_;
 275       [200, [], ['Hello ' . ($env->{REMOTE_USER} // 'unregistered user')]]
 276     }
 277   }
 278
 279 =head1 DESCRIPTION
 280
 281 AuthComplex is an authentication system for Plack applications that
 282 allows user registration, password changing and password reset.
 283
 284 AuthComplex sets REMOTE_USER if the request includes correct basic
 285 authentication and intercepts POST requests to some configurable URLs.
 286 It also sets C<< $env->{authcomplex} >> to itself before passing the
 287 request.
 288
 289 Some options can be controlled by passing a hashref to the
 290 constructor. More customization can be achieved by subclassing this
 291 module.
 292
 293 =head2 Intercepted URLs
 294
 295 Only POST requests are intercepted. Parameters can be either query
 296 parameters or body parameters. Using query parameters is not
 297 recommended. These endpoints return 200 for success, 400 for client
 298 error and 500 for server errors. All parameters are mandatory.
 299
 300 =over
 301
 302 =item B<POST> /action/register?username=user&password=pw&confirm_password=pw&email=user@example.org
 303
 304 This URL creates a new user with the given username, password and
 305 email. The two passwords must match, the user must match
 306 C<username_regex> and the user must not already exist.
 307
 308 =item B<POST> /action/passwd?password=oldpw&new_password=newpw&confirm_new_password=newpw
 309
 310 This URL changes the password of a user. The user must be
 311 authenticated (otherwise the endpoint will return 401).
 312
 313 =item B<POST> /action/request-reset?username=user
 314
 315 This URL requests a password reset token for the given user. The token
 316 will be sent to the user's email address.
 317
 318 A reset token in the default implementation is C<< base64(HMAC-SHA1("$username $passphrase $expiration_unix_time")) . ":$expiration_user_time" >>.
 319
 320 =item B<POST> /action/reset?username=user&new_password=pw&confirm_new_password=pw&token=token
 321
 322 This URL performs a password reset.
 323
 324 =back
 325
 326 =head2 Constructor arguments
 327
 328 =over
 329
 330 =item dbi_connect
 331
 332 Arrayref of arguments to pass to DBI->connect. Defaults to
 333 C<['dbi:Pg', '', '']>.
 334
 335 =item post_connect_cb
 336
 337 Callback (coderef) that is called just after connecting to the
 338 database. Used by the testsuite to create the users table.
 339
 340 =item select_user
 341
 342 SQL statement that selects a user by username. Defaults to
 343 C<'SELECT id, passphrase, email FROM users WHERE id = ?'>.
 344
 345 =item update_pass
 346
 347 SQL statement that updates a user's password. Defaults to
 348 C<'UPDATE users SET passphrase = ? WHERE id = ?'>.
 349
 350 =item insert_user
 351
 352 SQL statement that inserts a user. Defaults to
 353 C<'INSERT INTO users (id, passphrase, email) VALUES (?,?,?)'>.
 354
 355 =item hmackey
 356
 357 HMAC key used for password reset tokens. If not provided it is
 358 generated randomly, in which case reset tokens do not persist across
 359 application restarts.
 360
 361 =item mail_from
 362
 363 From: header of password reset emails. If not provided, password reset
 364 is disabled.
 365
 366 =item mail_subject
 367
 368 The subject of password reset emails. Defaults to
 369 C<'Password reset token'>.
 370
 371 =item realm
 372
 373 Authentication realm. Defaults to C<'restricted area'>.
 374
 375 =item cache_fail
 376
 377 If true, all authentication results are cached. If false, only
 378 successful logins are cached. Defaults to false.
 379
 380 =item cache_max_age
 381
 382 Authentication cache timeout, in seconds. Authentication results are
 383 cached for this number of seconds to avoid expensive hashing. Defaults
 384 to 5 minutes.
 385
 386 =item token_max_age
 387
 388 Password reset token validity, in seconds. Defaults to 1 hour.
 389
 390 =item username_regex
 391
 392 Regular expression that matches valid usernames. Defaults to
 393 C<qr/^\w{2,20}$/as>.
 394
 395 =item invalid_username
 396
 397 Error message returned when the username does not match
 398 username_regex. Defaults to C<'Invalid username'>
 399
 400 =item register_url
 401
 402 URL for registering. Defaults to C<'/action/register'>.
 403
 404 =item passwd_url
 405
 406 URL for changing your password. Defaults to C<'/action/passwd'>.
 407
 408 =item request_reset_url
 409
 410 URL for requesting a password reset token by email. Defaults to
 411 C<'/action/request-reset'>.
 412
 413 =item reset_url
 414
 415 URL for resetting your password with a reset token. Defaults to
 416 C<'/action/reset'>.
 417
 418 =back
 419
 420 =head2 Methods
 421
 422 =over
 423
 424 =item B<default_opts>
 425
 426 Returns a list of default options for the constructor.
 427
 428 =item B<new>(I<\%opts>)
 429
 430 Creates a new AuthComplex object.
 431
 432 =item B<init>
 433
 434 Called when the first request is received. The default implementation
 435 connects to the database, calls C<post_connect_cb> and prepares the
 436 SQL statements.
 437
 438 =item B<create_user>(I<$parms>)
 439
 440 Inserts a new user into the database. I<$parms> is a
 441 L<Hash::MultiValue> object containing the request parameters.
 442
 443 =item B<get_user>(I<$username>)
 444
 445 Returns a hashref with (at least) the following keys: passphrase (the
 446 RFC2307-formatted passphrase of the user), email (the user's email
 447 address).
 448
 449 =item B<check_passphrase>(I<$username>, I<$passphrase>)
 450
 451 Returns true if the given plaintext passphrase matches the one
 452 obtained from database. Default implementation uses L<Authen::Passphrase>.
 453
 454 =item B<hash_passphrase>(I<$passphrase>)
 455
 456 Returns a RFC2307-formatted hash of the passphrase. Default
 457 implementation uses L<Authen::Passphrase::BlowfishCrypt> with a cost
 458 of 10 and a random salt.
 459
 460 =item B<set_passphrase>(I<$username>, I<$passphrase>)
 461
 462 Changes a user's passphrase to the given value.
 463
 464 =item B<make_reset_hmac>(I<$username>, [I<@data>])
 465
 466 Returns the HMAC part of the reset token.
 467
 468 =item B<mail_body>(I<$username>, I<$token>)
 469
 470 Returns the body of the password reset email for the given username
 471 and password reset token.
 472
 473 =item B<send_reset_email>(I<$username>)
 474
 475 Generates a new reset token and sends it to the user via email.
 476
 477 =item B<response>(I<$code>, I<$body>)
 478
 479 Helper method. Returns a PSGI response with the given response code
 480 and string body.
 481
 482 =item B<reply>(I<$message>)
 483
 484 Shorthand for C<response(200, $message)>.
 485
 486 =item B<bad_request>(I<$message>)
 487
 488 Shorthand for C<response(400, $message)>.
 489
 490 =item B<internal_server_error>(I<$message>)
 491
 492 Shorthand for C<response(500, $message)>.
 493
 494 =item B<unauthorized>
 495
 496 Returns a 401 Authorization required response.
 497
 498 =item B<call_register>(I<$req>)
 499
 500 Handles the C</action/register> endpoint. I<$req> is a Plack::Request object.
 501
 502 =item B<call_passwd>(I<$req>)
 503
 504 Handles the C</action/passwd> endpoint. I<$req> is a Plack::Request object.
 505
 506 =item B<call_request_reset>(I<$req>)
 507
 508 Handles the C</action/request-reset> endpoint. I<$req> is a Plack::Request object.
 509
 510 =item B<call_reset>(I<$req>)
 511
 512 Handles the C</action/reset> endpoint. I<$req> is a Plack::Request object.
 513
 514 =back
 515
 516 =head1 AUTHOR
 517
 518 Marius Gavrilescu, E<lt>marius@ieval.roE<gt>
 519
 520 =head1 COPYRIGHT AND LICENSE
 521
 522 Copyright (C) 2015 by Marius Gavrilescu
 523
 524 This library is free software; you can redistribute it and/or modify
 525 it under the same terms as Perl itself, either Perl version 5.20.1 or,
 526 at your option, any later version of Perl 5 you may have available.
 527
 528
 529 =cut