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