File: AuthCookieHandler.pm

package info (click to toggle)
libapache2-authcookie-perl 3.32-1
  • links: PTS, VCS
  • area: main
  • in suites: forky, sid, trixie
  • size: 496 kB
  • sloc: perl: 1,560; sh: 101; makefile: 28
file content (79 lines) | stat: -rw-r--r-- 2,170 bytes parent folder | download | duplicates (5)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
package Sample::Apache::AuthCookieHandler;

use strict;
use utf8;
use base 'Apache::AuthCookie';
use Apache;
use Apache::Constants qw(:common);
use Apache::AuthCookie;
use Apache::Util;
use URI::Escape qw(uri_escape_utf8 uri_unescape);
use Encode;

sub authen_cred ($$\@) {
    my $self = shift;
    my $r = shift;
    my @creds = @_;

    return if $creds[0] eq 'fail'; # simulate bad_credentials

    # This would really authenticate the credentials 
    # and return the session key.
    # Here I'm just using setting the session
    # key to the escaped credentials and delaying authentication.
    return join ':', map { uri_escape_utf8($_) } @creds;
}

sub authen_ses_key ($$$) {
    my ($self, $r, $ses_key) = @_;

    # NOTE: uri_escape_utf8() was used to encode this so we have to decode
    # using UTF-8.  We don't rely on $self->encoding($r) here because if an
    # encoding other than UTF-8 is configured in t/conf/extra.conf.in, then the
    # wrong encoding gets used here.
    my($user, $password) =
        map { decode('UTF-8', uri_unescape($_)) }
        split /:/, $ses_key, 2;

    if ($user eq 'programmer' && $password eq 'Hero') {
        return $user;
    }
    elsif ($user eq 'some-user') {
        return $user;
    }
    elsif ($user eq '0') {
        return $user;
    }
    elsif ($user eq '程序员') { # programmer in chinese, at least according to google translate
        return $user;
    }

    return;
}

sub dwarf {
    my $self = shift;
    my $r = shift;

    my $user = $r->connection->user;
    if ("bashful doc dopey grumpy happy sleepy sneezy programmer"
	=~ /\b$user\b/) {
	# You might be thinking to yourself that there were only 7
	# dwarves, that's because the marketing folks left out
	# the often under appreciated "programmer" because:
	#
	# 10) He didn't hold 8 to 5 hours.
	# 9)  Sometimes forgot to shave several days at a time.
	# 8)  Was always buzzed on caffine.
	# 7)  Wasn't into heavy labor.
	# 6)  Prone to "swearing while he worked."
	# 5)  Wasn't as easily controlled as the other dwarves.
	# 
	# 1)  He posted naked pictures of Snow White to the Internet.
	return OK;
    }

    return FORBIDDEN;
}

1;