File Coverage

blib/lib/Catalyst/Plugin/Authentication/Basic/Remote.pm

Criterion	Covered	Total	%
statement	15	76	19.7
branch	0	34	0.0
condition	0	16	0.0
subroutine	5	9	55.5
pod	4	4	100.0
total	24	139	17.2

package Catalyst::Plugin::Authentication::Basic::Remote;

use strict;
use base qw/Class::Accessor::Fast/;
use NEXT;

use LWP::UserAgent;
use MIME::Base64;

our $VERSION = '0.03';

__PACKAGE__->mk_accessors(qw/_login/);

=head1 NAME

Catalyst::Plugin::Authentication::Basic::Remote - (DEPRECATED) Basic authentication via remote host.

=head1 SYNOPSIS

  use Catalyst;
  MyApp->setup(qw/Authentication::Basic::Remote Session::FastMmap/);

  MyApp->config(
      authentication => {
          auth_url => 'http://example.com/',

	  # Use Template when unauthorized. (option)
	  view_tt  => 'MyApp::V::TT',
	  template => '401.tt',

          # text in Authentication dialog (default="Require Authorization")
          auth_name => 'Require Authorization',
      },
  );

=head1 DEPRECATION NOTICE

This module has been deprecated. The use of a new Authentication style is recommended.

See L<Catalyst::Plugin::Authetnication> for detail.

=head1 DESCRIPTION

Catalyst authentication plugin that use remote host's Basic authentication.

It is only first time that plugin request to remote host for authentication.
After that, user infomation keeps in sessions.

=head1 METHODS

=over 4

=item prepare

=cut

sub prepare {
    my $c = shift;

    $c = $c->NEXT::prepare(@_);

    if ( $c->session->{user} and $c->session->{password} ) {
        $c->log->debug("Auth info found in Session:");
        $c->log->debug("user: ".$c->session->{user});
        $c->log->debug("pass: ".$c->session->{password});

        $c->req->{user}     = $c->session->{user};
        $c->req->{password} = $c->session->{password};
        return $c;
    }

    if ( $c->config->{authentication}->{auth_url} ) {
        if ( $c->req->header('Authorization') and  my ($tokens) = ( $c->req->header('Authorization') =~ /^Basic (.+)$/) ) {
            my ( $username, $password ) = split /:/, decode_base64($tokens);

            $c->log->debug("Authentication via ". $c->config->{authentication}->{auth_url} );
            $c->log->debug("user: $username");
            $c->log->debug("pass: $password");

            my $ua = LWP::UserAgent->new;
            my $req = HTTP::Request->new( HEAD => $c->config->{authentication}->{auth_url} );
            $req->header( 'Authorization' => $c->req->header('Authorization') );

            my $res = $ua->request($req);

            if ( $res->code ne '401' ) {
                $c->log->debug("Authorization successful.");
                $c->req->{user}         = $username;
                $c->session->{user}     = $username;
                $c->req->{password}     = $password;
                $c->session->{password} = $password;
                $c->_login(1);
            } else {
                $c->log->debug("Authorization failed.");
                $c->log->debug("Remote status line: " . $res->status_line);
            }
        }

        unless ( $c->req->{user} ) {
            $c->log->debug("return 401 Unauthorized.");
            $c->res->status(401);
            $c->res->header( 'WWW-Authenticate' =>
                  qq!Basic realm="@{[ $c->config->{authentication}->{auth_name} || 'Require Authorization' ]}"!
            );
        }
    }

    return $c;
}

=item dispatch

=cut

sub dispatch {
    my $c = shift;

    if ( $c->config->{authentication}->{template} ) {
        my $view = $c->config->{authentication}->{view_tt} || $c->config->{name};

        if ($view and $c->res->status eq '401') {
            $c->stash->{template} = $c->config->{authentication}->{template};
            $c->forward($view);
            return;
        }
    }

    return $c->NEXT::dispatch(@_);
}

=item login

=cut

sub login {
    my $c = shift;

    return unless $c->session->{user};
    return if ($c->_login);

    if ($c->config->{authentication}->{auth_url}) {
        $c->log->debug("Login method called");

        delete $c->session->{user} if $c->session->{user};
        delete $c->session->{password} if $c->session->{password};

        $c->res->status(401);
        $c->res->header( 'WWW-Authenticate' =>
              qq!Basic realm="@{[ $c->config->{authentication}->{auth_name} || 'Require Authorization' ]}"!
        );

        return 1;
    }

    return;
}

=item logout

=cut

sub logout {
    my $c = shift;

    return unless $c->config->{authentication}->{auth_url};

    delete $c->session->{user}     if $c->session->{user};
    delete $c->session->{password} if $c->session->{password};

    delete $c->req->{user}     if $c->req->{user};
    delete $c->req->{password} if $c->req->{password};

    1;
}

=back

=head1 SEE ALSO

L<Catalyst>

=head1 AUTHOR

Daisuke Murase, E<lt>[e-mail]<gt>

=head1 COPYRIGHT AND LICENSE

Copyright (C) 2005 by Daisuke Murase

This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.


=cut

1;