view release on metacpan or  search on metacpan

lib/Apache2/AuthAny/RequestConfig.pm  view on Meta::CPAN

        }
        # If we make it through authen and authz, update the last access
        $r->set_handlers(PerlFixupHandler => 'Apache2::AuthAny::FixupHandler');
        set_env($r, $pid, $cf);
    }
    return Apache2::Const::DECLINED;
}

sub set_env {
    my ($r, $pid, $cf) = @_;

    my ($authId, $authProvider);
    unless ($pid->{state} eq 'logged_out') {
        ($authId, $authProvider) = ($pid->{authId}, $pid->{authProvider});
    }

    if ($pid->{scripted}) {
        $r->subprocess_env('AA_SCRIPTED' => 1);
    }

    if ($authId && $pid->{SID}) {
        # login occurred in this browser session
        $r->subprocess_env('AA_SESSION' => 1);
    }

    # resolve identity if possible
    my $identifiedUser = $aaDB->getUserByAuthIdAndProvider($authId, $authProvider) || {};
    my $user;
    if ($identifiedUser->{username}) {
        $user = $identifiedUser->{username};

        my $roles = $aaDB->getUserRoles($identifiedUser->{UID});
        $r->subprocess_env(AA_ROLES => join(",", @$roles));

        # role choices are never used in Require directives
        my %user_role_choice;
        my $role_choices = $aaDB->getUserRoleChoices($identifiedUser->{UID});
        foreach my $role (@$role_choices) {
            $user_role_choice{$role} = 1;
        }
        my @roles_active = grep { $user_role_choice{$_} } @$roles;
        $r->subprocess_env(AA_ROLES_ACTIVE => join(",", @roles_active));

        my $identities = $aaDB->getUserIdentities($identifiedUser->{UID});
        my @idents = map {"$_->{authId}|$_->{authProvider}"} @$identities;
        $r->subprocess_env(AA_IDENTITIES => join(",", @idents));

        foreach my $field (keys %$identifiedUser) {
            $r->subprocess_env("AA_IDENT_$field" => $identifiedUser->{$field});
        }
    } elsif ($authId && $authProvider) {
        $user = "$authId|$authProvider";
    }

    $r->user($user) if $user;
    $r->subprocess_env(REMOTE_USER => $user);

    $r->subprocess_env(AA_USER => $authId);
    $r->subprocess_env(AA_PROVIDER => $authProvider);

    # Timeout
    my $timeout = 155520000; # defaults to 5 years
    if (defined $identifiedUser->{timeout}) {
        $timeout = $identifiedUser->{timeout};
    } elsif (defined $cf->{AuthAnyTimeout}) {
        $timeout = $cf->{AuthAnyTimeout};
    }

    if ($pid->{state} eq 'authenticated' && time() - $pid->{last} < $timeout) {
        $r->subprocess_env(AA_TIMEOUT => $timeout);
    } elsif ($authId ) {
        $aaDB->statePCookie($pid, 'recognized');
    } else {
        $aaDB->statePCookie($pid, 'logged_out');
    }

    $r->subprocess_env(AA_STATE => $pid->{state});
    # Passing gate for logout convienience
    $r->subprocess_env();
}

sub get_scripted_pid {
    my $r = shift;
    my $cf = shift;
    if ($cf->{AuthAnyBasicAuthUserFile}) {
        unless (open(HTPASSWD, $cf->{AuthAnyBasicAuthUserFile})) {
            my $msg = "Cannot read  '$cf->{AuthAnyBasicAuthUserFile}' $!";
            die $msg;
        }

        my ($http_user, $http_password) = get_user_and_password($r);
        if ($http_user && $http_password) {

            my $stored_passwd;
            while (<HTPASSWD>) {
                chomp;
                my ($username, $crypt_passwd) = split(":", $_, 2);
                if ($username eq $http_user) {
                    if (crypt($http_password, $crypt_passwd) eq $crypt_passwd) {
                        $r->log->info("RequestConfig: From HTTP header: $username");
                        return {PID => 'unused',
                                SID => 'unused',
                                logoutKey => 'unused',
                                state => 'authenticated',
                                scripted => 1,
                                authId => $username,
                                authProvider => 'basic',
                                last => 2298416724, # time in the future
                               };
                    } else {
                        my $msg = "RequestConfig: Basic user found in " .
                          "$cf->{AuthAnyBasicAuthUserFile}, however password is incorrect";
                        $r->log->warn($msg);
                        last;
                    }
                }
            }
        }
    }
}

sub get_user_and_password {
    my $r = shift;
    my $Authorization = $r->headers_in->{Authorization};
    if ($Authorization) {
        my ($type, $hash) = split " ", $Authorization;