view release on metacpan or  search on metacpan

lib/Apache2/Controller/Auth/OpenID.pm  view on Meta::CPAN

package Apache2::Controller::Auth::OpenID;

=head1 NAME

Apache2::Controller::Auth::OpenID - OpenID for Apache2::Controller

=head1 VERSION

Version 1.001.001 - THIS MODULE DISABLED, DOES NOT WORK.

=cut

use version;
our $VERSION = version->new('1.001.001');

=head1 SYNOPSIS

 PerlLoadModule Apache2::Controller::Directives

 <Location /myapp>
     SetHandler modperl

     # uri to your login controller:
     A2C_Auth_OpenID_Login          login

     # uri to your logout controller:
     A2C_Auth_OpenID_Logout         logout

     # uri to your registration controller:
     A2C_Auth_OpenID_Register       register
     # you might want to put this outside the protected area, 
     # i.e. /other/register - you can use leading '/' for absolute uri

     # idle timeout in seconds, +2m, +3h, +4D, +6M, +7Y, or 'no timeout'
     # default is 1 hour.  a month is actually 30 days, a year 365.
     A2C_Auth_OpenID_Timeout        +1h

     # name of the openid table in database:
     A2C_Auth_OpenID_Table          openid
     
     # key of the username field in table:
     A2C_Auth_OpenID_User_Field     uname

     # key of the openid url field in table:
     A2C_Auth_OpenID_URL_Field      openid_url

     # if you use multiple DBI handles, name the one in pnotes
     # that you should use for reading the openid table:
     A2C_Auth_OpenID_DBI_Name       dbh

     # by default trust_root is the result of $r->construct_url(''),
     # i.e. the top of the site (see Apache::URI)
     A2C_Auth_OpenID_Trust_Root     http://myapp.tld/somewhere

     # set a random string used as salt with time() to sha secret
     A2C_Auth_OpenID_Consumer_Secret

     # but that random salt will be reset if you restart server,
     # which may cause current logins to die, so you can specify
     # your own constant salt of arbitrary length
     A2C_Auth_OpenID_Consumer_Secret    abcdefg1234567

     # if you do not want to preserve GET/POST params 
     # across redirects to the OpenID server, use this flag:
     # A2C_Auth_OpenID_NoPreserveParams

     # if you do not overload get_uname() (see below), then
     # PerlHeaderParserHandlers must be invoked in order
     # to set up the dbi handle before checking auth
     # with the default method.  In this example,
     # MyApp::DBI::Connector is an Apache2::Controller::DBI::Connector
     # and MyApp::Session is an Apache2::Controller::Session::Cookie...
     # see those modules for more info.

     PerlInitHandler            MyApp::Dispatch 
     PerlHeaderParserHandler    MyApp::DBI::Connector
     PerlHeaderParserHandler    MyApp::Session
     PerlHeaderParserHandler    Apache2::Controller::Auth::OpenID
 </Location>

=head1 DESCRIPTION

Implements an authentication mechanism for L<Apache2::Controller>
that uses OpenID.  

This is NOT an AuthenPerlHandler.  This is an implementation
of a simple cookie-based mechanism that shows the browser
a login page, where your controller should present and process an
HTML form for logging in.  

If you want an authentication handler that uses browser-based auth
(the pop-up dialog implemented by HTTP auth protocol) use 
L<Apache::Authen::OpenID>, which is not a part of Apache2::Controller
but should work for you anyway.

Natively this depends on L<Apache2::Controller::Session::Cookie>

lib/Apache2/Controller/Auth/OpenID.pm  view on Meta::CPAN

Correct trailing double /'s etc. in the openid url.

=cut

