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         realms => {
 388             example => {
 389                 credential => {
 390                     class => 'HTTP',
 391                     type  => 'any', # or 'digest' or 'basic'
 392                     password_type  => 'clear',
 393                     password_field => 'password'
 394                 },
 395                 store => {
 396                     class => 'Minimal',
 397                     users => {
 398                         Mufasa => { password => "Circle Of Life", },
 399                     },
 400                 },
 401             },
 402         }
 403     });
 404
 405     sub foo : Local {
 406         my ( $self, $c ) = @_;
 407
 408         $c->authenticate({ realm => "example" });
 409         # either user gets authenticated or 401 is sent
 410         # Note that the authentication realm sent to the client is overridden
 411         # here, but this does not affect the Catalyst::Authentication::Realm
 412         # used for authentication.
 413
 414         do_stuff();
 415     }
 416
 417     sub always_auth : Local {
 418         my ( $self, $c ) = @_;
 419
 420         # Force authorization headers onto the response so that the user
 421         # is asked again for authentication, even if they successfully
 422         # authenticated.
 423         my $realm = $c->get_auth_realm('example');
 424         $realm->credential->authorization_required_response($c, $realm);
 425     }
 426
 427     # with ACL plugin
 428     __PACKAGE__->deny_access_unless("/path", sub { $_[0]->authenticate });
 429
 430 =head1 DESCRIPTION
 431
 432 This module lets you use HTTP authentication with
 433 L<Catalyst::Plugin::Authentication>. Both basic and digest authentication
 434 are currently supported.
 435
 436 When authentication is required, this module sets a status of 401, and
 437 the body of the response to 'Authorization required.'. To override
 438 this and set your own content, check for the C<< $c->res->status ==
 439 401 >> in your C<end> action, and change the body accordingly.
 440
 441 =head2 TERMS
 442
 443 =over 4
 444
 445 =item Nonce
 446
 447 A nonce is a one-time value sent with each digest authentication
 448 request header. The value must always be unique, so per default the
 449 last value of the nonce is kept using L<Catalyst::Plugin::Cache>. To
 450 change this behaviour, override the
 451 C<store_digest_authorization_nonce> and
 452 C<get_digest_authorization_nonce> methods as shown below.
 453
 454 =back
 455
 456 =head1 METHODS
 457
 458 =over 4
 459
 460 =item new $config, $c, $realm
 461
 462 Simple constructor.
 463
 464 =item init
 465
 466 Validates that $config is ok.
 467
 468 =item authenticate $c, $realm, \%auth_info
 469
 470 Tries to authenticate the user, and if that fails calls
 471 C<authorization_required_response> and detaches the current action call stack.
 472
 473 Looks inside C<< $c->request->headers >> and processes the digest and basic
 474 (badly named) authorization header.
 475
 476 This will only try the methods set in the configuration. First digest, then basic.
 477
 478 The %auth_info hash can contain a number of keys which control the authentication behaviour:
 479
 480 =over
 481
 482 =item realm
 483
 484 Sets the HTTP authentication realm presented to the client. Note this does not alter the
 485 Catalyst::Authentication::Realm object used for the authentication.
 486
 487 =item domain
 488
 489 Array reference to domains used to build the authorization headers.
 490
 491 This list of domains defines the protection space. If a domain URI is an
 492 absolute path (starts with /), it is relative to the root URL of the server being accessed.
 493 An absolute URI in this list may refer to a different server than the one being accessed.
 494
 495 The client will use this list to determine the set of URIs for which the same authentication
 496 information may be sent.
 497
 498 If this is omitted or its value is empty, the client will assume that the
 499 protection space consists of all URIs on the responding server.
 500
 501 Therefore, if your application is not hosted at the root of this domain, and you want to
 502 prevent the authentication credentials for this application being sent to any other applications.
 503 then you should use the I<use_uri_for> configuration option, and pass a domain of I</>.
 504
 505 =back
 506
 507 =item authenticate_basic $c, $realm, \%auth_info
 508
 509 Performs HTTP basic authentication.
 510
 511 =item authenticate_digest $c, $realm, \%auth_info
 512
 513 Performs HTTP digest authentication. Note that the password_type B<must> by I<clear> for
 514 digest authentication to succeed, and you must have L<Catalyst::Plugin::Session> in
 515 your application as digest authentication needs to store persistent data.
 516
 517 Note - if you do not want to store your user passwords as clear text, then it is possible
 518 to store instead the MD5 digest in hex of the string '$username:$realm:$password'
 519
 520 Takes an additional parameter of I<algorithm>, the possible values of which are 'MD5' (the default)
 521 and 'MD5-sess'. For more information about 'MD5-sess', see section 3.2.2.2 in RFC 2617.
 522
 523 =item authorization_required_response $c, $realm, \%auth_info
 524
 525 Sets C<< $c->response >> to the correct status code, and adds the correct
 526 header to demand authentication data from the user agent.
 527
 528 Typically used by C<authenticate>, but may be invoked manually.
 529
 530 %opts can contain C<domain> and C<algorithm>, which are used to build
 531 %the digest header.
 532
 533 =item store_digest_authorization_nonce $c, $key, $nonce
 534
 535 =item get_digest_authorization_nonce $c, $key
 536
 537 Set or get the C<$nonce> object used by the digest auth mode.
 538
 539 You may override these methods. By default they will call C<get> and C<set> on
 540 C<< $c->cache >>.
 541
 542 =back
 543
 544 =head1 CONFIGURATION
 545
 546 All configuration is stored in C<< YourApp->config(authentication => { yourrealm => { credential => { class => 'HTTP', %config } } } >>.
 547
 548 This should be a hash, and it can contain the following entries:
 549
 550 =over
 551
 552 =item type
 553
 554 Can be either C<any> (the default), C<basic> or C<digest>.
 555
 556 This controls C<authorization_required_response> and C<authenticate>, but
 557 not the "manual" methods.
 558
 559 =item authorization_required_message
 560
 561 Set this to a string to override the default body content "Authorization required.", or set to undef to suppress body content being generated.
 562
 563 =item password_type
 564
 565 The type of password returned by the user object. Same usage as in
 566 L<Catalyst::Authentication::Credential::Password|Catalyst::Authentication::Credential::Password/password_type>
 567
 568 =item password_field
 569
 570 The name of accessor used to retrieve the value of the password field from the user object. Same usage as in
 571 L<Catalyst::Authentication::Credential::Password|Catalyst::Authentication::Credential::Password/password_field>
 572
 573 =item username_field
 574
 575 The field name that the user's username is mapped into when finding the user from the realm. Defaults to 'username'.
 576
 577 =item use_uri_for
 578
 579 If this configuration key has a true value, then the domain(s) for the authorization header will be
 580 run through $c->uri_for(). Use this configuration option if your application is not running at the root
 581 of your domain, and you want to ensure that authentication credentials from your application are not shared with
 582 other applications on the same server.
 583
 584 =back
 585
 586 =head1 RESTRICTIONS
 587
 588 When using digest authentication, this module will only work together
 589 with authentication stores whose User objects have a C<password>
 590 method that returns the plain-text password. It will not work together
 591 with L<Catalyst::Authentication::Store::Htpasswd>, or
 592 L<Catalyst::Authentication::Store::DBIC> stores whose
 593 C<password> methods return a hashed or salted version of the password.
 594
 595 =head1 AUTHORS
 596
 597 Updated to current name space and currently maintained
 598 by: Tomas Doran C<bobtfish@bobtfish.net>.
 599
 600 Original module by:
 601
 602 =over
 603
 604 =item Yuval Kogman, C<nothingmuch@woobling.org>
 605
 606 =item Jess Robinson
 607
 608 =item Sascha Kiefer C<esskar@cpan.org>
 609
 610 =back
 611
 612 =head1 SEE ALSO
 613
 614 RFC 2617 (or its successors), L<Catalyst::Plugin::Cache>, L<Catalyst::Plugin::Authentication>
 615
 616 =head1 COPYRIGHT & LICENSE
 617
 618         Copyright (c) 2005-2008 the aforementioned authors. All rights
 619         reserved. This program is free software; you can redistribute
 620         it and/or modify it under the same terms as Perl itself.
 621
 622 =cut
 623