cvs commit: modperl-2.0/t/protocol/TestProtocol pseudo_http.pm

[st...@apache.org]

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>