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>