view release on metacpan or  search on metacpan

lib/Authen/Simple/WebForm.pm  view on Meta::CPAN

=cut


sub check
{
    my ($self, $username, $password) = @_;

    # prepend prefix. If none set, or blank, this will just be $username
    my $full_username = join('', ($self->username_prefix, $username));

    # prep any additional headers we might need
    my @headers;
    my $extra_headers = $self->extra_headers;
    if (ref($extra_headers) eq 'ARRAY' && @$extra_headers)
    {
        if ((@$extra_headers % 2) == 0)
        {
            push(@headers, @$extra_headers);
        } else {
            $self->log->error("Invalid extra_headers option.") if $self->log;
            return 0;
        }
    }

    # determine request method
    my $initial_req_method = uc($self->initial_request_method || 'GET');
    unless ($initial_req_method =~ /^(GET|POST)$/i) {
        $self->log->error("Invalid initial_request_method.") if $self->log;
        return 0;
    }
    my $login_req_method = uc($self->login_request_method || 'GET');
    unless ($login_req_method =~ /^(GET|POST)$/i) {
        $self->log->error("Invalid login_request_method.") if $self->log;
        return 0;
    }

    # initialize the user agent
    my $ua = LWP::UserAgent->new() or die "Unable to init LWP::UserAgent : $@";
    # keep in memory cookie jar
    $ua->cookie_jar({});
    $ua->agent($self->lwp_user_agent) if $self->lwp_user_agent;
    $ua->timeout( $self->lwp_timeout ) if $self->lwp_timeout;
    $ua->conn_cache(LWP::ConnCache->new()) if $self->lwp_use_conn_cache;

    my $req_redirectable = $self->lwp_requests_redirectable;
    if (ref($req_redirectable) eq 'ARRAY' && @$req_redirectable) {
        push @{$ua->requests_redirectable}, @$req_redirectable;
    }

    # get an inital page?
    if ($self->initial_url)
    {
        my $res = ($initial_req_method eq 'GET') ? $ua->get($self->initial_url, @headers):
                                                   $ua->post($self->initial_url, @headers);
        if ($self->trace)
        {
            print STDERR ("-"x80)."\n";
            print STDERR "TRACE: initial response, response code [".$res->code."]\n";
            print STDERR "TRACE: initial response, cookies [".$ua->cookie_jar->as_string()."]\n";
            print STDERR $res->decoded_content;
            print STDERR "\n\n\n";
            print STDERR ("-"x80)."\n";
        }
        # make sure status code is ok?
        if ($self->check_initial_status_code)
        {
            unless ($res->is_success)
            {
                $self->log->error("Can't get ".$self->initial_url." -- ".$res->status_line)
                    if $self->log;
                return 0;
            }
        }

        # do we care to check the content?
        if ($self->initial_expect)
        {
            my $expect = $self->initial_expect;
            unless (ref($expect) eq 'Regexp') {
                $expect = qr/\Q$expect\E/;
            }
            unless ($res->decoded_content =~ /$expect/)
            {
                $self->log->error("Initial url didn't return expected results.") if $self->log;
                return 0;
            }
        }

        # do we care to check for a cookie
        if ($self->initial_expect_cookie)
        {
            my $expect = $self->initial_expect_cookie;

            my $found = 0;
            my $search; # cookie_jar search callback

            if (ref($expect) eq 'Regexp')
            {
                $search = sub { $found++ if $_[1] =~ /$expect/ && length($_[2]); };
            } else {
                $search = sub { $found++ if $_[1] eq $expect && length($_[2]); };
            }

            # search the cookie jar
            $ua->cookie_jar->scan($search);
            unless ($found)
            {
                $self->log->debug("Failed to authenticate user '$full_username'. Reason: Initial Cookie $expect was not found.")
                    if $self->log;
                return 0;
            }
        }
    }


    # build data to post
    my @data = (
        $self->username_field   => $full_username,
        $self->password_field   => $password
        );
    # add an extra fields to submit
    my $extra_fields = $self->extra_fields;
    if (ref($extra_fields) eq 'ARRAY' && @$extra_fields)
    {
        if ((@$extra_fields % 2) == 0)
        {
            push(@data, @$extra_fields);
        } else {
            $self->log->error("Invalid extra_fields option.") if $self->log;
            return 0;
        }
    }

    # attempt to login
    my $res;
    if ($login_req_method eq 'GET')
    {
        my $url = URI->new($self->login_url);
        unless ($url) {
            $self->log->error("Unable to parse login_url. $@") if $self->log;
            return 0;
        }
        $url->query_form( \@data );
        $res = $ua->get($url, @headers);
    } else { # POST
        $res = $ua->post($self->login_url, \@data, @headers);
    }
    if ($self->trace)
    {
        print STDERR ("-"x80)."\n";
        print STDERR "TRACE: initial response, response code [".$res->code."]\n";
        print STDERR "TRACE: initial response, cookies [".$ua->cookie_jar->as_string()."]\n";
        print STDERR $res->decoded_content;
        print STDERR "\n\n\n";
        print STDERR ("-"x80)."\n";
    }

    # make sure status code is ok?
    if ($self->check_login_status_code)
    {
        unless ($res->is_success)
        {
            if ($res->is_redirect)
            {
                $self->log->debug("Failed to authenticate user '$full_username'. Reason: Login page returned redirect status code '".$res->code."'. You may wish to enable lwp_requests_redirectable -- ".$res->status_line)
                    if $self->log;
            } else {
                $self->log->debug("Failed to authenticate user '$full_username'. Reason: Login page returned invalid status code '".$res->code."' -- ".$res->status_line)
                    if $self->log;
            }
            return 0;
        }
    }

    # do we care to check the content?
    if ($self->login_expect)
    {
        my $expect = $self->login_expect;
        unless (ref($expect) eq 'Regexp') {
            $expect = qr/\Q$expect\E/;
        }
        unless ($res->decoded_content =~ /$expect/)
        {
            $self->log->debug("Failed to authenticate user '$full_username'. Reason: Login page response did not match expected value.")
                if $self->log;
            return 0;
        }
    }

    # do we care to check for a cookie
    if ($self->login_expect_cookie)
    {
        my $expect = $self->login_expect_cookie;

        my $found = 0;
        my $search; # cookie_jar search callback

        if (ref($expect) eq 'Regexp')
        {
            $search = sub { $found++ if $_[1] =~ /$expect/ && length($_[2]); };
        } else {
            $search = sub { $found++ if $_[1] eq $expect && length($_[2]); };
        }

        # search the cookie jar
        $ua->cookie_jar->scan($search);
        unless ($found)
        {
            $self->log->debug("Failed to authenticate user '$full_username'. Reason: Login Cookie $expect was not found.")
                if $self->log;
            return 0;
        }
    }

    $self->log->debug("Successfully authenticated user '$full_username'.") if $self->log;
    return 1;
}

=head1 TODO

Add lwp_cookie_jar option(s) so that it may use a file.

Add a debug mode. It's often difficult to determine what content is being returned, and what to look for. The debug mode should print each step out to STDERR, and include the relevant response information from the page.

Write tests using HTTP::Daemon as a local webserver. See LWP test t/local/http.t and t/local/chunked.t for example.

=head1 AUTHOR

Joshua I. Miller, C<< <unrtst at cpan.org> >>

=head1 BUGS

Please report any bugs or feature requests to C<bug-authen-simple-webform at rt.cpan.org>, or through
the web interface at L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Authen-Simple-WebForm>.  I will be notified, and then you'll
automatically be notified of progress on your bug as I make changes.




=head1 SUPPORT

You can find documentation for this module with the perldoc command.