lib/Catalyst/Authentication/Credential/HTTP.pm

   1 package Catalyst::Authentication::Credential::HTTP;
   2 use base qw/Catalyst::Authentication::Credential::Password/;
   3
   4 use strict;
   5 use warnings;
   6
   7 use String::Escape ();
   8 use URI::Escape    ();
   9 use Catalyst       ();
  10 use Digest::MD5    ();
  11
  12 __PACKAGE__->mk_accessors(qw/
  13     _config
  14     authorization_required_message
  15     password_field
  16     username_field
  17     type
  18     realm
  19     algorithm
  20     use_uri_for
  21     no_unprompted_authorization_required
  22     require_ssl
  23 /);
  24
  25 our $VERSION = '1.013';
  26
  27 sub new {
  28     my ($class, $config, $app, $realm) = @_;
  29
  30     $config->{username_field} ||= 'username';
  31     # _config is shity back-compat with our base class.
  32     my $self = { %$config, _config => $config, _debug => $app->debug ? 1 : 0 };
  33     bless $self, $class;
  34
  35     $self->realm($realm);
  36
  37     $self->init;
  38     return $self;
  39 }
  40
  41 sub init {
  42     my ($self) = @_;
  43     my $type = $self->type || 'any';
  44
  45     if (!grep /$type/, ('basic', 'digest', 'any')) {
  46         Catalyst::Exception->throw(__PACKAGE__ . " used with unsupported authentication type: " . $type);
  47     }
  48     $self->type($type);
  49 }
  50
  51 sub authenticate {
  52     my ( $self, $c, $realm, $auth_info ) = @_;
  53     my $auth;
  54
  55     $self->authentication_failed( $c, $realm, $auth_info )
  56         if $self->require_ssl ? $c->req->scheme ne 'https' : 0;
  57
  58     $auth = $self->authenticate_digest($c, $realm, $auth_info) if $self->_is_http_auth_type('digest');
  59     return $auth if $auth;
  60
  61     $auth = $self->authenticate_basic($c, $realm, $auth_info) if $self->_is_http_auth_type('basic');
  62     return $auth if $auth;
  63
  64     $self->authentication_failed( $c, $realm, $auth_info );
  65 }
  66
  67 sub authentication_failed {
  68     my ( $self, $c, $realm, $auth_info ) = @_;
  69     unless (!$self->no_unprompted_authorization_required) {
  70         $self->authorization_required_response($c, $realm, $auth_info);
  71         die $Catalyst::DETACH;
  72     }
  73 }
  74
  75 sub authenticate_basic {
  76     my ( $self, $c, $realm, $auth_info ) = @_;
  77
  78     $c->log->debug('Checking http basic authentication.') if $c->debug;
  79
  80     my $headers = $c->req->headers;
  81
  82     if ( my ( $username, $password ) = $headers->authorization_basic ) {
  83             my $user_obj = $realm->find_user( { $self->username_field => $username }, $c);
  84             if (ref($user_obj)) {
  85             my $opts = {};
  86             $opts->{$self->password_field} = $password
  87                 if $self->password_field;
  88             if ($self->check_password($user_obj, $opts)) {
  89                 return $user_obj;
  90             }
  91             else {
  92                 $c->log->debug("Password mismatch!") if $c->debug;
  93                 return;
  94             }
  95          }
  96          else {
  97              $c->log->debug("Unable to locate user matching user info provided")
  98                 if $c->debug;
  99             return;
 100         }
 101     }
 102
 103     return;
 104 }
 105
 106 sub authenticate_digest {
 107     my ( $self, $c, $realm, $auth_info ) = @_;
 108
 109     $c->log->debug('Checking http digest authentication.') if $c->debug;
 110
 111     my $headers       = $c->req->headers;
 112     my @authorization = $headers->header('Authorization');
 113     foreach my $authorization (@authorization) {
 114         next unless $authorization =~ m{^Digest};
 115         my %res = map {
 116             my @key_val = split /=/, $_, 2;
 117             $key_val[0] = lc $key_val[0];
 118             $key_val[1] =~ s{"}{}g;    # remove the quotes
 119             @key_val;
 120         } split /,\s?/, substr( $authorization, 7 );    #7 == length "Digest "
 121
 122         my $opaque = $res{opaque};
 123         my $nonce  = $self->get_digest_authorization_nonce( $c, __PACKAGE__ . '::opaque:' . $opaque );
 124         next unless $nonce;
 125
 126         $c->log->debug('Checking authentication parameters.')
 127           if $c->debug;
 128
 129         my $uri         = $c->request->uri->path_query;
 130         my $algorithm   = $res{algorithm} || 'MD5';
 131         my $nonce_count = '0x' . $res{nc};
 132
 133         my $check = $uri eq $res{uri}
 134           && ( exists $res{username} )
 135           && ( exists $res{qop} )
 136           && ( exists $res{cnonce} )
 137           && ( exists $res{nc} )
 138           && $algorithm eq $nonce->algorithm
 139           && hex($nonce_count) > hex( $nonce->nonce_count )
 140           && $res{nonce} eq $nonce->nonce;    # TODO: set Stale instead
 141
 142         unless ($check) {
 143             $c->log->debug('Digest authentication failed. Bad request.')
 144               if $c->debug;
 145             $c->res->status(400);             # bad request
 146             Carp::confess $Catalyst::DETACH;
 147         }
 148
 149         $c->log->debug('Checking authentication response.')
 150           if $c->debug;
 151
 152         my $username = $res{username};
 153
 154         my $user_obj;
 155
 156         unless ( $user_obj = $auth_info->{user} ) {
 157             $user_obj = $realm->find_user( { $self->username_field => $username }, $c);
 158         }
 159         unless ($user_obj) {    # no user, no authentication
 160             $c->log->debug("Unable to locate user matching user info provided") if $c->debug;
 161             return;
 162         }
 163
 164         # everything looks good, let's check the response
 165         # calculate H(A2) as per spec
 166         my $ctx = Digest::MD5->new;
 167         $ctx->add( join( ':', $c->request->method, $res{uri} ) );
 168         if ( $res{qop} eq 'auth-int' ) {
 169             my $digest =
 170               Digest::MD5::md5_hex( $c->request->body );    # not sure here
 171             $ctx->add( ':', $digest );
 172         }
 173         my $A2_digest = $ctx->hexdigest;
 174
 175         # the idea of the for loop:
 176         # if we do not want to store the plain password in our user store,
 177         # we can store md5_hex("$username:$realm:$password") instead
 178         my $password_field = $self->password_field;
 179         for my $r ( 0 .. 1 ) {
 180             # calculate H(A1) as per spec
 181             my $A1_digest = $r ? $user_obj->$password_field() : do {
 182                 $ctx = Digest::MD5->new;
 183                 $ctx->add( join( ':', $username, $realm->name, $user_obj->$password_field() ) );
 184                 $ctx->hexdigest;
 185             };
 186             if ( $nonce->algorithm eq 'MD5-sess' ) {
 187                 $ctx = Digest::MD5->new;
 188                 $ctx->add( join( ':', $A1_digest, $res{nonce}, $res{cnonce} ) );
 189                 $A1_digest = $ctx->hexdigest;
 190             }
 191
 192             my $digest_in = join( ':',
 193                     $A1_digest, $res{nonce},
 194                     $res{qop} ? ( $res{nc}, $res{cnonce}, $res{qop} ) : (),
 195                     $A2_digest );
 196             my $rq_digest = Digest::MD5::md5_hex($digest_in);
 197             $nonce->nonce_count($nonce_count);
 198             my $key = __PACKAGE__ . '::opaque:' . $nonce->opaque;
 199             $self->store_digest_authorization_nonce( $c, $key, $nonce );
 200             if ($rq_digest eq $res{response}) {
 201                 return $user_obj;
 202             }
 203         }
 204     }
 205     return;
 206 }
 207
 208 sub _check_cache {
 209     my $c = shift;
 210
 211     die "A cache is needed for http digest authentication."
 212       unless $c->can('cache');
 213     return;
 214 }
 215
 216 sub _is_http_auth_type {
 217     my ( $self, $type ) = @_;
 218     my $cfgtype = lc( $self->type );
 219     return 1 if $cfgtype eq 'any' || $cfgtype eq lc $type;
 220     return 0;
 221 }
 222
 223 sub authorization_required_response {
 224     my ( $self, $c, $realm, $auth_info ) = @_;
 225
 226     $c->res->status(401);
 227     $c->res->content_type('text/plain');
 228     if (exists $self->{authorization_required_message}) {
 229         # If you set the key to undef, don't stamp on the body.
 230         $c->res->body($self->authorization_required_message)
 231             if defined $self->authorization_required_message;
 232     }
 233     else {
 234         $c->res->body('Authorization required.');
 235     }
 236
 237     # *DONT* short circuit
 238     my $ok;
 239     $ok++ if $self->_create_digest_auth_response($c, $auth_info);
 240     $ok++ if $self->_create_basic_auth_response($c, $auth_info);
 241
 242     unless ( $ok ) {
 243         die 'Could not build authorization required response. '
 244         . 'Did you configure a valid authentication http type: '
 245         . 'basic, digest, any';
 246     }
 247     return;
 248 }
 249
 250 sub _add_authentication_header {
 251     my ( $c, $header ) = @_;
 252     $c->response->headers->push_header( 'WWW-Authenticate' => $header );
 253     return;
 254 }
 255
 256 sub _create_digest_auth_response {
 257     my ( $self, $c, $opts ) = @_;
 258
 259     return unless $self->_is_http_auth_type('digest');
 260
 261     if ( my $digest = $self->_build_digest_auth_header( $c, $opts ) ) {
 262         _add_authentication_header( $c, $digest );
 263         return 1;
 264     }
 265
 266     return;
 267 }
 268
 269 sub _create_basic_auth_response {
 270     my ( $self, $c, $opts ) = @_;
 271
 272     return unless $self->_is_http_auth_type('basic');
 273
 274     if ( my $basic = $self->_build_basic_auth_header( $c, $opts ) ) {
 275         _add_authentication_header( $c, $basic );
 276         return 1;
 277     }
 278
 279     return;
 280 }
 281
 282 sub _build_auth_header_realm {
 283     my ( $self, $c, $opts ) = @_;
 284     if ( my $realm_name = String::Escape::qprintable($opts->{realm} ? $opts->{realm} : $self->realm->name) ) {
 285         $realm_name = qq{"$realm_name"} unless $realm_name =~ /^"/;
 286         return 'realm=' . $realm_name;
 287     }
 288     return;
 289 }
 290
 291 sub _build_auth_header_domain {
 292     my ( $self, $c, $opts ) = @_;
 293     if ( my $domain = $opts->{domain} ) {
 294         Catalyst::Exception->throw("domain must be an array reference")
 295           unless ref($domain) && ref($domain) eq "ARRAY";
 296
 297         my @uris =
 298           $self->use_uri_for
 299           ? ( map { $c->uri_for($_) } @$domain )
 300           : ( map { URI::Escape::uri_escape($_) } @$domain );
 301
 302         return qq{domain="@uris"};
 303     }
 304     return;
 305 }
 306
 307 sub _build_auth_header_common {
 308     my ( $self, $c, $opts ) = @_;
 309     return (
 310         $self->_build_auth_header_realm($c, $opts),
 311         $self->_build_auth_header_domain($c, $opts),
 312     );
 313 }
 314
 315 sub _build_basic_auth_header {
 316     my ( $self, $c, $opts ) = @_;
 317     return _join_auth_header_parts( Basic => $self->_build_auth_header_common( $c, $opts ) );
 318 }
 319
 320 sub _build_digest_auth_header {
 321     my ( $self, $c, $opts ) = @_;
 322
 323     my $nonce = $self->_digest_auth_nonce($c, $opts);
 324
 325     my $key = __PACKAGE__ . '::opaque:' . $nonce->opaque;
 326
 327     $self->store_digest_authorization_nonce( $c, $key, $nonce );
 328
 329     return _join_auth_header_parts( Digest =>
 330         $self->_build_auth_header_common($c, $opts),
 331         map { sprintf '%s="%s"', $_, $nonce->$_ } qw(
 332             qop
 333             nonce
 334             opaque
 335             algorithm
 336         ),
 337     );
 338 }
 339
 340 sub _digest_auth_nonce {
 341     my ( $self, $c, $opts ) = @_;
 342
 343     my $package = __PACKAGE__ . '::Nonce';
 344
 345     my $nonce   = $package->new;
 346
 347     if ( my $algorithm = $opts->{algorithm} || $self->algorithm) {
 348         $nonce->algorithm( $algorithm );
 349     }
 350
 351     return $nonce;
 352 }
 353
 354 sub _join_auth_header_parts {
 355     my ( $type, @parts ) = @_;
 356     return "$type " . join(", ", @parts );
 357 }
 358
 359 sub get_digest_authorization_nonce {
 360     my ( $self, $c, $key ) = @_;
 361
 362     _check_cache($c);
 363     return $c->cache->get( $key );
 364 }
 365
 366 sub store_digest_authorization_nonce {
 367     my ( $self, $c, $key, $nonce ) = @_;
 368
 369     _check_cache($c);
 370     return $c->cache->set( $key, $nonce );
 371 }
 372
 373 package Catalyst::Authentication::Credential::HTTP::Nonce;
 374
 375 use strict;
 376 use base qw[ Class::Accessor::Fast ];
 377 use Data::UUID ();
 378
 379 our $VERSION = '0.02';
 380
 381 __PACKAGE__->mk_accessors(qw[ nonce nonce_count qop opaque algorithm ]);
 382
 383 sub new {
 384     my $class = shift;
 385     my $self  = $class->SUPER::new(@_);
 386
 387     $self->nonce( Data::UUID->new->create_b64 );
 388     $self->opaque( Data::UUID->new->create_b64 );
 389     $self->qop('auth,auth-int');
 390     $self->nonce_count('0x0');
 391     $self->algorithm('MD5');
 392
 393     return $self;
 394 }
 395
 396 1;
 397
 398 __END__
 399
 400 =pod
 401
 402 =head1 NAME
 403
 404 Catalyst::Authentication::Credential::HTTP - HTTP Basic and Digest authentication
 405 for Catalyst.
 406
 407 =head1 SYNOPSIS
 408
 409     use Catalyst qw/
 410         Authentication
 411     /;
 412
 413     __PACKAGE__->config( authentication => {
 414         default_realm => 'example',
 415         realms => {
 416             example => {
 417                 credential => {
 418                     class => 'HTTP',
 419                     type  => 'any', # or 'digest' or 'basic'
 420                     password_type  => 'clear',
 421                     password_field => 'password'
 422                 },
 423                 store => {
 424                     class => 'Minimal',
 425                     users => {
 426                         Mufasa => { password => "Circle Of Life", },
 427                     },
 428                 },
 429             },
 430         }
 431     });
 432
 433     sub foo : Local {
 434         my ( $self, $c ) = @_;
 435
 436         $c->authenticate({ realm => "example" });
 437         # either user gets authenticated or 401 is sent
 438         # Note that the authentication realm sent to the client (in the
 439         # RFC 2617 sense) is overridden here, but this *does not*
 440         # effect the Catalyst::Authentication::Realm used for
 441         # authentication - to do that, you need
 442         # $c->authenticate({}, 'otherrealm')
 443
 444         do_stuff();
 445     }
 446
 447     sub always_auth : Local {
 448         my ( $self, $c ) = @_;
 449
 450         # Force authorization headers onto the response so that the user
 451         # is asked again for authentication, even if they successfully
 452         # authenticated.
 453         my $realm = $c->get_auth_realm('example');
 454         $realm->credential->authorization_required_response($c, $realm);
 455     }
 456
 457     # with ACL plugin
 458     __PACKAGE__->deny_access_unless("/path", sub { $_[0]->authenticate });
 459
 460 =head1 DESCRIPTION
 461
 462 This module lets you use HTTP authentication with
 463 L<Catalyst::Plugin::Authentication>. Both basic and digest authentication
 464 are currently supported.
 465
 466 When authentication is required, this module sets a status of 401, and
 467 the body of the response to 'Authorization required.'. To override
 468 this and set your own content, check for the C<< $c->res->status ==
 469 401 >> in your C<end> action, and change the body accordingly.
 470
 471 =head2 TERMS
 472
 473 =over 4
 474
 475 =item Nonce
 476
 477 A nonce is a one-time value sent with each digest authentication
 478 request header. The value must always be unique, so per default the
 479 last value of the nonce is kept using L<Catalyst::Plugin::Cache>. To
 480 change this behaviour, override the
 481 C<store_digest_authorization_nonce> and
 482 C<get_digest_authorization_nonce> methods as shown below.
 483
 484 =back
 485
 486 =head1 METHODS
 487
 488 =over 4
 489
 490 =item new $config, $c, $realm
 491
 492 Simple constructor.
 493
 494 =item init
 495
 496 Validates that $config is ok.
 497
 498 =item authenticate $c, $realm, \%auth_info
 499
 500 Tries to authenticate the user, and if that fails calls
 501 C<authorization_required_response> and detaches the current action call stack.
 502
 503 Looks inside C<< $c->request->headers >> and processes the digest and basic
 504 (badly named) authorization header.
 505
 506 This will only try the methods set in the configuration. First digest, then basic.
 507
 508 The %auth_info hash can contain a number of keys which control the authentication behaviour:
 509
 510 =over
 511
 512 =item realm
 513
 514 Sets the HTTP authentication realm presented to the client. Note this does not alter the
 515 Catalyst::Authentication::Realm object used for the authentication.
 516
 517 =item domain
 518
 519 Array reference to domains used to build the authorization headers.
 520
 521 This list of domains defines the protection space. If a domain URI is an
 522 absolute path (starts with /), it is relative to the root URL of the server being accessed.
 523 An absolute URI in this list may refer to a different server than the one being accessed.
 524
 525 The client will use this list to determine the set of URIs for which the same authentication
 526 information may be sent.
 527
 528 If this is omitted or its value is empty, the client will assume that the
 529 protection space consists of all URIs on the responding server.
 530
 531 Therefore, if your application is not hosted at the root of this domain, and you want to
 532 prevent the authentication credentials for this application being sent to any other applications.
 533 then you should use the I<use_uri_for> configuration option, and pass a domain of I</>.
 534
 535 =back
 536
 537 =item authenticate_basic $c, $realm, \%auth_info
 538
 539 Performs HTTP basic authentication.
 540
 541 =item authenticate_digest $c, $realm, \%auth_info
 542
 543 Performs HTTP digest authentication.
 544
 545 The password_type B<must> be I<clear> for digest authentication to
 546 succeed.  If you do not want to store your user passwords as clear
 547 text, you may instead store the MD5 digest in hex of the string
 548 '$username:$realm:$password'.
 549
 550 L<Catalyst::Plugin::Cache> is used for persistent storage of the nonce
 551 values (see L</Nonce>).  It must be loaded in your application, unless
 552 you override the C<store_digest_authorization_nonce> and
 553 C<get_digest_authorization_nonce> methods as shown below.
 554
 555 Takes an additional parameter of I<algorithm>, the possible values of which are 'MD5' (the default)
 556 and 'MD5-sess'. For more information about 'MD5-sess', see section 3.2.2.2 in RFC 2617.
 557
 558 =item authorization_required_response $c, $realm, \%auth_info
 559
 560 Sets C<< $c->response >> to the correct status code, and adds the correct
 561 header to demand authentication data from the user agent.
 562
 563 Typically used by C<authenticate>, but may be invoked manually.
 564
 565 %opts can contain C<domain> and C<algorithm>, which are used to build
 566 %the digest header.
 567
 568 =item store_digest_authorization_nonce $c, $key, $nonce
 569
 570 =item get_digest_authorization_nonce $c, $key
 571
 572 Set or get the C<$nonce> object used by the digest auth mode.
 573
 574 You may override these methods. By default they will call C<get> and C<set> on
 575 C<< $c->cache >>.
 576
 577 =back
 578
 579 =head1 CONFIGURATION
 580
 581 All configuration is stored in C<< YourApp->config(authentication => { yourrealm => { credential => { class => 'HTTP', %config } } } >>.
 582
 583 This should be a hash, and it can contain the following entries:
 584
 585 =over
 586
 587 =item type
 588
 589 Can be either C<any> (the default), C<basic> or C<digest>.
 590
 591 This controls C<authorization_required_response> and C<authenticate>, but
 592 not the "manual" methods.
 593
 594 =item authorization_required_message
 595
 596 Set this to a string to override the default body content "Authorization required.", or set to undef to suppress body content being generated.
 597
 598 =item password_type
 599
 600 The type of password returned by the user object. Same usage as in
 601 L<Catalyst::Authentication::Credential::Password|Catalyst::Authentication::Credential::Password/password_type>
 602
 603 =item password_field
 604
 605 The name of accessor used to retrieve the value of the password field from the user object. Same usage as in
 606 L<Catalyst::Authentication::Credential::Password|Catalyst::Authentication::Credential::Password/password_field>
 607
 608 =item username_field
 609
 610 The field name that the user's username is mapped into when finding the user from the realm. Defaults to 'username'.
 611
 612 =item use_uri_for
 613
 614 If this configuration key has a true value, then the domain(s) for the authorization header will be
 615 run through $c->uri_for(). Use this configuration option if your application is not running at the root
 616 of your domain, and you want to ensure that authentication credentials from your application are not shared with
 617 other applications on the same server.
 618
 619 =back
 620
 621 =head1 RESTRICTIONS
 622
 623 When using digest authentication, this module will only work together
 624 with authentication stores whose User objects have a C<password>
 625 method that returns the plain-text password. It will not work together
 626 with L<Catalyst::Authentication::Store::Htpasswd>, or
 627 L<Catalyst::Authentication::Store::DBIC> stores whose
 628 C<password> methods return a hashed or salted version of the password.
 629
 630 =head1 AUTHORS
 631
 632 Updated to current name space and currently maintained
 633 by: Tomas Doran C<bobtfish@bobtfish.net>.
 634
 635 Original module by:
 636
 637 =over
 638
 639 =item Yuval Kogman, C<nothingmuch@woobling.org>
 640
 641 =item Jess Robinson
 642
 643 =item Sascha Kiefer C<esskar@cpan.org>
 644
 645 =back
 646
 647 =head1 CONTRIBUTORS
 648
 649 Patches contributed by:
 650
 651 =over
 652
 653 =item Peter Corlett
 654
 655 =item Devin Austin (dhoss) C<dhoss@cpan.org>
 656
 657 =back
 658
 659 =head1 SEE ALSO
 660
 661 RFC 2617 (or its successors), L<Catalyst::Plugin::Cache>, L<Catalyst::Plugin::Authentication>
 662
 663 =head1 COPYRIGHT & LICENSE
 664
 665         Copyright (c) 2005-2008 the aforementioned authors. All rights
 666         reserved. This program is free software; you can redistribute
 667         it and/or modify it under the same terms as Perl itself.
 668
 669 =cut
 670