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