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, $c, $opts ) = @_;
 252     if ( my $realm_name = String::Escape::qprintable($opts->{realm} ? $opts->{realm} : $self->realm->name) ) {
 253         $realm_name = qq{"$realm_name"} unless $realm_name =~ /^"/;
 254         return 'realm=' . $realm_name;
 255     }
 256     return;
 257 }
 258
 259 sub _build_auth_header_domain {
 260     my ( $self, $c, $opts ) = @_;
 261
 262     if ( my $domain = $opts->{domain} ) {
 263         Catalyst::Exception->throw("domain must be an array reference")
 264           unless ref($domain) && ref($domain) eq "ARRAY";
 265
 266         my @uris =
 267           $self->_config->{use_uri_for}
 268           ? ( map { $c->uri_for($_) } @$domain )
 269           : ( map { URI::Escape::uri_escape($_) } @$domain );
 270
 271         return qq{domain="@uris"};
 272     }
 273     return;
 274 }
 275
 276 sub _build_auth_header_common {
 277     my ( $self, $c, $opts ) = @_;
 278
 279     return (
 280         $self->_build_auth_header_realm($c, $opts),
 281         $self->_build_auth_header_domain($c, $opts),
 282     );
 283 }
 284
 285 sub _build_basic_auth_header {
 286     my ( $self, $c, $opts ) = @_;
 287     return _join_auth_header_parts( Basic => $self->_build_auth_header_common( $c, $opts ) );
 288 }
 289
 290 sub _build_digest_auth_header {
 291     my ( $self, $c, $opts ) = @_;
 292
 293     my $nonce = $self->_digest_auth_nonce($c, $opts);
 294
 295     my $key = __PACKAGE__ . '::opaque:' . $nonce->opaque;
 296
 297     $self->store_digest_authorization_nonce( $c, $key, $nonce );
 298
 299     return _join_auth_header_parts( Digest =>
 300         $self->_build_auth_header_common($c, $opts),
 301         map { sprintf '%s="%s"', $_, $nonce->$_ } qw(
 302             qop
 303             nonce
 304             opaque
 305             algorithm
 306         ),
 307     );
 308 }
 309
 310 sub _digest_auth_nonce {
 311     my ( $self, $c, $opts ) = @_;
 312
 313     my $package = __PACKAGE__ . '::Nonce';
 314
 315     my $nonce   = $package->new;
 316
 317     if ( my $algorithm = $opts->{algorithm} || $self->_config->{algorithm}) {
 318         $nonce->algorithm( $algorithm );
 319     }
 320
 321     return $nonce;
 322 }
 323
 324 sub _join_auth_header_parts {
 325     my ( $type, @parts ) = @_;
 326     return "$type " . join(", ", @parts );
 327 }
 328
 329 sub get_digest_authorization_nonce {
 330     my ( $self, $c, $key ) = @_;
 331
 332     _check_cache($c);
 333     return $c->cache->get( $key );
 334 }
 335
 336 sub store_digest_authorization_nonce {
 337     my ( $self, $c, $key, $nonce ) = @_;
 338
 339     _check_cache($c);
 340     return $c->cache->set( $key, $nonce );
 341 }
 342
 343 package Catalyst::Authentication::Credential::HTTP::Nonce;
 344
 345 use strict;
 346 use base qw[ Class::Accessor::Fast ];
 347 use Data::UUID ();
 348
 349 our $VERSION = '0.02';
 350
 351 __PACKAGE__->mk_accessors(qw[ nonce nonce_count qop opaque algorithm ]);
 352
 353 sub new {
 354     my $class = shift;
 355     my $self  = $class->SUPER::new(@_);
 356
 357     $self->nonce( Data::UUID->new->create_b64 );
 358     $self->opaque( Data::UUID->new->create_b64 );
 359     $self->qop('auth,auth-int');
 360     $self->nonce_count('0x0');
 361     $self->algorithm('MD5');
 362
 363     return $self;
 364 }
 365
 366 1;
 367
 368 __END__
 369
 370 =pod
 371
 372 =head1 NAME
 373
 374 Catalyst::Authentication::Credential::HTTP - HTTP Basic and Digest authentication
 375 for Catalyst.
 376
 377 =head1 SYNOPSIS
 378
 379     use Catalyst qw/
 380         Authentication
 381     /;
 382
 383     __PACKAGE__->config( authentication => {
 384         realms => {
 385             example => {
 386                 credential => {
 387                     class => 'HTTP',
 388                     type  => 'any', # or 'digest' or 'basic'
 389                     password_type  => 'clear',
 390                     password_field => 'password'
 391                 },
 392                 store => {
 393                     class => 'Minimal',
 394                     users => {
 395                         Mufasa => { password => "Circle Of Life", },
 396                     },
 397                 },
 398             },
 399         }
 400     });
 401
 402     sub foo : Local {
 403         my ( $self, $c ) = @_;
 404
 405         $c->authenticate({ realm => "example" });
 406         # either user gets authenticated or 401 is sent
 407         # Note that the authentication realm sent to the client is overridden
 408         # here, but this does not affect the Catalyst::Authentication::Realm
 409         # used for authentication.
 410
 411         do_stuff();
 412     }
 413
 414     sub always_auth : Local {
 415         my ( $self, $c ) = @_;
 416
 417         # Force authorization headers onto the response so that the user
 418         # is asked again for authentication, even if they successfully
 419         # authenticated.
 420         my $realm = $c->get_auth_realm('example');
 421         $realm->credential->authorization_required_response($c, $realm);
 422     }
 423
 424     # with ACL plugin
 425     __PACKAGE__->deny_access_unless("/path", sub { $_[0]->authenticate });
 426
 427 =head1 DESCRIPTION
 428
 429 This module lets you use HTTP authentication with
 430 L<Catalyst::Plugin::Authentication>. Both basic and digest authentication
 431 are currently supported.
 432
 433 When authentication is required, this module sets a status of 401, and
 434 the body of the response to 'Authorization required.'. To override
 435 this and set your own content, check for the C<< $c->res->status ==
 436 401 >> in your C<end> action, and change the body accordingly.
 437
 438 =head2 TERMS
 439
 440 =over 4
 441
 442 =item Nonce
 443
 444 A nonce is a one-time value sent with each digest authentication
 445 request header. The value must always be unique, so per default the
 446 last value of the nonce is kept using L<Catalyst::Plugin::Cache>. To
 447 change this behaviour, override the
 448 C<store_digest_authorization_nonce> and
 449 C<get_digest_authorization_nonce> methods as shown below.
 450
 451 =back
 452
 453 =head1 METHODS
 454
 455 =over 4
 456
 457 =item new $config, $c, $realm
 458
 459 Simple constructor.
 460
 461 =item authenticate $c, $realm, \%auth_info
 462
 463 Tries to authenticate the user, and if that fails calls
 464 C<authorization_required_response> and detaches the current action call stack.
 465
 466 Looks inside C<< $c->request->headers >> and processes the digest and basic
 467 (badly named) authorization header.
 468
 469 This will only try the methods set in the configuration. First digest, then basic.
 470
 471 The %auth_info hash can contain a number of keys which control the authentication behaviour:
 472
 473 =over
 474
 475 =item realm
 476
 477 Sets the HTTP authentication realm presented to the client. Note this does not alter the
 478 Catalyst::Authentication::Realm object used for the authentication.
 479
 480 =item password_type
 481
 482 The type of password returned by the user object. Same useage as in
 483 L<Catalyst::Authentication::Credential::Password|Catalyst::Authentication::Credential::Password/passwprd_type>
 484
 485 =item password_field
 486
 487 The name of accessor used to retrieve the value of the password field from the user object. Same useage as in
 488 L<Catalyst::Authentication::Credential::Password|Catalyst::Authentication::Credential::Password/password_field>
 489
 490 =back
 491
 492 =item authenticate_basic $c, $realm, \%auth_info
 493
 494 Performs HTTP basic authentication.
 495
 496 =item authenticate_digest $c, $realm, \%auth_info
 497
 498 Performs HTTP digest authentication. Note that the password_type B<must> by I<clear> for
 499 digest authentication to succeed.
 500
 501 =item authorization_required_response $c, $realm, \%auth_info
 502
 503 Sets C<< $c->response >> to the correct status code, and adds the correct
 504 header to demand authentication data from the user agent.
 505
 506 Typically used by C<authenticate>, but may be invoked manually.
 507
 508 %opts can contain C<domain> and C<algorithm>, which are used to build
 509 %the digest header.
 510
 511 =item store_digest_authorization_nonce $c, $key, $nonce
 512
 513 =item get_digest_authorization_nonce $c, $key
 514
 515 Set or get the C<$nonce> object used by the digest auth mode.
 516
 517 You may override these methods. By default they will call C<get> and C<set> on
 518 C<< $c->cache >>.
 519
 520 =back
 521
 522 =head1 CONFIGURATION
 523
 524 All configuration is stored in C<< YourApp->config(authentication => { yourrealm => { credential => { class => 'HTTP', %config } } } >>.
 525
 526 This should be a hash, and it can contain the following entries:
 527
 528 =over 4
 529
 530 =item type
 531
 532 Can be either C<any> (the default), C<basic> or C<digest>.
 533
 534 This controls C<authorization_required_response> and C<authenticate>, but
 535 not the "manual" methods.
 536
 537 =item authorization_required_message
 538
 539 Set this to a string to override the default body content "Authorization required.", or set to undef to suppress body content being generated.
 540
 541 =back
 542
 543 =head1 RESTRICTIONS
 544
 545 When using digest authentication, this module will only work together
 546 with authentication stores whose User objects have a C<password>
 547 method that returns the plain-text password. It will not work together
 548 with L<Catalyst::Authentication::Store::Htpasswd>, or
 549 L<Catalyst::Authentication::Store::DBIC> stores whose
 550 C<password> methods return a hashed or salted version of the password.
 551
 552 =head1 AUTHORS
 553
 554 Updated to current name space and currently maintained
 555 by: Tomas Doran C<bobtfish@bobtfish.net>.
 556
 557 Original module by:
 558
 559 =over
 560
 561 =item Yuval Kogman, C<nothingmuch@woobling.org>
 562
 563 =item Jess Robinson
 564
 565 =item Sascha Kiefer C<esskar@cpan.org>
 566
 567 =back
 568
 569 =head1 SEE ALSO
 570
 571 RFC 2617 (or its successors), L<Catalyst::Plugin::Cache>, L<Catalyst::Plugin::Authentication>
 572
 573 =head1 COPYRIGHT & LICENSE
 574
 575         Copyright (c) 2005-2008 the aforementioned authors. All rights
 576         reserved. This program is free software; you can redistribute
 577         it and/or modify it under the same terms as Perl itself.
 578
 579 =cut
 580