Perl Advent Calendar 2010-12-16

'Net stockings are barely servicable gift receptacles

by Stephen R. Scaffidi

Santa needed to implement a server to collect naughty/nice lists from all over the world. The IT elves needed a quick solution that allowed Naughty Montoring Service offices in far flung corners across the globe to report their extensive child behavioral data to HQ for analysis.

In the end the North Pole settled on Net::Server, a comprehensive, flexible, and robust framework used by numerous other packages such as Catalyst::Engine::Server and Starman. It handles the gritty details of listening on one or more sockets, forking and daemonising, buffering, logging and even more. In some cases it takes more control of things than you might want (like signal handling), but before you give-up and roll your own, ask yourself: Do you really need your server to be an ornament polish and a gingerbread house spackle?

Net::Server has extensive documentation, but our example script below should hopefully provide a comparatively short introduction.

mod16.pl

   1 # Run the server, unless this code is being loaded as a module
   2 Xmas::NMS::Server->run() unless caller();
   3 
   4 package Xmas::NMS::Server;
   5 use base qw(Net::Server::PreFork);
   6 use Carp;
   7 use Scalar::Util qw(blessed);
   8 use File::Basename qw(dirname);
   9 use File::Spec::Functions qw(catdir);
  10 
  11 # Net::Server can take options from the command line, a
  12 # config file, or as parameters to new() or run(). Using
  13 # this method, you can override and add options that
  14 # Net::Server will then recognize from any of those places
  15 sub options {
  16     my ( $self, $template ) = @_;  # template is a hashref
  17     my $props = $self->{server};   # server properties
  18 
  19     # load the base class' options into the template
  20     $self->SUPER::options( $template );
  21 
  22     # create a property entry for the new option
  23     $props->{nms_authkey} ||= undef;
  24 
  25     # put a reference to that entry into the template
  26     $template->{nms_authkey} = \$props->{nms_authkey};
  27 
  28     # when the options are processed by Net::Server,
  29     # their values will be stored in the referenced
  30     # server property entries
  31 
  32     # use an arrayref for multi-valued options
  33     $props->{nms_regions} ||= [];
  34     $template->{nms_regions} = $props->{nms_regions};
  35 
  36     # you can do each type in one line, if you like...
  37     $template->{"nms_$_"} = \$props->{"nms_$_"}
  38         for ( qw( data_dir client_timeout) );
  39 
  40     $template->{nms_data_types} = $props->{nms_data_types} ||= [];
  41 }
  42 
  43 # If you want to set some defaults differently or in
  44 # addition to those already used by Net::Server, put
  45 # them in a hash returned by this method.
  46 sub default_values {
  47     return {
  48         port => 8765,
  49         nms_client_timeout => 30,
  50 
  51         # types of data collected by the agency
  52         nms_data_types => [qw(observations hearsay gift_lists)],
  53 
  54         # where to look for the data files
  55         nms_data_dir => catdir( dirname( $0 ), 'data' ),
  56     };
  57 }
  58 
  59 # use this method to validate the values of your options
  60 sub post_configure_hook {
  61     my ( $self ) = @_;
  62     my $props = $self->{server};
  63 
  64     @{ $props->{nms_regions} }
  65         || croak "Please specify one or more values for nms_regions";
  66 
  67     $props->{nms_authkey}
  68         || croak "Please specify a value for nms_authkey";
  69 }
  70 
  71 # if you want to use authorization more involved than
  72 # checking the client's IP address, use this hook
  73 sub allow_deny_hook {
  74     my ( $self ) = @_;
  75     my $props = $self->{server};
  76 
  77     # prompt
  78     $self->sendtext( "auth: " );
  79 
  80     my $line = $self->getline_timeout || return;
  81 
  82     # authorized? return truth
  83     return 1 if $line eq $props->{nms_authkey};
  84 
  85     # not authorized? return false
  86     my $client_ip = $props->{peeraddr} || 'unknown';
  87     $self->sendlines( 
  88         "AUTHORIZATION FAILED FROM IP [$client_ip]",
  89         "YOU ARE NOW ON THE NAUGHTY LIST",
  90     );
  91 
  92     return;
  93 }
  94 
  95 # continuation of authorized connections
  96 sub process_request {
  97     my ( $self ) = @_;
  98 
  99     my $props     = $self->{server};
 100     my $client_fh = $props->{client};
 101 
 102     $self->sendlines(
 103         "",
 104         "Welcome to the NMS server for the following regions:",
 105         ( map {"\t$_"} @{ $props->{nms_regions} } ),
 106         "",
 107         "Enter the name of a snot-nosed brat or QUIT to logout.",
 108         "NOTE: children actually named 'QUIT' have a tough life",
 109         "already and automatically get a pony EVERY YEAR",
 110         "",
 111     );
 112 
 113     while ( $self->sendtext( "name: " )
 114         and defined( my $name = $self->getline_timeout ) )
 115     {
 116         return if $name eq 'QUIT';
 117         $self->sendlines( "\t$name is a rotten little kid", "" );
 118     }
 119 
 120 }
 121 
 122 # this isn't a Net::Server hook, it's just a helper
 123 # to get a line from the client within a timeout
 124 sub getline_timeout {
 125     my ( $self, $client_fh, $timeout ) = @_;
 126 
 127     $client_fh ||= $self->{server}{client};
 128     $timeout   ||= $self->{server}{nms_client_timeout};
 129 
 130     # attempt to get a line from the client within the timeout
 131     my $line = eval {
 132 
 133         # set an alarm to throw an exception...
 134         local $SIG{'ALRM'} = sub { die "Timed Out!\n" };
 135         my $previous_alarm = alarm( $timeout );
 136 
 137         my $line = $client_fh->getline;
 138 
 139         # restore the old alarm value
 140         alarm( $previous_alarm );
 141 
 142         # return the line from the eval
 143         $line;
 144     };
 145 
 146     # if the alarm went off, catch the exception
 147     if ( $@ =~ /timed out/i ) {
 148         $self->sendlines(
 149             $client_fh,
 150             "Timed Out - You were too slow-ho-ho!"
 151         );
 152         return;
 153     }
 154 
 155     # getline can return undef...
 156     return unless defined $line;
 157 
 158     # strip out any end-of-line chars
 159     $line =~ s/\r?\n$//;
 160     return $line;
 161 }
 162 
 163 
 164 # another helper method to make decorate text with newlines
 165 sub sendlines {
 166     my $self = shift;
 167     my ($client_fh, @lines) = $self->_client_fh_from_args( @_ );
 168     $self->sendtext( $client_fh, map { "$_\r\n" } @lines );
 169 }
 170 
 171 # concatenate text and send to client undecorated
 172 sub sendtext {
 173     my ( $self ) = shift;
 174 
 175     my ($client_fh, @lines) = $self->_client_fh_from_args( @_ );
 176 
 177     $client_fh->print( map { defined( $_ ) ? $_ : "" } @lines )
 178         or croak "Error sending data to the client!";
 179 }
 180 
 181 # find out if the first argument is a filehandle. if so, use that.
 182 # if not, use the client filehandle.
 183 sub _client_fh_from_args {
 184     my $self = shift;
 185     my $client_fh
 186         = ( blessed( $_[0] ) && $_[0]->can( 'print' ) ) ?
 187             shift : $self->{server}{client};
 188     return ( $client_fh, @_ );
 189 }
 190 
 191 1;
View Source (POD)