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