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 =back
 482
 483 =item authenticate_basic $c, $realm, \%auth_info
 484
 485 Performs HTTP basic authentication.
 486
 487 =item authenticate_digest $c, $realm, \%auth_info
 488
 489 Performs HTTP digest authentication. Note that the password_type B<must> by I<clear> for
 490 digest authentication to succeed, and you must have L<Catalyst::Plugin::Session> in
 491 your application as digest authentication needs to store persistent data.
 492
 493 Note - if you do not want to store your user passwords as clear text, then it is possible
 494 to store instead the MD5 digest in hex of the string '$username:$realm:$password'
 495
 496 =item authorization_required_response $c, $realm, \%auth_info
 497
 498 Sets C<< $c->response >> to the correct status code, and adds the correct
 499 header to demand authentication data from the user agent.
 500
 501 Typically used by C<authenticate>, but may be invoked manually.
 502
 503 %opts can contain C<domain> and C<algorithm>, which are used to build
 504 %the digest header.
 505
 506 =item store_digest_authorization_nonce $c, $key, $nonce
 507
 508 =item get_digest_authorization_nonce $c, $key
 509
 510 Set or get the C<$nonce> object used by the digest auth mode.
 511
 512 You may override these methods. By default they will call C<get> and C<set> on
 513 C<< $c->cache >>.
 514
 515 =back
 516
 517 =head1 CONFIGURATION
 518
 519 All configuration is stored in C<< YourApp->config(authentication => { yourrealm => { credential => { class => 'HTTP', %config } } } >>.
 520
 521 This should be a hash, and it can contain the following entries:
 522
 523 =over
 524
 525 =item type
 526
 527 Can be either C<any> (the default), C<basic> or C<digest>.
 528
 529 This controls C<authorization_required_response> and C<authenticate>, but
 530 not the "manual" methods.
 531
 532 =item authorization_required_message
 533
 534 Set this to a string to override the default body content "Authorization required.", or set to undef to suppress body content being generated.
 535
 536 =item password_type
 537
 538 The type of password returned by the user object. Same usage as in
 539 L<Catalyst::Authentication::Credential::Password|Catalyst::Authentication::Credential::Password/passwprd_type>
 540
 541 =item password_field
 542
 543 The name of accessor used to retrieve the value of the password field from the user object. Same usage as in
 544 L<Catalyst::Authentication::Credential::Password|Catalyst::Authentication::Credential::Password/password_field>
 545
 546 =item use_uri_for
 547
 548 If this configuration key has a true value, then the domain(s) for the authorization header will be
 549 run through $c->uri_for()
 550
 551 =back
 552
 553 =head1 RESTRICTIONS
 554
 555 When using digest authentication, this module will only work together
 556 with authentication stores whose User objects have a C<password>
 557 method that returns the plain-text password. It will not work together
 558 with L<Catalyst::Authentication::Store::Htpasswd>, or
 559 L<Catalyst::Authentication::Store::DBIC> stores whose
 560 C<password> methods return a hashed or salted version of the password.
 561
 562 =head1 AUTHORS
 563
 564 Updated to current name space and currently maintained
 565 by: Tomas Doran C<bobtfish@bobtfish.net>.
 566
 567 Original module by:
 568
 569 =over
 570
 571 =item Yuval Kogman, C<nothingmuch@woobling.org>
 572
 573 =item Jess Robinson
 574
 575 =item Sascha Kiefer C<esskar@cpan.org>
 576
 577 =back
 578
 579 =head1 SEE ALSO
 580
 581 RFC 2617 (or its successors), L<Catalyst::Plugin::Cache>, L<Catalyst::Plugin::Authentication>
 582
 583 =head1 COPYRIGHT & LICENSE
 584
 585         Copyright (c) 2005-2008 the aforementioned authors. All rights
 586         reserved. This program is free software; you can redistribute
 587         it and/or modify it under the same terms as Perl itself.
 588
 589 =cut
 590