lib/Plack/Middleware/Auth/Complex.pm

   1 package Plack::Middleware::Auth::Complex;
   2
   3 use 5.014000;
   4 use strict;
   5 use warnings;
   6
   7 our $VERSION = '0.000_001';
   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         register_url      => '/action/register',
  36         passwd_url        => '/action/passwd',
  37         request_reset_url => '/action/request-reset',
  38         reset_url         => '/action/reset'
  39 )}
  40
  41 sub new {
  42         my ($class, $opts) = @_;
  43         my %self = $class->default_opts;
  44         %self = (%self, %$opts);
  45         my $self = bless \%self, $class;
  46         $self->init;
  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})
  63 }
  64
  65 sub get_user {
  66         my ($self, $user) = @_;
  67         $self->{select_sth}->execute($user) or croak $self->{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)
  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('Username must match ' . $self->{username_regex}) 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         my $auth = $env->{HTTP_AUTHORIZATION};
 236         if ($auth && $auth =~ /^Basic (.*)$/i) {
 237                 my ($user, $pass) = split /:/, decode_base64($1), 2;
 238                 $env->{REMOTE_USER} = $user if $self->check_passphrase($user, $pass);
 239         }
 240
 241         my $req = Plack::Request->new($env);
 242
 243         if ($req->method eq 'POST') {
 244                 return $self->call_register($req)      if $req->path eq $self->{register_url};
 245                 return $self->call_passwd($req)        if $req->path eq $self->{passwd_url};
 246                 return $self->call_request_reset($req) if $req->path eq $self->{request_reset_url};
 247                 return $self->call_reset($req)         if $req->path eq $self->{reset_url};
 248         }
 249
 250         $env->{authcomplex} = $self;
 251         $self->app->($env);
 252 }
 253
 254 1;
 255 __END__
 256
 257 =head1 NAME
 258
 259 Plack::Middleware::Auth::Complex - Feature-rich authentication system
 260
 261 =head1 SYNOPSIS
 262
 263   use Plack::Builder;
 264
 265   builder {
 266     enable 'Auth::Complex', dbi_connect => ['dbi:Pg:dbname=mydb', '', ''], mail_from => 'nobody@example.org';
 267     sub {
 268       my ($env) = @_;
 269       [200, [], ['Hello ' . ($env->{REMOTE_USER} // 'unregistered user')]]
 270     }
 271   }
 272
 273 =head1 DESCRIPTION
 274
 275 AuthComplex is an authentication system for Plack applications that
 276 allows user registration, password changing and password reset.
 277
 278 AuthComplex sets REMOTE_USER if the request includes correct basic
 279 authentication and intercepts POST requests to some configurable URLs.
 280 It also sets C<< $env->{authcomplex} >> to itself before passing the
 281 request.
 282
 283 Some options can be controlled by passing a hashref to the
 284 constructor. More customization can be achieved by subclassing this
 285 module.
 286
 287 =head2 Intercepted URLs
 288
 289 Only POST requests are intercepted. Parameters can be either query
 290 parameters or body parameters. Using query parameters is not
 291 recommended. These endpoints return 200 for success, 400 for client
 292 error and 500 for server errors. All parameters are mandatory.
 293
 294 =over
 295
 296 =item B<POST> /action/register?username=user&password=pw&confirm_password=pw&email=user@example.org
 297
 298 This URL creates a new user with the given username, password and
 299 email. The two passwords must match, the user must match
 300 C<username_regex> and the user must not already exist.
 301
 302 =item B<POST> /action/passwd?password=oldpw&new_password=newpw&confirm_new_password=newpw
 303
 304 This URL changes the password of a user. The user must be
 305 authenticated (otherwise the endpoint will return 401).
 306
 307 =item B<POST> /action/request-reset?username=user
 308
 309 This URL requests a password reset token for the given user. The token
 310 will be sent to the user's email address.
 311
 312 A reset token in the default implementation is C<< base64(HMAC-SHA1("$username $passphrase $expiration_unix_time")) . ":$expiration_user_time" >>.
 313
 314 =item B<POST> /action/reset?username=user&new_password=pw&confirm_new_password=pw&token=token
 315
 316 This URL performs a password reset.
 317
 318 =back
 319
 320 =head2 Constructor arguments
 321
 322 =over
 323
 324 =item dbi_connect
 325
 326 Arrayref of arguments to pass to DBI->connect. Defaults to
 327 C<['dbi:Pg', '', '']>.
 328
 329 =item post_connect_cb
 330
 331 Callback (coderef) that is called just after connecting to the
 332 database. Used by the testsuite to create the users table.
 333
 334 =item select_user
 335
 336 SQL statement that selects a user by username. Defaults to
 337 C<'SELECT id, passphrase, email FROM users WHERE id = ?'>.
 338
 339 =item update_pass
 340
 341 SQL statement that updates a user's password. Defaults to
 342 C<'UPDATE users SET passphrase = ? WHERE id = ?'>.
 343
 344 =item insert_user
 345
 346 SQL statement that inserts a user. Defaults to
 347 C<'INSERT INTO users (id, passphrase, email) VALUES (?,?,?)'>.
 348
 349 =item hmackey
 350
 351 HMAC key used for password reset tokens. If not provided it is
 352 generated randomly, in which case reset tokens do not persist across
 353 application restarts.
 354
 355 =item mail_from
 356
 357 From: header of password reset emails. If not provided, password reset
 358 is disabled.
 359
 360 =item mail_subject
 361
 362 The subject of password reset emails. Defaults to
 363 C<'Password reset token'>.
 364
 365 =item realm
 366
 367 Authentication realm. Defaults to C<'restricted area'>.
 368
 369 =item cache_fail
 370
 371 If true, all authentication results are cached. If false, only
 372 successful logins are cached. Defaults to false.
 373
 374 =item cache_max_age
 375
 376 Authentication cache timeout, in seconds. Authentication results are
 377 cached for this number of seconds to avoid expensive hashing. Defaults
 378 to 5 minutes.
 379
 380 =item token_max_age
 381
 382 Password reset token validity, in seconds. Defaults to 1 hour.
 383
 384 =item username_regex
 385
 386 Regular expression that matches valid usernames. Defaults to
 387 C<qr/^\w{2,20}$/as>.
 388
 389 =item register_url
 390
 391 URL for registering. Defaults to C<'/action/register'>.
 392
 393 =item passwd_url
 394
 395 URL for changing your password. Defaults to C<'/action/passwd'>.
 396
 397 =item request_reset_url
 398
 399 URL for requesting a password reset token by email. Defaults to
 400 C<'/action/request-reset'>.
 401
 402 =item reset_url
 403
 404 URL for resetting your password with a reset token. Defaults to
 405 C<'/action/reset'>.
 406
 407 =back
 408
 409 =head2 Methods
 410
 411 =over
 412
 413 =item B<default_opts>
 414
 415 Returns a list of default options for the constructor.
 416
 417 =item B<new>(I<\%opts>)
 418
 419 Creates a new AuthComplex object.
 420
 421 =item B<init>
 422
 423 Called at the end of the constructor. The default implementation
 424 connects to the database, calls C<post_connect_cb> and prepares the
 425 SQL statements.
 426
 427 =item B<create_user>(I<$parms>)
 428
 429 Inserts a new user into the database. I<$parms> is a
 430 L<Hash::MultiValue> object containing the request parameters.
 431
 432 =item B<get_user>(I<$username>)
 433
 434 Returns a hashref with (at least) the following keys: passphrase (the
 435 RFC2307-formatted passphrase of the user), email (the user's email
 436 address).
 437
 438 =item B<check_passphrase>(I<$username>, I<$passphrase>)
 439
 440 Returns true if the given plaintext passphrase matches the one
 441 obtained from database. Default implementation uses L<Authen::Passphrase>.
 442
 443 =item B<hash_passphrase>(I<$passphrase>)
 444
 445 Returns a RFC2307-formatted hash of the passphrase. Default
 446 implementation uses L<Authen::Passphrase::BlowfishCrypt> with a cost
 447 of 10 and a random salt.
 448
 449 =item B<set_passphrase>(I<$username>, I<$passphrase>)
 450
 451 Changes a user's passphrase to the given value.
 452
 453 =item B<make_reset_hmac>(I<$username>, [I<@data>])
 454
 455 Returns the HMAC part of the reset token.
 456
 457 =item B<mail_body>(I<$username>, I<$token>)
 458
 459 Returns the body of the password reset email for the given username
 460 and password reset token.
 461
 462 =item B<send_reset_email>(I<$username>)
 463
 464 Generates a new reset token and sends it to the user via email.
 465
 466 =item B<response>(I<$code>, I<$body>)
 467
 468 Helper method. Returns a PSGI response with the given response code
 469 and string body.
 470
 471 =item B<reply>(I<$message>)
 472
 473 Shorthand for C<response(200, $message)>.
 474
 475 =item B<bad_request>(I<$message>)
 476
 477 Shorthand for C<response(400, $message)>.
 478
 479 =item B<internal_server_error>(I<$message>)
 480
 481 Shorthand for C<response(500, $message)>.
 482
 483 =item B<unauthorized>
 484
 485 Returns a 401 Authorization required response.
 486
 487 =item B<call_register>(I<$req>)
 488
 489 Handles the C</register> endpoint. I<$req> is a Plack::Request object.
 490
 491 =item B<call_passwd>(I<$req>)
 492
 493 Handles the C</passwd> endpoint. I<$req> is a Plack::Request object.
 494
 495 =item B<call_request_reset>(I<$req>)
 496
 497 Handles the C</request-reset> endpoint. I<$req> is a Plack::Request object.
 498
 499 =item B<call_reset>(I<$req>)
 500
 501 Handles the C</reset> endpoint. I<$req> is a Plack::Request object.
 502
 503 =back
 504
 505 =head1 AUTHOR
 506
 507 Marius Gavrilescu, E<lt>marius@ieval.roE<gt>
 508
 509 =head1 COPYRIGHT AND LICENSE
 510
 511 Copyright (C) 2015 by Marius Gavrilescu
 512
 513 This library is free software; you can redistribute it and/or modify
 514 it under the same terms as Perl itself, either Perl version 5.20.1 or,
 515 at your option, any later version of Perl 5 you may have available.
 516
 517
 518 =cut