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