lib/Catalyst/Plugin/Authentication/Credential/HTTP.pm

   1 #!/usr/bin/perl
   2
   3 package Catalyst::Plugin::Authentication::Credential::HTTP;
   4 use base qw/Catalyst::Plugin::Authentication::Credential::Password/;
   5
   6 use strict;
   7 use warnings;
   8
   9 use String::Escape ();
  10 use URI::Escape    ();
  11 use Catalyst       ();
  12 use Digest::MD5    ();
  13
  14 our $VERSION = "0.06";
  15
  16 sub authenticate_http {
  17     my ( $c, @args ) = @_;
  18
  19     return 1 if $c->_is_http_auth_type('digest') && $c->authenticate_digest(@args);
  20     return 1 if $c->_is_http_auth_type('basic')  && $c->authenticate_basic(@args);
  21 }
  22
  23 sub get_http_auth_store {
  24     my ( $c, %opts ) = @_;
  25
  26     my $store = $opts{store} || $c->config->{authentication}{http}{store} || return;
  27
  28     return ref $store
  29         ? $store
  30         : $c->get_auth_store($store);
  31 }
  32
  33 sub authenticate_basic {
  34     my ( $c, %opts ) = @_;
  35
  36     $c->log->debug('Checking http basic authentication.') if $c->debug;
  37
  38     my $headers = $c->req->headers;
  39
  40     if ( my ( $username, $password ) = $headers->authorization_basic ) {
  41
  42         my $user;
  43
  44         unless ( $user = $opts{user} ) {
  45             if ( my $store = $c->get_http_auth_store(%opts) ) {
  46                 $user = $store->get_user($username);
  47             } else {
  48                 $user = $username;
  49             }
  50         }
  51
  52         return $c->login( $user, $password );
  53     }
  54
  55     return 0;
  56 }
  57
  58 sub authenticate_digest {
  59     my ( $c, %opts ) = @_;
  60
  61     $c->log->debug('Checking http digest authentication.') if $c->debug;
  62
  63     my $headers       = $c->req->headers;
  64     my @authorization = $headers->header('Authorization');
  65     foreach my $authorization (@authorization) {
  66         next unless $authorization =~ m{^Digest};
  67
  68         my %res = map {
  69             my @key_val = split /=/, $_, 2;
  70             $key_val[0] = lc $key_val[0];
  71             $key_val[1] =~ s{"}{}g;    # remove the quotes
  72             @key_val;
  73         } split /,\s?/, substr( $authorization, 7 );    #7 == length "Digest "
  74
  75         my $opaque = $res{opaque};
  76         my $nonce  = $c->get_digest_authorization_nonce( __PACKAGE__ . '::opaque:' . $opaque );
  77         next unless $nonce;
  78
  79         $c->log->debug('Checking authentication parameters.')
  80           if $c->debug;
  81
  82         my $uri         = '/' . $c->request->path;
  83         my $algorithm   = $res{algorithm} || 'MD5';
  84         my $nonce_count = '0x' . $res{nc};
  85
  86         my $check = $uri eq $res{uri}
  87           && ( exists $res{username} )
  88           && ( exists $res{qop} )
  89           && ( exists $res{cnonce} )
  90           && ( exists $res{nc} )
  91           && $algorithm eq $nonce->algorithm
  92           && hex($nonce_count) > hex( $nonce->nonce_count )
  93           && $res{nonce} eq $nonce->nonce;    # TODO: set Stale instead
  94
  95         unless ($check) {
  96             $c->log->debug('Digest authentication failed. Bad request.')
  97               if $c->debug;
  98             $c->res->status(400);             # bad request
  99             die $Catalyst::DETACH;
 100         }
 101
 102         $c->log->debug('Checking authentication response.')
 103           if $c->debug;
 104
 105         my $username = $res{username};
 106         my $realm    = $res{realm};
 107
 108         my $user;
 109
 110         unless ( $user = $opts{user} ) {
 111             if ( my $store = $c->get_http_auth_store(%opts) || $c->default_auth_store ) {
 112                 $user = $store->get_user($username);
 113             }
 114         }
 115
 116         unless ($user) {    # no user, no authentication
 117             $c->log->debug('Unknown user: $user.') if $c->debug;
 118             return 0;
 119         }
 120
 121         # everything looks good, let's check the response
 122
 123         # calculate H(A2) as per spec
 124         my $ctx = Digest::MD5->new;
 125         $ctx->add( join( ':', $c->request->method, $res{uri} ) );
 126         if ( $res{qop} eq 'auth-int' ) {
 127             my $digest =
 128               Digest::MD5::md5_hex( $c->request->body );    # not sure here
 129             $ctx->add( ':', $digest );
 130         }
 131         my $A2_digest = $ctx->hexdigest;
 132
 133         # the idea of the for loop:
 134         # if we do not want to store the plain password in our user store,
 135         # we can store md5_hex("$username:$realm:$password") instead
 136         for my $r ( 0 .. 1 ) {
 137
 138             # calculate H(A1) as per spec
 139             my $A1_digest = $r ? $user->password : do {
 140                 $ctx = Digest::MD5->new;
 141                 $ctx->add( join( ':', $username, $realm, $user->password ) );
 142                 $ctx->hexdigest;
 143             };
 144             if ( $nonce->algorithm eq 'MD5-sess' ) {
 145                 $ctx = Digest::MD5->new;
 146                 $ctx->add( join( ':', $A1_digest, $res{nonce}, $res{cnonce} ) );
 147                 $A1_digest = $ctx->hexdigest;
 148             }
 149
 150             my $rq_digest = Digest::MD5::md5_hex(
 151                 join( ':',
 152                     $A1_digest, $res{nonce},
 153                     $res{qop} ? ( $res{nc}, $res{cnonce}, $res{qop} ) : (),
 154                     $A2_digest )
 155             );
 156
 157             $nonce->nonce_count($nonce_count);
 158             $c->cache->set( __PACKAGE__ . '::opaque:' . $nonce->opaque,
 159                 $nonce );
 160
 161             return $c->login( $user, $user->password )
 162               if $rq_digest eq $res{response};
 163         }
 164     }
 165
 166     return 0;
 167 }
 168
 169 sub _check_cache {
 170     my $c = shift;
 171
 172     die "A cache is needed for http digest authentication."
 173       unless $c->can('cache');
 174 }
 175
 176 sub _is_http_auth_type {
 177     my ( $c, $type ) = @_;
 178
 179     my $cfgtype = lc( $c->config->{authentication}{http}{type} || 'any' );
 180     return 1 if $cfgtype eq 'any' || $cfgtype eq lc $type;
 181     return 0;
 182 }
 183
 184 sub authorization_required {
 185     my ( $c, @args ) = @_;
 186
 187     return 1 if $c->authenticate_http(@args);
 188
 189     $c->authorization_required_response(@args);
 190
 191     die $Catalyst::DETACH;
 192 }
 193
 194 sub authorization_required_response {
 195     my ( $c, %opts ) = @_;
 196
 197     $c->res->status(401);
 198
 199     # *DONT* short circuit
 200     my $ok;
 201     $ok++ if $c->_create_digest_auth_response(\%opts);
 202     $ok++ if $c->_create_basic_auth_response(\%opts);
 203
 204     unless ( $ok ) {
 205         die 'Could not build authorization required response. '
 206         . 'Did you configure a valid authentication http type: '
 207         . 'basic, digest, any';
 208     }
 209 }
 210
 211 sub _add_authentication_header {
 212     my ( $c, $header ) = @_;
 213     $c->res->headers->push_header( 'WWW-Authenticate' => $header );
 214 }
 215
 216 sub _create_digest_auth_response {
 217     my ( $c, $opts ) = @_;
 218
 219     return unless $c->_is_http_auth_type('digest');
 220
 221     if ( my $digest = $c->_build_digest_auth_header( $opts ) ) {
 222         $c->_add_authentication_header( $digest );
 223         return 1;
 224     }
 225
 226     return;
 227 }
 228
 229 sub _create_basic_auth_response {
 230     my ( $c, $opts ) = @_;
 231
 232     return unless $c->_is_http_auth_type('basic');
 233
 234     if ( my $basic = $c->_build_basic_auth_header( $opts ) ) {
 235         $c->_add_authentication_header( $basic );
 236         return 1;
 237     }
 238
 239     return;
 240 }
 241
 242 sub _build_auth_header_realm {
 243     my ( $c, $opts ) = @_;
 244
 245     if ( my $realm = $opts->{realm} ) {
 246         return 'realm=' . String::Escape::qprintable($realm);
 247     } else {
 248         return;
 249     }
 250 }
 251
 252 sub _build_auth_header_domain {
 253     my ( $c, $opts ) = @_;
 254
 255     if ( my $domain = $opts->{domain} ) {
 256         Catalyst::Exception->throw("domain must be an array reference")
 257           unless ref($domain) && ref($domain) eq "ARRAY";
 258
 259         my @uris =
 260           $c->config->{authentication}{http}{use_uri_for}
 261           ? ( map { $c->uri_for($_) } @$domain )
 262           : ( map { URI::Escape::uri_escape($_) } @$domain );
 263
 264         return qq{domain="@uris"};
 265     } else {
 266         return;
 267     }
 268 }
 269
 270 sub _build_auth_header_common {
 271     my ( $c, $opts ) = @_;
 272
 273     return (
 274         $c->_build_auth_header_realm($opts),
 275         $c->_build_auth_header_domain($opts),
 276     );
 277 }
 278
 279 sub _build_basic_auth_header {
 280     my ( $c, $opts ) = @_;
 281     return $c->_join_auth_header_parts( Basic => $c->_build_auth_header_common( $opts ) );
 282 }
 283
 284 sub _build_digest_auth_header {
 285     my ( $c, $opts ) = @_;
 286
 287     my $nonce = $c->_digest_auth_nonce($opts);
 288
 289     my $key = __PACKAGE__ . '::opaque:' . $nonce->opaque;
 290
 291     $c->store_digest_authorization_nonce( $key, $nonce );
 292
 293     return $c->_join_auth_header_parts( Digest =>
 294         $c->_build_auth_header_common($opts),
 295         map { sprintf '%s="%s"', $_, $nonce->$_ } qw(
 296             qop
 297             nonce
 298             opaque
 299             algorithm
 300         ),
 301     );
 302 }
 303
 304 sub _digest_auth_nonce {
 305     my ( $c, $opts ) = @_;
 306
 307     my $package = __PACKAGE__ . '::Nonce';
 308
 309     my $nonce   = $package->new;
 310
 311     if ( my $algorithm = $opts->{algorithm} || $c->config->{authentication}{http}{algorithm}) {
 312         $nonce->algorithm( $algorithm );
 313     }
 314
 315     return $nonce;
 316 }
 317
 318 sub _join_auth_header_parts {
 319     my ( $c, $type, @parts ) = @_;
 320     return "$type " . join(", ", @parts );
 321 }
 322
 323 sub get_digest_authorization_nonce {
 324     my ( $c, $key ) = @_;
 325
 326     $c->_check_cache;
 327     $c->cache->get( $key );
 328 }
 329
 330 sub store_digest_authorization_nonce {
 331     my ( $c, $key, $nonce ) = @_;
 332
 333     $c->_check_cache;
 334     $c->cache->set( $key, $nonce );
 335 }
 336
 337 package Catalyst::Plugin::Authentication::Credential::HTTP::Nonce;
 338
 339 use strict;
 340 use base qw[ Class::Accessor::Fast ];
 341 use Data::UUID ();
 342
 343 our $VERSION = "0.01";
 344
 345 __PACKAGE__->mk_accessors(qw[ nonce nonce_count qop opaque algorithm ]);
 346
 347 sub new {
 348     my $class = shift;
 349     my $self  = $class->SUPER::new(@_);
 350
 351     $self->nonce( Data::UUID->new->create_b64 );
 352     $self->opaque( Data::UUID->new->create_b64 );
 353     $self->qop('auth,auth-int');
 354     $self->nonce_count('0x0');
 355     $self->algorithm('MD5');
 356
 357     return $self;
 358 }
 359
 360 1;
 361
 362 __END__
 363
 364 =pod
 365
 366 =head1 NAME
 367
 368 Catalyst::Plugin::Authentication::Credential::HTTP - HTTP Basic and Digest authentication
 369 for Catlayst.
 370
 371 =head1 SYNOPSIS
 372
 373     use Catalyst qw/
 374         Authentication
 375         Authentication::Store::Moose
 376         Authentication::Credential::HTTP
 377     /;
 378
 379     __PACKAGE__->config->{authentication}{http}{type} = 'any'; # or 'digest' or 'basic'
 380     __PACKAGE__->config->{authentication}{users} = {
 381         Mufasa => { password => "Circle Of Life", },
 382     };
 383
 384     sub foo : Local {
 385         my ( $self, $c ) = @_;
 386
 387         $c->authorization_required( realm => "foo" ); # named after the status code ;-)
 388
 389         # either user gets authenticated or 401 is sent
 390
 391         do_stuff();
 392     }
 393
 394     # with ACL plugin
 395     __PACKAGE__->deny_access_unless("/path", sub { $_[0]->authenticate_http });
 396
 397     sub end : Private {
 398         my ( $self, $c ) = @_;
 399
 400         $c->authorization_required_response( realm => "foo" );
 401         $c->error(0);
 402     }
 403
 404 =head1 DESCRIPTION
 405
 406 This moduule lets you use HTTP authentication with
 407 L<Catalyst::Plugin::Authentication>. Both basic and digest authentication
 408 are currently supported.
 409
 410 =head1 METHODS
 411
 412 =over 4
 413
 414 =item authorization_required %opts
 415
 416 Tries to C<authenticate_http>, and if that fails calls
 417 C<authorization_required_response> and detaches the current action call stack.
 418
 419 This method just passes the options through untouched.
 420
 421 =item authenticate_http %opts
 422
 423 Looks inside C<< $c->request->headers >> and processes the digest and basic
 424 (badly named) authorization header.
 425
 426 This will only try the methods set in the configuration.
 427
 428 See the next two methods for what %opts can contain.
 429
 430 =item authenticate_basic %opts
 431
 432 =item authenticate_digest %opts
 433
 434 Try to authenticate one of the methods without checking if the method is
 435 allowed in the configuration.
 436
 437 %opts can contain C<store> (either an object or a name), C<user> (to disregard
 438 %the username from the header altogether, overriding it with a username or user
 439 %object).
 440
 441 =item authorization_required_response %opts
 442
 443 Sets C<< $c->response >> to the correct status code, and adds the correct
 444 header to demand authentication data from the user agent.
 445
 446 Typically used by C<authorization_required>, but may be invoked manually.
 447
 448 %opts can contain C<realm>, C<domain> and C<algorithm>, which are used to build
 449 %the digest header.
 450
 451 =item store_digest_authorization_nonce $key, $nonce
 452
 453 =item get_digest_authorization_nonce $key
 454
 455 Set or get the C<$nonce> object used by the digest auth mode.
 456
 457 You may override these methods. By default they will call C<get> and C<set> on
 458 C<< $c->cache >>.
 459
 460 =back
 461
 462 =head1 CONFIGURATION
 463
 464 All configuration is stored in C<< YourApp->config->{authentication}{http} >>.
 465
 466 This should be a hash, and it can contain the following entries:
 467
 468 =over 4
 469
 470 =item store
 471
 472 Either a name or an object -- the default store to use for HTTP authentication.
 473
 474 =item type
 475
 476 Can be either C<any> (the default), C<basic> or C<digest>.
 477
 478 This controls C<authorization_required_response> and C<authenticate_http>, but
 479 not the "manual" methods.
 480
 481 =back
 482
 483 =head1 AUTHORS
 484
 485 Yuval Kogman, C<nothingmuch@woobling.org>
 486
 487 Jess Robinson
 488
 489 Sascha Kiefer C<esskar@cpan.org>
 490
 491 =head1 COPYRIGHT & LICENSE
 492
 493         Copyright (c) 2005-2006 the aforementioned authors. All rights
 494         reserved. This program is free software; you can redistribute
 495         it and/or modify it under the same terms as Perl itself.
 496
 497 =cut