Apache-AxKit-Plugin-Session
1 match

 view release on metacpan or  search on metacpan

lib/Apache/AxKit/Plugin/Session.pm  view on Meta::CPAN 

        # set error message cookie if error message exists
        $self->send_cookie(name=>'Reason', value=>$error_message);
        $r->pnotes('COOKIES')->{$auth_type.'_'.$auth_name.'Reason'} = $error_message;
    }
}
# ____ End of save_reason ____



#==================
sub orig_get_reason($) {
#------------------
    my ($self) = @_;
    $self->debug(3,"======= orig_get_reason(".join(',',@_).")");
    my $r = Apache->request();
    my $auth_name = $r->auth_name || 'AxKitSession';
    my $auth_type = $r->auth_type || __PACKAGE__;

    parse_input();
    return $r->pnotes('COOKIES')->{$auth_type.'_'.$auth_name.'Reason'};
}

lib/Apache/AxKit/Plugin/Session.pm  view on Meta::CPAN 

    $self->debug(3,"======= external_redirect(".join(',',@_).")");
    my $r = Apache->request();
    $r->header_out('Location' => $uri);
    return $self->fixup_redirect($r);
}
# ____ End of external_redirect ____



#====================
sub send_cookie($@) {
#--------------------
    my ($self, %settings) = @_;
    $self->debug(3,"======= send_cookie(".join(',',@_).")");
    my $r = Apache->request();
    my $auth_name = $r->auth_name || 'AxKitSession';
    my $auth_type = $r->auth_type || __PACKAGE__;

    return if $r->dir_config($auth_name.'NoCookie');

    $settings{name} = "${auth_type}_$auth_name".($settings{name}||'');

lib/Apache/AxKit/Plugin/Session.pm  view on Meta::CPAN 

    $self->save_reason($error_message) if ($r->is_main());

    return $self->login_form;
}
# ____ End of authenticate ____


# override this one to retrieve permissions from somewhere else.
# you still need to add a dummy 'require something' to httpd.conf
#========================
sub get_permissions($$) {
#------------------------
    my ($self, $r) = @_;
    my $reqs = $r->requires || return ();
    return map { [ split /\s+/, $_->{requirement}, 2 ] } @$reqs;
}
# ____ End of get_permissions ____


# handler for 'require user' directives
#=============
sub user($$) {
#-------------
    my ($self, $r, $args) = @_;
    $self->debug(3,"======= user(".join(',',@_).")");
    my $user = $r->connection->user;
    return OK if grep { $user eq $_ } split /\s+/, $args;
    return FORBIDDEN;
}
# ____ End of user ____

