stas 2004/07/04 18:36:47
Added: t/htdocs/protocols basic-auth
t/protocol pseudo_http.t
t/protocol/TestProtocol pseudo_http.pm
Log:
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
testing hooks like: run_access_checker, run_check_user_id,
run_auth_checker and various auth methods
Revision Changes Path
1.1 modperl-2.0/t/htdocs/protocols/basic-auth
Index: basic-auth
===================================================================
stas:Bk4ZXGa.lVGTQ
1.1 modperl-2.0/t/protocol/pseudo_http.t
Index: pseudo_http.t
===================================================================
use strict;
use warnings FATAL => 'all';
use Apache::Test;
use Apache::TestUtil;
use Apache::TestRequest ();
my $module = 'TestProtocol::pseudo_http';
{
# debug
Apache::TestRequest::module($module);
my $hostport = Apache::TestRequest::hostport(Apache::Test::config());
t_debug("connecting to $hostport");
}
my $login = "stas";
my $passgood = "foobar";
my $passbad = "foObaR";
plan tests => 13, have_access;
{
# supply correct credential when prompted for such and ask the
# server get the secret datetime information
my $socket = Apache::TestRequest::vhost_socket($module);
ok $socket;
expect_reply($socket, "HELO", "HELO", "greeting");
expect_reply($socket, "Login:", $login, "login");
expect_reply($socket, "Password:", $passgood, "good password");
expect($socket, "Welcome to TestProtocol::pseudo_http", "banner");
expect_reply($socket, "Available commands: date quit", "date", "date");
expect_reply($socket, qr/The time is:/, "quit", "quit");
expect($socket, "Goodbye", "end of transmission");
}
{
# this time sending wrong credentials and hoping that the server
# won't let us in
my $socket = Apache::TestRequest::vhost_socket($module);
ok $socket;
expect_reply($socket, "HELO", "HELO", "greeting");
expect_reply($socket, "Login:", $login, "login");
t_client_log_error_is_expected();
expect_reply($socket, "Password:", $passbad, "wrong password");
expect($socket, "Access Denied", "end of transmission");
}
sub expect {
my($socket, $expect, $action) = @_;
chomp(my $recv = <$socket> || '');
ok t_cmp($recv, $expect, $action);
}
sub expect_reply {
my($socket, $expect, $reply, $action) = @_;
chomp(my $recv = <$socket> || '');
ok t_cmp($recv, $expect, $action);
t_debug("send: $reply");
print $socket $reply;
}
1.1 modperl-2.0/t/protocol/TestProtocol/pseudo_http.pm
Index: pseudo_http.pm
===================================================================
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 Apache::Connection ();
use Apache::RequestUtil ();
use Apache::HookRun ();
use Apache::Access ();
use APR::Socket ();
use Apache::Const -compile => qw(OK DONE DECLINED);
my @cmds = qw(date quit);
my %commands = map { $_, \&{$_} } @cmds;
sub handler {
my $c = shift;
my $socket = $c->client_socket;
if ((my $rc = greet($c)) != Apache::OK) {
$socket->send("Say HELO first\n");
return $rc;
}
if ((my $rc = login($c)) != Apache::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) == Apache::OK;
}
else {
$socket->send("Commands: @cmds\n");
}
}
return Apache::OK;
}
sub greet {
my $c = shift;
my $socket = $c->client_socket;
$socket->send("HELO\n");
my $reply = getline($socket) || '';
return $reply eq 'HELO' ? Apache::OK : Apache::DECLINED;
}
sub login {
my $c = shift;
my $r = Apache::RequestRec->new($c);
$r->location_merge(__PACKAGE__);
for my $method (qw(run_access_checker run_check_user_id
run_auth_checker)) {
my $rc = $r->$method();
if ($rc != Apache::OK and $rc != Apache::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 Apache::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 Apache::OK;
}
sub quit {
my $socket = shift;
$socket->send("Goodbye\n");
return Apache::DONE
}
1;
__END__
<NoAutoConfig>
<VirtualHost TestProtocol::pseudo_http>
PerlProcessConnectionHandler TestProtocol::pseudo_http
<Location TestProtocol::pseudo_http>
<IfModule mod_access.c>
Order Deny,Allow
Allow from @servername@
Require user stas
Satisfy any
# htpasswd -bc basic-auth stas foobar
AuthUserFile @ServerRoot@/htdocs/protocols/basic-auth
</IfModule>
</Location>
</VirtualHost>
</NoAutoConfig>
