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