# Apache auto-configuration
#================================
sub initialize_url_sessions($@) {
#--------------------------------
    my ($self, $redirect_location) = @_;
    $redirect_location ||= '/redirect';

    # configure stuff
    push @Apache::ReadConfig::PerlTransHandler, $self.'->translate_session_uri';

    $Apache::ReadConfig::Location{$redirect_location} = {
        'SetHandler' => 'perl-script',
        'PerlHandler' => $self.'->fixup_redirect',

lib/Apache/AxKit/Plugin/Session.pm  view on Meta::CPAN 

    $rc = $self->authorize($r,$r->requires||[{requirement => 'valid-user'}]);
    return OK if $rc == DECLINED;
    return $rc;
}


# this part does the real work and won't be very useful for
# customization/subclassing.
# You may consider skipping to the 'require' handlers below.

sub makeVariableName($) { my $x = shift; $x =~ s/[^a-zA-Z0-9]/_/g; $x; }

sub save_reason($;$) {
    my ($self, $error_message) = @_;
    $self->debug(3,"--------- save_reason(".join(',',@_).")");
    my $session = Apache->request()->pnotes('SESSION') || return $self->orig_save_reason($error_message);

    if (!$error_message) {
        # delete error message
        delete $$session{'auth_reason'};
        delete $$session{'auth_location'};
    } else {
        # set error message
        $$session{'auth_reason'} = $error_message;
        my $r = Apache->request();
        $$session{'auth_location'} = $r->uri;
        $$session{'auth_location'} .= '?'.$r->args if ($r->args);
    }
}

sub get_reason($) {
    my ($self) = @_;
    $self->debug(3,"--------- get_reason(".join(',',@_).")");
    my $session = Apache->request()->pnotes('SESSION') || return $self->orig_get_reason();

    $$session{'auth_reason'};
}

sub get_location($) {
    my ($self) = @_;
    $self->debug(3,"--------- get_location(".join(',',@_).")");
    my $session = Apache->request()->pnotes('SESSION') || return undef;

    $$session{'auth_location'};
}

sub save_params ($$) {
    my ($self, $uri) = @_;
    $self->debug(3,"--------- save_params(".join(',',@_).")");

lib/Apache/AxKit/Plugin/Session.pm  view on Meta::CPAN 

}


sub _cleanup_session ($$) {
    my ($self, $session) = @_;
    $self->debug(3,"--------- _cleanup_session(".join(',',@_).")");
    untie %{$session};
    undef %{$session};
}

sub _get_session_from_store($$;$) {
    my ($self, $r, $session_id) = @_;
    $self->debug(3,"--------- _get_session_from_store(".join(',',@_).")");
    my $auth_name = $r->auth_name || 'AxKitSession';
    my @now = localtime;
    my $session = {};
    my $dir = $r->dir_config($auth_name.'Dir') || '/tmp/sessions';
    my $absdir = $dir;
    $absdir = $r->document_root.'/'.$dir if substr($dir,0,1) ne '/';
    my $args = {
            Directory => $absdir,

lib/Apache/AxKit/Plugin/Session.pm  view on Meta::CPAN 

            $r->dir_config->get($auth_name.'ManagerArgs'),
    };
    eval {
        eval "require ".($r->dir_config($auth_name.'Manager')||'Apache::Session::File') or die $@;
        tie %{$session}, $r->dir_config($auth_name.'Manager')||'Apache::Session::File', $session_id, $args;
    };
    die "Session creation failed. Depending on which session module you use, make sure that directories $absdir, $absdir/locks or $absdir/counters, or database $dir exist and are writable. The error message was: $@" if $@ && !defined $session_id;
    return $session;
}

sub _get_session($$;$) {
    my ($self, $r, $session_id) = @_;
    my $auth_name = $r->auth_name || 'AxKitSession';
    $self->debug(3,"--------- _get_session(".join(',',@_).")");
    my $dir = $r->dir_config($auth_name.'Dir') || '/tmp/sessions';
    my $expire = ($r->dir_config($auth_name.'Expire') || 30) / 5 + 1; #/
    my $check = $r->dir_config($auth_name.'IPCheck');
    my $remote = ($check == 1?($r->header_in('X-Forwarded-For') || $r->connection->remote_ip):
        $check == 2?($r->connection->remote_ip =~ m/(.*)\./):
        $check == 3?($r->connection->remote_ip):
        '');

lib/Apache/AxKit/Plugin/Session.pm  view on Meta::CPAN 

	}
    }
    $r->pnotes('GLOBAL',$globals);

    return $session;
}

# this is a NO-OP! Don't use this one (or ->login) directly,
# unless you have verified the credentials yourself or don't
# want user logins
sub authen_cred($$\@) {
    my ($self, $r, @credentials) = @_;
    $self->debug(3,"--------- authen_cred(".join(',',@_).")");
    my ($session, $err) = $self->_get_session($r);
    return (undef, $err) if $err;
    $$session{'auth_access_user'} = $credentials[0] if defined $credentials[0];
    $r->pnotes('SESSION',$session);
    return $$session{'_session_id'};
}

sub authen_ses_key($$$) {
    my ($self, $r, $session_id) = @_;
    $self->debug(3,"--------- authen_ses_key(".join(',',@_).")");
    my ($session, $err) = $self->_get_session($r, $session_id);
    return (undef, $err) if $err;
    return ($session_id eq $$session{'_session_id'})?$$session{'auth_access_user'}:undef;
}

sub logout($$) {
    my ($self) = shift;
    my ($r) = @_;
    $self->debug(3,"--------- logout(".join(',',$self,@_).")");
    my $session = $r->pnotes('SESSION');
    eval {
	%$session = ('_session_id' => $$session{'_session_id'});
        my $obj = tied(%$session);
	untie(%$session);
	$obj->delete;
    };
    $self->debug(5,'session delete failed: '.$@) if $@;
    return $self->orig_logout(@_);
}

# 'require' handlers

sub subrequest($$) {
    my ($self, $r) = @_;
    $self->debug(3,"--------- subrequest(".join(',',@_).")");
    return ($r->is_initial_req?FORBIDDEN:OK);
}

sub group($$) {
    my ($self, $r, $args) = @_;
    $self->debug(3,"--------- group(".join(',',@_).")");
    my $session = $r->pnotes('SESSION');

    my $groups = $$session{'auth_access_group'};
    $self->debug(10,"Groups: $groups");
    $groups = { $groups => undef } if !ref($groups);
    $groups = {} if (!$groups || ref($groups) ne 'HASH');
    foreach (split(/\s+/,$args)) {
        return OK if exists $$groups{$_};
    }
    return FORBIDDEN;
}

