| Commit | Line | Data |
|---|
| 007935b8 |
1 | #!/usr/bin/perl\r |
| 2 | \r |
| 3 | package Catalyst::Plugin::Authentication::Credential::HTTP;\r |
| 4 | use base qw/Catalyst::Plugin::Authentication::Credential::Password/;\r |
| 5 | \r |
| 6 | use strict;\r |
| 7 | use warnings;\r |
| 8 | \r |
| 9 | use String::Escape ();\r |
| 10 | use URI::Escape ();\r |
| 11 | use Catalyst ();\r |
| 12 | use Digest::MD5 ();\r |
| 13 | \r |
| 14 | our $VERSION = "0.02";\r |
| 15 | \r |
| 16 | sub authenticate_http {\r |
| 17 | my $c = shift;\r |
| 18 | \r |
| 19 | return $c->authenticate_digest || $c->authenticate_basic;\r |
| 20 | }\r |
| 21 | \r |
| 22 | sub authenticate_basic {\r |
| 23 | my $c = shift;\r |
| 24 | \r |
| 25 | $c->log->debug('Checking http basic authentication.') if $c->debug;\r |
| 26 | \r |
| 27 | my $headers = $c->req->headers;\r |
| 28 | \r |
| 29 | if ( my ( $user, $password ) = $headers->authorization_basic ) {\r |
| 30 | \r |
| 31 | if ( my $store = $c->config->{authentication}{http}{store} ) {\r |
| 32 | $user = $store->get_user($user);\r |
| 33 | }\r |
| 34 | \r |
| 35 | return $c->login( $user, $password );\r |
| 36 | }\r |
| 37 | \r |
| 38 | return 0;\r |
| 39 | }\r |
| 40 | \r |
| 41 | sub authenticate_digest {\r |
| 42 | my $c = shift;\r |
| 43 | \r |
| 44 | $c->log->debug('Checking http digest authentication.') if $c->debug;\r |
| 45 | \r |
| 46 | my $headers = $c->req->headers;\r |
| 47 | my @authorization = $headers->header('Authorization');\r |
| 48 | foreach my $authorization (@authorization) {\r |
| 49 | next unless $authorization =~ m{^Digest};\r |
| 50 | \r |
| 51 | $c->_check_cache;\r |
| 52 | \r |
| 53 | my %res = map {\r |
| 54 | my @key_val = split /=/, $_, 2;\r |
| 55 | $key_val[0] = lc $key_val[0];\r |
| 56 | $key_val[1] =~ s{"}{}g; # remove the quotes\r |
| 57 | @key_val;\r |
| 58 | } split /,\s?/, substr( $authorization, 7 ); #7 == length "Digest "\r |
| 59 | \r |
| 60 | my $opaque = $res{opaque};\r |
| 61 | my $nonce = $c->cache->get( __PACKAGE__ . '::opaque:' . $opaque );\r |
| 62 | next unless $nonce;\r |
| 63 | \r |
| 64 | $c->log->debug('Checking authentication parameters.')\r |
| 65 | if $c->debug;\r |
| 66 | \r |
| 67 | my $uri = '/' . $c->request->path;\r |
| 68 | my $algorithm = $res{algorithm} || 'MD5';\r |
| 69 | my $nonce_count = '0x' . $res{nc};\r |
| 70 | \r |
| 71 | my $check = $uri eq $res{uri}\r |
| 72 | && ( exists $res{username} )\r |
| 73 | && ( exists $res{qop} )\r |
| 74 | && ( exists $res{cnonce} )\r |
| 75 | && ( exists $res{nc} )\r |
| 76 | && $algorithm eq $nonce->algorithm\r |
| 77 | && hex($nonce_count) > hex( $nonce->nonce_count )\r |
| 78 | && $res{nonce} eq $nonce->nonce; # TODO: set Stale instead\r |
| 79 | \r |
| 80 | unless ($check) {\r |
| 81 | $c->log->debug('Digest authentication failed. Bad request.')\r |
| 82 | if $c->debug;\r |
| 83 | $c->res->status(400); # bad request\r |
| 84 | die $Catalyst::DETACH;\r |
| 85 | }\r |
| 86 | \r |
| 87 | $c->log->debug('Checking authentication response.')\r |
| 88 | if $c->debug;\r |
| 89 | \r |
| 90 | my $username = $res{username};\r |
| 91 | my $realm = $res{realm};\r |
| 92 | \r |
| 93 | my $user;\r |
| 94 | my $store = $c->config->{authentication}{http}{store}\r |
| 95 | || $c->default_auth_store;\r |
| 96 | $user = $store->get_user($username) if $store;\r |
| 97 | unless ($user) { # no user, no authentication\r |
| 98 | $c->log->debug('Unknown user: $user.') if $c->debug;\r |
| 99 | return 0;\r |
| 100 | }\r |
| 101 | \r |
| 102 | # everything looks good, let's check the response\r |
| 103 | \r |
| 104 | # calculate H(A2) as per spec\r |
| 105 | my $ctx = Digest::MD5->new;\r |
| 106 | $ctx->add( join( ':', $c->request->method, $res{uri} ) );\r |
| 107 | if ( $res{qop} eq 'auth-int' ) {\r |
| 108 | my $digest =\r |
| 109 | Digest::MD5::md5_hex( $c->request->body ); # not sure here\r |
| 110 | $ctx->add( ':', $digest );\r |
| 111 | }\r |
| 112 | my $A2_digest = $ctx->hexdigest;\r |
| 113 | \r |
| 114 | # the idea of the for loop:\r |
| 115 | # if we do not want to store the plain password in our user store,\r |
| 116 | # we can store md5_hex("$username:$realm:$password") instead\r |
| 117 | for my $r ( 0 .. 1 ) {\r |
| 118 | \r |
| 119 | # calculate H(A1) as per spec\r |
| 120 | my $A1_digest = $r ? $user->password : do {\r |
| 121 | $ctx = Digest::MD5->new;\r |
| 122 | $ctx->add( join( ':', $username, $realm, $user->password ) );\r |
| 123 | $ctx->hexdigest;\r |
| 124 | };\r |
| 125 | if ( $nonce->algorithm eq 'MD5-sess' ) {\r |
| 126 | $ctx = Digest::MD5->new;\r |
| 127 | $ctx->add( join( ':', $A1_digest, $res{nonce}, $res{cnonce} ) );\r |
| 128 | $A1_digest = $ctx->hexdigest;\r |
| 129 | }\r |
| 130 | \r |
| 131 | my $rq_digest = Digest::MD5::md5_hex(\r |
| 132 | join( ':',\r |
| 133 | $A1_digest, $res{nonce},\r |
| 134 | $res{qop} ? ( $res{nc}, $res{cnonce}, $res{qop} ) : (),\r |
| 135 | $A2_digest )\r |
| 136 | );\r |
| 137 | \r |
| 138 | $nonce->nonce_count($nonce_count);\r |
| 139 | $c->cache->set( __PACKAGE__ . '::opaque:' . $nonce->opaque,\r |
| 140 | $nonce );\r |
| 141 | \r |
| 142 | return $c->login( $user, $user->password )\r |
| 143 | if $rq_digest eq $res{response};\r |
| 144 | }\r |
| 145 | }\r |
| 146 | \r |
| 147 | return 0;\r |
| 148 | }\r |
| 149 | \r |
| 150 | sub _check_cache {\r |
| 151 | my $c = shift;\r |
| 152 | \r |
| 153 | die "A cache is needed for http digest authentication."\r |
| 154 | unless $c->can('cache');\r |
| 155 | }\r |
| 156 | \r |
| 157 | sub _is_auth_type {\r |
| 158 | my ( $c, $type ) = @_;\r |
| 159 | \r |
| 160 | my $cfgtype = lc( $c->config->{authentication}{http}{type} || 'any' );\r |
| 161 | return 1 if $cfgtype eq 'any' || $cfgtype eq lc $type;\r |
| 162 | return 0;\r |
| 163 | }\r |
| 164 | \r |
| 165 | sub authorization_required {\r |
| 166 | my ( $c, %opts ) = @_;\r |
| 167 | \r |
| 168 | return 1 if $c->_is_auth_type('digest') && $c->authenticate_digest;\r |
| 169 | return 1 if $c->_is_auth_type('basic') && $c->authenticate_basic;\r |
| 170 | \r |
| 171 | $c->authorization_required_response(%opts);\r |
| 172 | \r |
| 173 | die $Catalyst::DETACH;\r |
| 174 | }\r |
| 175 | \r |
| 176 | sub authorization_required_response {\r |
| 177 | my ( $c, %opts ) = @_;\r |
| 178 | \r |
| 179 | $c->res->status(401);\r |
| 180 | \r |
| 181 | my ( $digest, $basic );\r |
| 182 | $digest = $c->build_authorization_required_response( \%opts, 'Digest' )\r |
| 183 | if $c->_is_auth_type('digest');\r |
| 184 | $basic = $c->build_authorization_required_response( \%opts, 'Basic' )\r |
| 185 | if $c->_is_auth_type('basic');\r |
| 186 | \r |
| 187 | die 'Could not build authorization required response. '\r |
| 188 | . 'Did you configure a valid authentication http type: '\r |
| 189 | . 'basic, digest, any'\r |
| 190 | unless $digest || $basic;\r |
| 191 | \r |
| 192 | $c->res->headers->push_header( 'WWW-Authenticate' => $digest )\r |
| 193 | if $digest;\r |
| 194 | $c->res->headers->push_header( 'WWW-Authenticate' => $basic ) if $basic;\r |
| 195 | }\r |
| 196 | \r |
| 197 | sub build_authorization_required_response {\r |
| 198 | my ( $c, $opts, $type ) = @_;\r |
| 199 | my @opts;\r |
| 200 | \r |
| 201 | if ( my $realm = $opts->{realm} ) {\r |
| 202 | push @opts, 'realm=' . String::Escape::qprintable($realm);\r |
| 203 | }\r |
| 204 | \r |
| 205 | if ( my $domain = $opts->{domain} ) {\r |
| 206 | Catalyst::Excpetion->throw("domain must be an array reference")\r |
| 207 | unless ref($domain) && ref($domain) eq "ARRAY";\r |
| 208 | \r |
| 209 | my @uris =\r |
| 210 | $c->config->{authentication}{http}{use_uri_for}\r |
| 211 | ? ( map { $c->uri_for($_) } @$domain )\r |
| 212 | : ( map { URI::Escape::uri_escape($_) } @$domain );\r |
| 213 | \r |
| 214 | push @opts, qq{domain="@uris"};\r |
| 215 | }\r |
| 216 | \r |
| 217 | if ( $type eq 'Digest' ) {\r |
| 218 | my $package = __PACKAGE__ . '::Nonce';\r |
| 219 | my $nonce = $package->new;\r |
| 220 | $nonce->algorithm( $c->config->{authentication}{http}{algorithm}\r |
| 221 | || $nonce->algorithm );\r |
| 222 | \r |
| 223 | push @opts, 'qop="' . $nonce->qop . '"';\r |
| 224 | push @opts, 'nonce="' . $nonce->nonce . '"';\r |
| 225 | push @opts, 'opaque="' . $nonce->opaque . '"';\r |
| 226 | push @opts, 'algorithm="' . $nonce->algorithm . '"';\r |
| 227 | \r |
| 228 | $c->_check_cache;\r |
| 229 | $c->cache->set( __PACKAGE__ . '::opaque:' . $nonce->opaque, $nonce );\r |
| 230 | }\r |
| 231 | \r |
| 232 | return "$type " . join( ', ', @opts );\r |
| 233 | }\r |
| 234 | \r |
| 235 | package Catalyst::Plugin::Authentication::Credential::HTTP::Nonce;\r |
| 236 | \r |
| 237 | use strict;\r |
| 238 | use base qw[ Class::Accessor::Fast ];\r |
| 239 | use Data::UUID ();\r |
| 240 | \r |
| 241 | our $VERSION = "0.01";\r |
| 242 | \r |
| 243 | __PACKAGE__->mk_accessors(qw[ nonce nonce_count qop opaque algorithm ]);\r |
| 244 | \r |
| 245 | sub new {\r |
| 246 | my $class = shift;\r |
| 247 | my $self = $class->SUPER::new(@_);\r |
| 248 | \r |
| 249 | $self->nonce( Data::UUID->new->create_b64 );\r |
| 250 | $self->opaque( Data::UUID->new->create_b64 );\r |
| 251 | $self->qop('auth,auth-int');\r |
| 252 | $self->nonce_count('0x0');\r |
| 253 | $self->algorithm('MD5');\r |
| 254 | \r |
| 255 | return $self;\r |
| 256 | }\r |
| 257 | \r |
| 258 | 1;\r |
| 259 | \r |
| 260 | __END__\r |
| 261 | \r |
| 262 | =pod\r |
| 263 | \r |
| 264 | =head1 NAME\r |
| 265 | \r |
| 266 | Catalyst::Plugin::Authentication::Credential::HTTP - HTTP Basic authentication\r |
| 267 | for Catlayst.\r |
| 268 | \r |
| 269 | =head1 SYNOPSIS\r |
| 270 | \r |
| 271 | use Catalyst qw/\r |
| 272 | Authentication\r |
| 273 | Authentication::Store::Moose\r |
| 274 | Authentication::Credential::HTTP\r |
| 275 | /;\r |
| 276 | \r |
| 277 | sub foo : Local {\r |
| 278 | my ( $self, $c ) = @_;\r |
| 279 | \r |
| 280 | $c->authorization_required( realm => "foo" ); # named after the status code ;-)\r |
| 281 | \r |
| 282 | # either user gets authenticated or 401 is sent\r |
| 283 | \r |
| 284 | do_stuff();\r |
| 285 | }\r |
| 286 | \r |
| 287 | # with ACL plugin\r |
| 288 | __PACKAGE__->deny_access_unless("/path", sub { $_[0]->authenticate_http });\r |
| 289 | \r |
| 290 | sub end : Private {\r |
| 291 | my ( $self, $c ) = @_;\r |
| 292 | \r |
| 293 | $c->authorization_required_response( realm => "foo" );\r |
| 294 | $c->error(0);\r |
| 295 | }\r |
| 296 | \r |
| 297 | =head1 DESCRIPTION\r |
| 298 | \r |
| 299 | This moduule lets you use HTTP authentication with\r |
| 300 | L<Catalyst::Plugin::Authentication>.\r |
| 301 | \r |
| 302 | Currently this module only supports the Basic scheme, but upon request Digest\r |
| 303 | will also be added. Patches welcome!\r |
| 304 | \r |
| 305 | =head1 METHODS\r |
| 306 | \r |
| 307 | =over 4\r |
| 308 | \r |
| 309 | =item authorization_required\r |
| 310 | \r |
| 311 | Tries to C<authenticate_http>, and if that fails calls\r |
| 312 | C<authorization_required_response> and detaches the current action call stack.\r |
| 313 | \r |
| 314 | =item authenticate_http\r |
| 315 | \r |
| 316 | Looks inside C<< $c->request->headers >> and processes the basic (badly named)\r |
| 317 | authorization header.\r |
| 318 | \r |
| 319 | =item authorization_required_response\r |
| 320 | \r |
| 321 | Sets C<< $c->response >> to the correct status code, and adds the correct\r |
| 322 | header to demand authentication data from the user agent.\r |
| 323 | \r |
| 324 | =back\r |
| 325 | \r |
| 326 | =head1 AUTHORS\r |
| 327 | \r |
| 328 | Yuval Kogman, C<nothingmuch@woobling.org>\r |
| 329 | \r |
| 330 | Jess Robinson\r |
| 331 | \r |
| 50888fc8 |
332 | Sascha Kiefer C<esskar@cpan.org>\r |
| 333 | \r |
| 007935b8 |
334 | =head1 COPYRIGHT & LICENSE\r |
| 335 | \r |
| 50888fc8 |
336 | Copyright (c) 2005-2006 the aforementioned authors. All rights\r |
| 007935b8 |
337 | reserved. This program is free software; you can redistribute\r |
| 338 | it and/or modify it under the same terms as Perl itself.\r |
| 339 | \r |
| 340 | =cut\r |
projects / catagits/Catalyst-Authentication-Credential-HTTP.git / blame