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
  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
  37     die $Catalyst::DETACH;
  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
 134 =head1 AUTHORS
 135
 136 Yuval Kogman, C<nothingmuch@woobling.org>
 137
 138 Jess Robinson
 139
 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
 147