Commit | Line | Data |
2022b950 |
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 (); |
d9914dd2 |
11 | use Catalyst (); |
2022b950 |
12 | |
13 | our $VERSION = "0.01"; |
14 | |
15 | sub authenticate_http { |
16 | my $c = shift; |
17 | |
18 | my $headers = $c->req->headers; |
19 | |
20 | if ( my ( $user, $password ) = $headers->authorization_basic ) { |
21 | |
22 | if ( my $store = $c->config->{authentication}{http}{store} ) { |
23 | $user = $store->get_user($user); |
24 | } |
25 | |
26 | return $c->login( $user, $password ); |
27 | } |
28 | } |
29 | |
30 | sub authorization_required { |
31 | my ( $c, %opts ) = @_; |
32 | |
33 | return 1 if $c->authenticate_http; |
34 | |
35 | $c->authorization_required_response( %opts ); |
36 | |
790f9ddb |
37 | die $Catalyst::DETACH; |
2022b950 |
38 | } |
39 | |
40 | sub authorization_required_response { |
41 | my ( $c, %opts ) = @_; |
42 | |
43 | $c->res->status(401); |
44 | |
45 | my @opts; |
46 | |
47 | if ( my $realm = $opts{realm} ) { |
48 | push @opts, sprintf 'realm=%s', String::Escape::qprintable($realm); |
49 | } |
50 | |
51 | if ( my $domain = $opts{domain} ) { |
52 | Catalyst::Excpetion->throw("domain must be an array reference") |
53 | unless ref($domain) && ref($domain) eq "ARRAY"; |
54 | |
55 | my @uris = |
56 | $c->config->{authentication}{http}{use_uri_for} |
57 | ? ( map { $c->uri_for($_) } @$domain ) |
58 | : ( map { URI::Escape::uri_escape($_) } @$domain ); |
59 | |
60 | push @opts, qq{domain="@uris"}; |
61 | } |
62 | |
63 | $c->res->headers->www_authenticate(join " ", "Basic", @opts); |
64 | } |
65 | |
66 | __PACKAGE__; |
67 | |
68 | __END__ |
69 | |
70 | =pod |
71 | |
72 | =head1 NAME |
73 | |
74 | Catalyst::Plugin::Authentication::Credential::HTTP - HTTP Basic authentication |
75 | for Catlayst. |
76 | |
77 | =head1 SYNOPSIS |
78 | |
79 | use Catalyst qw/ |
80 | Authentication |
81 | Authentication::Store::Moose |
82 | Authentication::Credential::HTTP |
83 | /; |
84 | |
85 | sub foo : Local { |
86 | my ( $self, $c ) = @_; |
87 | |
88 | $c->authorization_requried( realm => "foo" ); # named after the status code ;-) |
89 | |
90 | # either user gets authenticated or 401 is sent |
91 | |
92 | do_stuff(); |
93 | } |
94 | |
95 | # with ACL plugin |
96 | __PACKAGE__->deny_access_unless("/path", sub { $_[0]->authenticate_http }); |
97 | |
98 | sub end : Private { |
99 | my ( $self, $c ) = @_; |
100 | |
101 | $c->authorization_required_response( realm => "foo" ); |
102 | $c->error(0); |
103 | } |
104 | |
105 | =head1 DESCRIPTION |
106 | |
107 | This moduule lets you use HTTP authentication with |
108 | L<Catalyst::Plugin::Authentication>. |
109 | |
110 | Currently this module only supports the Basic scheme, but upon request Digest |
111 | will also be added. Patches welcome! |
112 | |
113 | =head1 METHODS |
114 | |
115 | =over 4 |
116 | |
117 | =item authorization_required |
118 | |
119 | Tries to C<authenticate_http>, and if that files calls |
120 | C<authorization_required_response> and detaches the current action call stack. |
121 | |
122 | =item authenticate_http |
123 | |
124 | Looks inside C<< $c->request->headers >> and processes the basic (badly named) |
125 | authorization header. |
126 | |
127 | =item authorization_required_response |
128 | |
129 | Sets C<< $c->response >> to the correct status code, and adds the correct |
130 | header to demand authentication data from the user agent. |
131 | |
132 | =back |
133 | |
ee77d7fa |
134 | =head1 AUTHORS |
135 | |
136 | Yuval Kogman, C<nothingmuch@woobling.org> |
137 | |
138 | Jess Robinson |
2022b950 |
139 | |
ee77d7fa |
140 | =head1 COPYRIGHT & LICENSE |
141 | |
142 | Copyright (c) 2005 the aforementioned authors. All rights |
143 | reserved. This program is free software; you can redistribute |
144 | it and/or modify it under the same terms as Perl itself. |
145 | |
146 | =cut |
2022b950 |
147 | |