sub level($$) {
    my ($self, $r, $args) = @_;
    $self->debug(3,"--------- level(".join(',',@_).")");
    my $session = $r->pnotes('SESSION');

    if (exists $$session{'auth_access_level'}) {
        return OK if ($$session{'auth_user_level'} >= $args);
    }
    return FORBIDDEN;
}

sub combined($$) {
    my ($self, $r, $args) = @_;
    $self->debug(3,"--------- combined(".join(',',@_).")");
    my ($requirement, $arg);
    while ($args =~ m/\s*(.*?)\s+("(?:.*?(?:\\\\|\\"))*.*?"(?:\s|$)|[^" \t\r\n].*?(?:\s|$))/g) {
        ($requirement, $arg) = ($1, $2);
        $arg =~ s/^"|"\s?$//g;
        $arg =~ s/\\([\\"])/$1/g;
        $requirement = makeVariableName($requirement);
        no strict 'refs';
        my $rc = $self->$requirement($r,$arg);
        $self->debug(4,"-------- $requirement returned $rc");
        return FORBIDDEN if $rc != OK;
    }
    return OK;
}

sub alternate($$) {
    my ($self, $r, $args) = @_;
    $self->debug(3,"--------- alternate(".join(',',@_).")");
    my ($requirement, $arg);
    while ($args =~ m/\s*(.*?)\s+("(?:.*?(?:\\\\|\\"))*.*?"(?:\s|$)|[^" \t\r\n].*?(?:\s|$))/g) {
        ($requirement, $arg) = ($1, $2);
        $arg =~ s/^"|"\s?$//g;
        $arg =~ s/\\([\\"])/$1/g;
        $requirement = makeVariableName($requirement);
        no strict 'refs';
        my $rc = $self->$requirement($r,$arg);
        $self->debug(4,"-------- $requirement returned $rc");
        return OK if $rc == OK;
    }
    return FORBIDDEN;
}

sub not($$) {
    my ($self, $r, $args) = @_;
    $self->debug(3,"--------- not(".join(',',@_).")");
    my ($requirement, $arg) = split /\s+/, $args, 2;
    $requirement = makeVariableName($requirement);
    no strict 'refs';
    my $rc = $self->$requirement($r,$arg);
    $self->debug(4,"-------- $requirement returned $rc");
    return FORBIDDEN if $rc == OK;
    return OK;
}

lib/Apache/AxKit/Plugin/Session.pm  view on Meta::CPAN 


*pack_requirement_alternate = \&pack_requirement_combined;

sub pack_requirement_not {
    my ($self, $args) = @_;
    no strict 'refs';
    my $sub = "pack_requirement_".makeVariableName($$args[1][0]);
    return $$args[1][0].' '.$self->$sub($$args[1]);
}

sub set_permissions($$@) {
    my ($self, $r, @perms) = @_;
    @perms = map { 'require '.$_->[0].' '.$_->[1]."\n" } @perms;
    if ($r->uri =~ m/#[^\/]*$/) {
        push @perms, "SetHandler perl-script\n";
        push @perms, "PerlHandler \"sub { &Apache::Constants::NOT_FOUND; }\"\n";
    }
    # Enabling write access to httpd config files is dangerous, so you will have to find
    # out yourself what to do. Do this only if you absolutely know what you are doing.
    my $configfile = $r->dir_config(($r->auth_name || 'AxKitSession').'AuthFile') || die 'read the fine manual.';
    local (*IN, *OUT);

lib/Apache/AxKit/Plugin/Session.pm  view on Meta::CPAN 

        print OUT '<Files '.$file.">\n";
        print OUT @perms;
        print OUT "</Files>\n";
        print OUT "# end of autogenerated fragment\n";
        close(OUT);
    }
}

# interfaces for the taglib

sub get_permission_set($$) {
    my ($self, $r) = @_;
    my @rc = ();
    foreach my $req ($self->get_permissions($r)) {
        $$req[1] = '' unless defined $$req[1];
        my $sub = 'unpack_requirement_'.makeVariableName($$req[0]);
        push @rc, $self->$sub(@$req);
    }
    return @rc;
}

sub set_permission_set($$@) {
    my ($self, $r, @reqs) = @_;
    my @rc;
    my $req;
    foreach my $req (@reqs) {
        my $sub = "pack_requirement_".makeVariableName($$req[0]);
        push @rc, [ $$req[0], $self->$sub($req) ];
    }
    $self->set_permissions($r,@rc);
}



( run in 0.592 second using v1.01-cache-2.11-cpan-65fba6d93b7 )