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