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 |
332 | =head1 COPYRIGHT & LICENSE\r |
333 | \r |
334 | Copyright (c) 2005 the aforementioned authors. All rights\r |
335 | reserved. This program is free software; you can redistribute\r |
336 | it and/or modify it under the same terms as Perl itself.\r |
337 | \r |
338 | =cut\r |