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
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
|
# please insert nothing before this line: -*- mode: cperl; cperl-indent-level: 4; cperl-continued-statement-offset: 4; indent-tabs-mode: nil -*-
package TestProtocol::pseudo_http;
# this is a more advanced protocol implementation. While using a
# simplistic socket communication, the protocol uses an almost
# complete HTTP AAA (access and authentication, but not authorization,
# which can be easily added) provided by mod_auth (but can be
# implemented in perl too)
#
# see the protocols.pod document for the explanations of the code
use strict;
use warnings FATAL => 'all';
use Apache2::Connection ();
use Apache2::RequestUtil ();
use Apache2::HookRun ();
use Apache2::Access ();
use APR::Socket ();
use Apache::TestTrace;
use Apache2::Const -compile => qw(OK DONE DECLINED);
use APR::Const -compile => qw(SO_NONBLOCK);
my @cmds = qw(date quit);
my %commands = map { $_, \&{$_} } @cmds;
sub handler {
my $c = shift;
my $socket = $c->client_socket;
if ($socket->opt_get(APR::Const::SO_NONBLOCK)) {
$socket->opt_set(APR::Const::SO_NONBLOCK => 0);
}
if ((my $rc = greet($c)) != Apache2::Const::OK) {
$socket->send("Say HELO first\n");
return $rc;
}
if ((my $rc = login($c)) != Apache2::Const::OK) {
$socket->send("Access Denied\n");
return $rc;
}
$socket->send("Welcome to " . __PACKAGE__ .
"\nAvailable commands: @cmds\n");
while (1) {
my $cmd;
next unless $cmd = getline($socket);
if (my $sub = $commands{$cmd}) {
last unless $sub->($socket) == Apache2::Const::OK;
}
else {
$socket->send("Commands: @cmds\n");
}
}
return Apache2::Const::OK;
}
sub greet {
my $c = shift;
my $socket = $c->client_socket;
$socket->send("HELO\n");
my $reply = getline($socket) || '';
return $reply eq 'HELO' ? Apache2::Const::OK : Apache2::Const::DECLINED;
}
sub login {
my $c = shift;
my $r = Apache2::RequestRec->new($c);
# test whether we can invoke modperl HTTP handlers on the fake $r
$r->push_handlers(PerlAccessHandler => \&my_access);
$r->location_merge(__PACKAGE__);
for my $method (qw(run_access_checker run_check_user_id
run_auth_checker)) {
my $rc = $r->$method();
if ($rc != Apache2::Const::OK and $rc != Apache2::Const::DECLINED) {
return $rc;
}
last unless $r->some_auth_required;
unless ($r->user) {
my $socket = $c->client_socket;
my $username = prompt($socket, "Login");
my $password = prompt($socket, "Password");
$r->set_basic_credentials($username, $password);
}
}
return Apache2::Const::OK;
}
sub my_access {
# just test that we can invoke a mod_perl HTTP handler
debug "running my_access";
return Apache2::Const::OK;
}
sub getline {
my $socket = shift;
my $line;
$socket->recv($line, 1024);
return unless $line;
$line =~ s/[\r\n]*$//;
return $line;
}
sub prompt {
my ($socket, $msg) = @_;
$socket->send("$msg:\n");
getline($socket);
}
sub date {
my $socket = shift;
$socket->send("The time is: " . scalar(localtime) . "\n");
return Apache2::Const::OK;
}
sub quit {
my $socket = shift;
$socket->send("Goodbye\n");
return Apache2::Const::DONE
}
1;
__END__
<NoAutoConfig>
<VirtualHost TestProtocol::pseudo_http>
PerlProcessConnectionHandler TestProtocol::pseudo_http
<Location TestProtocol::pseudo_http>
<IfModule @ACCESS_MODULE@>
Order Deny,Allow
Allow from @servername@
</IfModule>
<IfModule @AUTH_MODULE@>
# htpasswd -mbc basic-auth stas foobar
# using md5 password so it'll work on win32 too
AuthUserFile @ServerRoot@/htdocs/protocols/basic-auth
</IfModule>
AuthName TestProtocol::pseudo_http
AuthType Basic
Require user stas
Satisfy any
</Location>
</VirtualHost>
</NoAutoConfig>
|
