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.002";
  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             # FIXME - Do not assume accessor is called password.
 147             # calculate H(A1) as per spec
 148             my $A1_digest = $r ? $user->$password_field() : do {
 149                 $ctx = Digest::MD5->new;
 150                 $ctx->add( join( ':', $username, $realm->name, $user->$password_field() ) );
 151                 $ctx->hexdigest;
 152             };
 153             if ( $nonce->algorithm eq 'MD5-sess' ) {
 154                 $ctx = Digest::MD5->new;
 155                 $ctx->add( join( ':', $A1_digest, $res{nonce}, $res{cnonce} ) );
 156                 $A1_digest = $ctx->hexdigest;
 157             }
 158
 159             my $digest_in = join( ':',
 160                     $A1_digest, $res{nonce},
 161                     $res{qop} ? ( $res{nc}, $res{cnonce}, $res{qop} ) : (),
 162                     $A2_digest );
 163             my $rq_digest = Digest::MD5::md5_hex($digest_in);
 164             $nonce->nonce_count($nonce_count);
 165             $c->cache->set( __PACKAGE__ . '::opaque:' . $nonce->opaque,
 166                 $nonce );
 167             if ($rq_digest eq $res{response}) {
 168                 $c->set_authenticated($user);
 169                 return 1;
 170             }
 171         }
 172     }
 173     return;
 174 }
 175
 176 sub _check_cache {
 177     my $c = shift;
 178
 179     die "A cache is needed for http digest authentication."
 180       unless $c->can('cache');
 181     return;
 182 }
 183
 184 sub _is_http_auth_type {
 185     my ( $self, $type ) = @_;
 186     my $cfgtype = lc( $self->_config->{'type'} || 'any' );
 187     return 1 if $cfgtype eq 'any' || $cfgtype eq lc $type;
 188     return 0;
 189 }
 190
 191 sub authorization_required_response {
 192     my ( $self, $c, $realm, $auth_info ) = @_;
 193
 194     $c->res->status(401);
 195     $c->res->content_type('text/plain');
 196     if (exists $self->_config->{authorization_required_message}) {
 197         # If you set the key to undef, don't stamp on the body.
 198         $c->res->body($self->_config->{authorization_required_message})
 199             if defined $c->res->body($self->_config->{authorization_required_message});
 200     }
 201     else {
 202         $c->res->body('Authorization required.');
 203     }
 204
 205     # *DONT* short circuit
 206     my $ok;
 207     $ok++ if $self->_create_digest_auth_response($c, $auth_info);
 208     $ok++ if $self->_create_basic_auth_response($c, $auth_info);
 209
 210     unless ( $ok ) {
 211         die 'Could not build authorization required response. '
 212         . 'Did you configure a valid authentication http type: '
 213         . 'basic, digest, any';
 214     }
 215     return;
 216 }
 217
 218 sub _add_authentication_header {
 219     my ( $c, $header ) = @_;
 220     $c->response->headers->push_header( 'WWW-Authenticate' => $header );
 221     return;
 222 }
 223
 224 sub _create_digest_auth_response {
 225     my ( $self, $c, $opts ) = @_;
 226
 227     return unless $self->_is_http_auth_type('digest');
 228
 229     if ( my $digest = $self->_build_digest_auth_header( $c, $opts ) ) {
 230         _add_authentication_header( $c, $digest );
 231         return 1;
 232     }
 233
 234     return;
 235 }
 236
 237 sub _create_basic_auth_response {
 238     my ( $self, $c, $opts ) = @_;
 239
 240     return unless $self->_is_http_auth_type('basic');
 241
 242     if ( my $basic = $self->_build_basic_auth_header( $c, $opts ) ) {
 243         _add_authentication_header( $c, $basic );
 244         return 1;
 245     }
 246
 247     return;
 248 }
 249
 250 sub _build_auth_header_realm {
 251     my ( $self ) = @_;
 252
 253     if ( my $realm = $self->realm ) {
 254         my $realm_name = String::Escape::qprintable($realm->name);
 255         $realm_name = qq{"$realm_name"} unless $realm_name =~ /^"/;
 256         return 'realm=' . $realm_name;
 257     }
 258     return;
 259 }
 260
 261 sub _build_auth_header_domain {
 262     my ( $self, $c, $opts ) = @_;
 263
 264     if ( my $domain = $opts->{domain} ) {
 265         Catalyst::Exception->throw("domain must be an array reference")
 266           unless ref($domain) && ref($domain) eq "ARRAY";
 267
 268         my @uris =
 269           $self->_config->{use_uri_for}
 270           ? ( map { $c->uri_for($_) } @$domain )
 271           : ( map { URI::Escape::uri_escape($_) } @$domain );
 272
 273         return qq{domain="@uris"};
 274     }
 275     return;
 276 }
 277
 278 sub _build_auth_header_common {
 279     my ( $self, $c, $opts ) = @_;
 280
 281     return (
 282         $self->_build_auth_header_realm(),
 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
 410         do_stuff();
 411     }
 412
 413     # with ACL plugin
 414     __PACKAGE__->deny_access_unless("/path", sub { $_[0]->authenticate });
 415
 416 =head1 DESCRIPTION
 417
 418 This module lets you use HTTP authentication with
 419 L<Catalyst::Plugin::Authentication>. Both basic and digest authentication
 420 are currently supported.
 421
 422 When authentication is required, this module sets a status of 401, and
 423 the body of the response to 'Authorization required.'. To override
 424 this and set your own content, check for the C<< $c->res->status ==
 425 401 >> in your C<end> action, and change the body accordingly.
 426
 427 =head2 TERMS
 428
 429 =over 4
 430
 431 =item Nonce
 432
 433 A nonce is a one-time value sent with each digest authentication
 434 request header. The value must always be unique, so per default the
 435 last value of the nonce is kept using L<Catalyst::Plugin::Cache>. To
 436 change this behaviour, override the
 437 C<store_digest_authorization_nonce> and
 438 C<get_digest_authorization_nonce> methods as shown below.
 439
 440 =back
 441
 442 =head1 METHODS
 443
 444 =over 4
 445
 446 =item new $config, $c, $realm
 447
 448 Simple constructor.
 449
 450 =item authenticate $c, $realm, \%auth_info
 451
 452 Tries to authenticate the user, and if that fails calls
 453 C<authorization_required_response> and detaches the current action call stack.
 454
 455 Looks inside C<< $c->request->headers >> and processes the digest and basic
 456 (badly named) authorization header.
 457
 458 This will only try the methods set in the configuration. First digest, then basic.
 459
 460 This method just passes the options through untouched. See the next two methods for what \%auth_info can contain.
 461
 462 =item authenticate_basic $c, $realm, \%auth_info
 463
 464 Acts like L<Catalyst::Authentication::Credential::Password>, and will lookup the user's password as detailed in that module.
 465
 466 =item authenticate_digest $c, $realm, \%auth_info
 467
 468 Assumes that your user object has a hard coded method which returns a clear text password.
 469
 470 =item authorization_required_response $c, $realm, \%auth_info
 471
 472 Sets C<< $c->response >> to the correct status code, and adds the correct
 473 header to demand authentication data from the user agent.
 474
 475 Typically used by C<authenticate>, but may be invoked manually.
 476
 477 %opts can contain C<domain> and C<algorithm>, which are used to build
 478 %the digest header.
 479
 480 =item store_digest_authorization_nonce $c, $key, $nonce
 481
 482 =item get_digest_authorization_nonce $c, $key
 483
 484 Set or get the C<$nonce> object used by the digest auth mode.
 485
 486 You may override these methods. By default they will call C<get> and C<set> on
 487 C<< $c->cache >>.
 488
 489 =back
 490
 491 =head1 CONFIGURATION
 492
 493 All configuration is stored in C<< YourApp->config(authentication => { yourrealm => { credential => { class => 'HTTP', %config } } } >>.
 494
 495 This should be a hash, and it can contain the following entries:
 496
 497 =over 4
 498
 499 =item type
 500
 501 Can be either C<any> (the default), C<basic> or C<digest>.
 502
 503 This controls C<authorization_required_response> and C<authenticate>, but
 504 not the "manual" methods.
 505
 506 =item authorization_required_message
 507
 508 Set this to a string to override the default body content "Authorization required.", or set to undef to suppress body content being generated.
 509
 510 =back
 511
 512 =head1 RESTRICTIONS
 513
 514 When using digest authentication, this module will only work together
 515 with authentication stores whose User objects have a C<password>
 516 method that returns the plain-text password. It will not work together
 517 with L<Catalyst::Authentication::Store::Htpasswd>, or
 518 L<Catalyst::Authentication::Store::DBIC> stores whose
 519 C<password> methods return a hashed or salted version of the password.
 520
 521 =head1 AUTHORS
 522
 523 Updated to current name space and currently maintained
 524 by: Tomas Doran C<bobtfish@bobtfish.net>.
 525
 526 Original module by:
 527
 528 =over
 529
 530 =item Yuval Kogman, C<nothingmuch@woobling.org>
 531
 532 =item Jess Robinson
 533
 534 =item Sascha Kiefer C<esskar@cpan.org>
 535
 536 =back
 537
 538 =head1 SEE ALSO
 539
 540 RFC 2617 (or its successors), L<Catalyst::Plugin::Cache>, L<Catalyst::Plugin::Authentication>
 541
 542 =head1 COPYRIGHT & LICENSE
 543
 544         Copyright (c) 2005-2008 the aforementioned authors. All rights
 545         reserved. This program is free software; you can redistribute
 546         it and/or modify it under the same terms as Perl itself.
 547
 548 =cut
 549