sub openid_url_normalize {
    my ($self, $openid_url) = @_;
    my $orig_url = $openid_url;
    my ($scheme) = $openid_url =~ m{ \A (\w+) : // }mxs;
    $scheme ||= 'http';
    $scheme = lc $scheme;
    $openid_url = URI->new( $openid_url, $scheme )->canonical->as_string
        || a2cx "Could not normalize openid_url '$orig_url'";
    $openid_url =~ s{ /+ \z }{}mxs;
    return $openid_url;
}

=head2 process

Make sure the config directives are assigned or use defaults.

If uri = login uri, process accordingly.

If uri = logout uri, delete session hash login flags and return OK.

=cut

sub _save_errs_in_sess {
    my ($self, $openid_csr) = @_;
    my $sess = $self->pnotes->{a2c}{session};
    my $errcode = $openid_csr->errcode 
        || $openid_csr->{last_errcode} || '[ no error code ]';
    my $errtext = $openid_csr->err 
        || $openid_csr->{last_errtext} || '[ no error text ]';
    $sess->{a2c}{openid}{errtext} = $errtext;
    $sess->{a2c}{openid}{errcode} = $errcode;
    return ($errtext, $errcode);
}

my ($openid_csr, $consumer_secret_string);
my %params_hash;

sub process {
    my ($self) = @_;
    my $uri = $self->uri();

  # my $pnotes = $self->pnotes;
  # DEBUG sub { "Before checking session, pnotes is:\n".Dump($pnotes) };

    # make sure a session object is set up already
    my $sess = $self->pnotes->{a2c}{session}
        || a2cx "No session object configured for handler";

    DEBUG sub { "Entering, processing uri '$uri'.\nsession is:\n".Dump($sess) };

    my $directives = $self->get_directives();
    my %conf = (
        $self->default_directives(),
        ( map {(lc($_) => $directives->{"A2C_Auth_OpenID_$_"})} 
          grep exists $directives->{"A2C_Auth_OpenID_$_"}, qw( 
            Login       Logout      Register    Timeout
            Table       User_Field  URL_Field   DBI_Name    
            Trust_Root  LWP_Class   Allow_Login Consumer_Secret
            NoPreserveParams
        ) ),
    );

    # make a lookup verification map of the internal uris
    $conf{is_internal} = { map {($conf{$_} => 1)} qw( login logout register ) };

    # slap in anything specified in the sub-hash of LWP class options
    my $lwp_opts_directive = $directives->{A2C_Auth_OpenID_LWP_Opts} || { };
    my @lwp_opt_keys = keys %{$lwp_opts_directive};
    DEBUG sub { "Trying to slice in lwp_opts: ".Dump($lwp_opts_directive) };
    @{$conf{lwp_opts}}{@lwp_opt_keys} = @{$lwp_opts_directive}{@lwp_opt_keys}
        if scalar @lwp_opt_keys;

    $self->{conf} = \%conf;

    DEBUG sub { "conf:\n".Dump(\%conf) };
    DEBUG sub { "session:\n".Dump($self->pnotes->{a2c}{session}) };

    # if we're on the register page, allow it through
    return Apache2::Const::OK if $uri eq $self->qualify_uri($conf{register});

    # logout and return if we're processing the logout uri
    if ($uri eq $self->qualify_uri($conf{logout})) {
        DEBUG "requested logout page $conf{logout}, returning logout()";
        return $self->logout();
    }

    # return OK if their session is logged in and timestamp is current
    if ($self->is_logged_in) {
        DEBUG "user is logged in, returning OK";
        return Apache2::Const::OK;
    }
    else {
        DEBUG "user is NOT logged in, continuing auth";
    }

    # consumer object creation is very slow, so we cache in package space:
    if (!defined $openid_csr) {
        my $cache = $self->can('cache') ? $self->cache() : undef;
        eval "use $conf{lwp_class}";
        a2cx "Could not load A2C_Auth_OpenID_LWP_Class ($conf{lwp_class}): "
            ."$EVAL_ERROR" if $EVAL_ERROR;

        # stash string in package to avoid closure circle on this req's %conf.
        # we provide some hardcoded junk if they didn't use the directive 
        # to specify or generate some.
        $consumer_secret_string = $conf{consumer_secret};
        DEBUG "Setting up CSR with secret string '$consumer_secret_string'";

        $openid_csr = Net::OpenID::Consumer->new(
            ua              => $conf{lwp_class}->new(%{ $conf{lwp_opts} }),
            cache           => $cache,
            consumer_secret => sub {
                my ($time) = @_;
                return sha224_base64("$time-$consumer_secret_string");
            },
            debug           => \&DEBUG,