
#############################################################################
## $Id: NetServer.pm 6004 2006-05-02 13:52:30Z spadkins $
#############################################################################

package App::Context::NetServer;
$VERSION = (q$Revision: 6004 $ =~ /(\d[\d\.]*)/)[0];  # VERSION numbers generated by svn

use App;
use App::Context;
use Net::Server;

@ISA = ( "Net::Server", "App::Context" );

use App::UserAgent;

use strict;

=head1 NAME

App::Context::NetServer - context in which we are currently running

=head1 SYNOPSIS

   # ... official way to get a Context object ...
   use App;
   $context = App->context();
   $config = $context->config();   # get the configuration
   $config->dispatch_events();     # dispatch events

   # ... alternative way (used internally) ...
   use App::Context::NetServer;
   $context = App::Context::NetServer->new();

=cut

#############################################################################
# DESCRIPTION
#############################################################################

=head1 DESCRIPTION

A Context class models the environment (aka "context)
in which the current execution thread is running.
For the App::Context::NetServer class, this is the runtime environment
of a server with any of the following Net::Server personalities.

  * Net::Server                - generic, single-connection server
  * Net::Server::INET          - a server controlled by inetd
  * Net::Server::Fork          - a forking server
  * Net::Server::PreForkSimple - a prefork server with constant # children
  * Net::Server::PreFork       - a prefork server with varying # children

=cut

#############################################################################
# PROTECTED METHODS
#############################################################################

=head1 Protected Methods:

The following methods are intended to be called by subclasses of the
current class.

=cut

#############################################################################
# _init()
#############################################################################

=head2 _init()

The _init() method is called from within the standard Context constructor.

The _init() method sets debug flags.

    * Signature: $context->_init($args)
    * Param:     $args            hash{string} [in]
    * Return:    void
    * Throws:    App::Exception
    * Since:     0.01

    Sample Usage: 

    $context->_init($args);

=cut

sub _init {
    my ($self, $args) = @_;
    $args = {} if (!defined $args);

}

#############################################################################
# PROTECTED METHODS
#############################################################################

=head1 Protected Methods

These methods are considered protected because no class is ever supposed
to call them.  They may however be called by the context-specific drivers.

=cut

#############################################################################
# dispatch_events()
#############################################################################

=head2 dispatch_events()

The dispatch_events() method is called at server startup.
This method is not expected to return control until the server
is exiting.

    * Signature: $context->dispatch_events()
    * Param:     void
    * Return:    void
    * Throws:    App::Exception
    * Since:     0.01

    Sample Usage: 

    $context->dispatch_events();

=cut

#  conf_file         "filename"               undef
#
#  log_level         0-4                      2
#  log_file          (filename|Sys::Syslog)   undef
#
#  ## syslog parameters
#  syslog_logsock    (unix|inet)              unix
#  syslog_ident      "identity"               "net_server"
#  syslog_logopt     (cons|ndelay|nowait|pid) pid
#  syslog_facility   \w+                      daemon
#
#  port              \d+                      20203
#  host              "host"                   "*"
#  proto             (tcp|udp|unix)           "tcp"
#  listen            \d+                      SOMAXCONN
#
#  reverse_lookups   1                        undef
#  allow             /regex/                  none
#  deny              /regex/                  none
#
#  ## daemonization parameters
#  pid_file          "filename"               undef
#  chroot            "directory"              undef
#  user              (uid|username)           "nobody"
#  group             (gid|group)              "nobody"
#  background        1                        undef
#  setsid            1                        undef
#
#  no_close_by_child (1|undef)                undef

sub dispatch_events {
    my ($self) = @_;

    my $options = $self->options();
    my @options = qw(
        conf_file
        log_level log_file
        syslog_logsock syslog_ident syslog_logopt syslog_facility
        port host proto listen
        reverse_lookups allow deny
        pid_file chroot user group background setsid
        no_close_by_child
    );

    my (%options);
    #foreach my $option (@options) {
    #    if (defined $options->{"netserver_$option"}) {
    #        $options{$option} = $options->{"netserver_$option"};
    #    }
    #}

    $self->run(%options);  # this initiates the native event loop of Net::Server
    $self->shutdown();
}

#############################################################################
# process_request()
# this is the interface that needs to be implemented for Net::Server
#############################################################################

sub process_request {
    my $self = shift;
    eval {
        local $SIG{ALRM} = sub { die "Timed Out!\n" };
        my $timeout = 10; # give the user 30 seconds to type a line
        #my $header_sent = 0;

        my $previous_alarm = alarm($timeout);
        while (<STDIN>) {
            s/\r?\n$//;
            #if (!$header_sent) {
            #    print "Content-type: text/plain\n\n";
            #    $header_sent = 1;
            #}
            print "You said \"$_\"\r\n";
            alarm($timeout);
        }
        alarm($previous_alarm);
    };
    if( $@=~/timed out/i ){
        print STDOUT "Timed Out.\r\n";
        return;
    }
}

#############################################################################
# send_response()
#############################################################################

=head2 send_response()

    * Signature: $context->send_response()
    * Param:     void
    * Return:    void
    * Throws:    App::Exception
    * Since:     0.01

    Sample Usage: 

    $context->send_response();

=cut

sub send_response {
    my $self = shift;

    my ($serializer, $response, $ctype, $content, $content_type, $headers);
    $response     = $self->response();
    $content      = $response->content();

    if (ref($content)) {
        $ctype = $self->so_get("default", "ctype", "default");
        $serializer = $self->serializer($ctype);
        $content = $serializer->serialize($content);
        $content_type = $serializer->serialized_content_type();
    }
    $content_type = $response->content_type() if (!$content_type);
    $content_type = "text/plain" if (!$content_type);
    $headers      = "Content-type: $content_type\n";

    if (defined $self->{headers}) {
        $headers .= $self->{headers};
        delete $self->{headers}
    }

    #if ($self->{messages}) {
    #    my $msg = $self->{messages};
    #    $self->{messages} = "";
    #    $msg =~ s/<br>/\n/g;
    #    print "Content-type: text/plain\n\n", $msg, "\n";
    #}
    #else {
    #    print $headers, "\n", $content;
    #}
}

#############################################################################
# set_header()
#############################################################################

=head2 set_header()

    * Signature: $context->set_header()
    * Param:     void
    * Return:    void
    * Throws:    App::Exception
    * Since:     0.01

    Sample Usage: 

    $context->set_header();

=cut

sub set_header {
    my ($self, $header) = @_;
    if ($self->{headers}) {
        $self->{headers} .= $header;
    }
    else {
        $self->{headers} = $header;
    }
}

#############################################################################
# request()
#############################################################################

=head2 request()

    * Signature: $context->request()
    * Param:     void
    * Return:    void
    * Throws:    App::Exception
    * Since:     0.01

    Sample Usage: 

    $context->request();

The request() method gets the current Request being handled in the Context.

=cut

sub request {
    my $self = shift;

    return $self->{request} if (defined $self->{request});

    #################################################################
    # REQUEST
    #################################################################

    my $request_class = $self->get_option("request_class");
    if (!$request_class) {
        $request_class = "App::Request";
    }

    eval {
        $self->{request} = App->new($request_class, "new", $self, $self->{options});
    };
    $self->add_message("Context::NetServer::request(): $@") if ($@);

    return $self->{request};
}

#############################################################################
# response()
#############################################################################

=head2 response()

    * Signature: $context->response()
    * Param:     void
    * Return:    void
    * Throws:    App::Exception
    * Since:     0.01

    Sample Usage: 

    $context->response();

The response() method gets the current Request being handled in the Context.

=cut

sub response {
    my $self = shift;

    return $self->{response} if (defined $self->{response});

    #################################################################
    # RESPONSE
    #################################################################

    my $response_class = $self->get_option("response_class", "App::Response");

    eval {
        $self->{response} = App->new($response_class, "new", $self, $self->{options});
    };
    $self->add_message("Context::NetServer::response(): $@") if ($@);

    return $self->{response};
}

#############################################################################
# PUBLIC METHODS
#############################################################################

=head1 Public Methods:

=cut

#############################################################################
# user()
#############################################################################

=head2 user()

The user() method returns the username of the authenticated user.
The special name, "guest", refers to the unauthenticated (anonymous) user.

    * Signature: $username = $self->user();
    * Param:  void
    * Return: string
    * Throws: <none>
    * Since:  0.01

    Sample Usage: 

    $username = $context->user();

In a request/response environment, this turns out to be a convenience
method which gets the authenticated user from the current Request object.

=cut

sub user {
    my $self = shift;
    return "guest";
    #return $self->request()->user();
}

1;

