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