lecture in color

Case study: IPC

CPAN is a complicated and vicious beast.
Easiest way to describe it is via case studies.
Let's study "Inter-Process Communication" in detail.
Requires: CPAN, "man perlipc", Chapter 16.

Inter-process communication

much easier in perl than in many other languages.
writing internet daemons is downright trivial.
perl's terse style makes network programming more clear than in most any other language.
one can very easily craft things that -- in C -- take 10 times longer to write.

Parts of IPC

signals: how to talk to processes out of band.
files: simple IPC mechanisms.
pipes: talking with your children.
sockets: connecting to internet services.

First, the basics of processes

a process is an autonomous unit of computation, with its own memory map, context, etc.
processes spawn others via fork(). The code:
```
 $pid = fork(); 
```
splits the current process into two copies, a parent and a child.
- In the parent, $pid is the process-id of the child.
- In the child, $pid is 0.
This means that we can write:
```
 $pid = fork(); 
 if ($pid!=0) { 
     # in parent 
 } else { 
     # in child 
 } 
```
to describe what the parent and child do.
during a fork, a child can:
- simply exit when it's done with what it's doing.
- replace itself with another program, using exec.
during a fork, a parent can:
- wait for the child to finish (usually) or
- arrange to reap the child's process asynchronously.

system: a shorthand for "fork and wait"; roughly equivalent to:

 sub mysystem { 
     my $command = shift; 
     my $pid = fork(); 
     if ($pid!=0) { 
         # parent: wait for child 
         waitpid($pid,0); 
     } else { 
         # child: simply execute the command
         exec $command; 
     } 
 }

Signals

way of communicating between processes (that might not have ancestor relationships).
can only send signals to your own processes (unless you're root)
signals sent as a result of common occurrences.
sending a signal: kill
```
 kill 9, $pid
```
stops it unconditionally (9=SIGKILL='shut up and die')

solaris signals:

 #define SIGHUP  1       /* hangup */
 #define SIGINT  2       /* interrupt (rubout) */
 #define SIGQUIT 3       /* quit (ASCII FS) */
 #define SIGILL  4       /* illegal instruction (not reset when caught) */
 #define SIGTRAP 5       /* trace trap (not reset when caught) */
 #define SIGIOT  6       /* IOT instruction */
 #define SIGABRT 6       /* used by abort, replace SIGIOT in the future */
 #define SIGEMT  7       /* EMT instruction */
 #define SIGFPE  8       /* floating point exception */
 #define SIGKILL 9       /* kill (cannot be caught or ignored) */
 #define SIGBUS  10      /* bus error */
 #define SIGSEGV 11      /* segmentation violation */
 #define SIGSYS  12      /* bad argument to system call */
 #define SIGPIPE 13      /* write on a pipe with no one to read it */
 #define SIGALRM 14      /* alarm clock */
 #define SIGTERM 15      /* software termination signal from kill */
 #define SIGUSR1 16      /* user defined signal 1 */
 #define SIGUSR2 17      /* user defined signal 2 */
 #define SIGCLD  18      /* child status change */
 #define SIGCHLD 18      /* child status change alias (POSIX) */
 #define SIGPWR  19      /* power-fail restart */
 #define SIGWINCH 20     /* window size change */
 #define SIGURG  21      /* urgent socket condition */
 #define SIGPOLL 22      /* pollable event occured */
 #define SIGIO   SIGPOLL /* socket I/O possible (SIGPOLL alias) */
 #define SIGSTOP 23      /* stop (cannot be caught or ignored) */
 #define SIGTSTP 24      /* user stop requested from tty */
 #define SIGCONT 25      /* stopped process has been continued */
 #define SIGTTIN 26      /* background tty read attempted */
 #define SIGTTOU 27      /* background tty write attempted */
 #define SIGVTALRM 28    /* virtual timer expired */
 #define SIGPROF 29      /* profiling timer expired */
 #define SIGXCPU 30      /* exceeded cpu limit */
 #define SIGXFSZ 31      /* exceeded file size limit */
 #define SIGWAITING 32   /* process's lwps are blocked */
 #define SIGLWP  33      /* special signal used by thread library */
 #define SIGFREEZE 34    /* special signal used by CPR */
 #define SIGTHAW 35      /* special signal used by CPR */
 #define SIGCANCEL 36    /* thread cancellation signal used by libthread */
 #define SIGLOST 37      /* resource lost (eg, record-lock lost) */

(linux similar)

Important signals for us:
- INT interrupt (control-C).
- TSTP suspend (control-Z).
- KILL die unconditionally.
- TERM die nicely.
- PIPE I/o waiting on a pipe.
- ALRM Timer alarm reached.
- CHLD child process status change.
- SEGV segmentation violation.
- BUS bus error.
- FPE floating-point exception (e.g., divide by 0)

Responding to signals

With notable exceptions, you can define define what happens in response to a signal.
$SIG{NAME} is a reference to a coderef of the handler for the signal named NAME.

For example, you can make control-C work:

 sub catch_zap {
    my $signame = shift;
    die "Somebody sent me a SIG$signame";
 }
 $SIG{INT} = \&catch_zap;  
 # source: man perlipc

or become non-operative:

 sub catch_zap {
    my $signame = shift;
 }
 $SIG{INT} = \&catch_zap;

The handler receives one argument that is the short name of the signal being invoked.

Signal Handler caveats

Signal handlers interrupt the normal flow of a program.
If a signal handler returns, the program might continue to function properly (or might not).
A program is re-entrant if signal handlers can return without crashing it.
Many perl libraries aren't re-entrant.
Caveat: if you do much more than setting global variables in your handler, returning from it will likely cause a core dump.
Exception: in Perl 5.7+, signal handlers are deferred during non-re-entrant activities. This means that
- you can do non-trivial things in your handler but
- certain interrupts (e.g., SIGINT) may be deferred until after I/O completes, etc.

Responding to `CHLD`

Suppose you "can't wait" for a particular process.
You must still reap the child process or it can become a zombie.

Answer: CHLD.

 sub REAPER {
     $waitedpid = wait; # reap the child 
     # loathe sysV: it makes us not only reinstate
     # the handler, but place it after the wait
     $SIG{CHLD} = \&REAPER;
 }
 $SIG{CHLD} = \&REAPER; # reap ALL children
 # source: man perlipc

After this, you could, e.g.,
```
 if (!fork()) { # child
    exec "some command"; 
 } 
```
and some command would run in parallel with further processing in the parent, and would still be reaped at the end of its execution.

ALRM allows you to limit waiting for an external event. Consider:

 eval {
     local $SIG{ALRM} = sub { die "alarm clock restart" };
     alarm 10;       # set alarm to 10 seconds
     flock(FH, 2);   # blocking write lock
     alarm 0;        # turn off alarm
 };
 if ($@ and $@ !~ /alarm clock restart/) { die }
 # source: man perlipc

Inside the eval, we set a 10-second time limit.
If this goes off, the flock took too long. If so, we know this from $@ (the exit error string).
If the error is not an alarm, we know something more serious happened and die ourselves.

Special handlers:

DEFAULT: do the default thing

 $SIG{INT}='DEFAULT'; # restore default control-C processing

IGNORE: ignore this signal

 $SIG{INT}='IGNORE';  # ignore control-C

Process groups:

Sending a signal to the negative of a process id kills all processes in its group.

 {
   local $SIG{HUP} = 'IGNORE';
   kill HUP => -$$;
   # snazzy writing of: kill('HUP', -$$)
 }

Handling `HUP` for daemons

Daemons (Disk And Execution MONitors): programs that run all the time.
Executed at startup.
Read configuration files.

Standard convention: SIGHUP means "re-read your databases".

 #!/usr/bin/perl -w

 use POSIX (); # fancy signal handling 
 use FindBin (); # locate directory of this perl script 
 use File::Basename (); # compute basename of a file. 
 use File::Spec::Functions;  # catfile: concatenate a filename

 $|=1;

 # make the daemon cross-platform, so exec always calls the script
 # itself with the right path, no matter how the script was invoked.
 my $script = File::Basename::basename($0);
 my $SELF = catfile $FindBin::Bin, $script;

 # POSIX unmasks the sigprocmask properly
 # SigSet: a set of signals 
 my $sigset = POSIX::SigSet->new();
 # action must be in a SigSet
 my $action = POSIX::SigAction->new('sigHUP_handler',
                                   $sigset,
                                   &POSIX::SA_NODEFER);
 # associate an action with a signal
 POSIX::sigaction(&POSIX::SIGHUP, $action);

 sub sigHUP_handler {
     print "got SIGHUP\n";
     exec($SELF, @ARGV) or die "Couldn't restart: $!\n";
 }

 # go into an infinite loop and simulate a daemon
 code();

 sub code {
     print "PID: $$\n";
     print "ARGV: @ARGV\n";
     my $c = 0;
     while (++$c) {
        sleep 2;
        print "$c\n";
     }
 }
 __END__
 # source: man perlipc

Creating a daemon

most important step in creating a daemon: dissociate from the controlling terminal.
Most processes have a controlling terminal (e.g., where you're typing).
Daemons cannot; there's no concept of "what user" invoked a daemon.

Lots of fancy file calls necessary to make this happen:

 use POSIX 'setsid'; # create a new session id
 
 sub daemonize {
    chdir '/'               or die "Can't chdir to /: $!";
    open STDIN, '/dev/null' or die "Can't read /dev/null: $!";
    open STDOUT, '>/dev/null'
                          or die "Can't write to /dev/null: $!";
    defined(my $pid = fork) or die "Can't fork: $!";
    exit if $pid;
    setsid                  or die "Can't start a new session: $!";
    open STDERR, '>&STDOUT' or die "Can't dup stdout: $!";
 }
 # source: man perlipc

setsid: set new "session ID" (create new process group).

Step 2: understanding advanced file I/O

When a process forks or execs, the new process has a copy of
- all open file descriptors in the original.
- all environment variables.
This means that one can set the stage for a child program by manipulating file descriptors before fork or exec.

Fancy opens

We know that when you execute, e.g.,
```
 open (FH, "netstat -an |"); 
```
that Perl actually executes the netstat command and connects it to your output.

Also, one can write to a program, by, e.g.,

 open (FH, "| cat -n"); # number output lines

In this case, however, one should trap SIGPIPE:

 sub hot { 
     my $signame = shift; 
     die "received SIG$signame"; 
 } 
 $SIG{PIPE}=\&hot;

or there is no way to tell that the pipe broke!

As a really fancy open, the statement

 my $pid = open (FH, "|-");

forks a child whose STDIN is connected to your FH. Then one can do parent and child actions:

 if ($pid) { # parent
    print FH "hello\n"; 
 } else { # child 
    my $message = <STDIN>; 
    chomp $message; # remove \n
    print "got message '$message' from parent.\n";  
    exit 0; 
 }

Likewise, the statement

 my $pid = open (FH, "-|");

forks a child whose STDOUT is connected to your FH. E.g.,

 if ($pid) { #parent
    my $input = <FH>; chomp $input; 
    print "got $input from child!\n"; 
 } else { # child 
    print "hidere\n"; 
    exit 0; 
 }

What's going on inside `|-` and `-|`

often, we need to "fool" subprocesses into writing onto our filehandles rather than to STDOUT.
solution: dup a pipe onto STDIN or STDOUT.

Consider:

contents of perl_ipc/dup.pl...
#! /var/local/couch/bin/perl 

pipe(READER, WRITER); # make a pair of connected sockets. 
if ($pid=fork()) { 
    close WRITER; 
    while (<READER>) { 
	print "parent: ".$_; 
    } 
    waitpid($pid,0); 
} else { 
    close READER; 
    # duplicate WRITER on STDOUT
    open STDOUT, ">&", \*WRITER or die "can't dup WRITER to STDOUT: $!"; 
    # run a local command; capture output
    exec "w"; 
} 
...end of perl_ipc/dup.pl

This prints:

contents of perl_ipc/dup.pl.out...
lin09{couch}88: dup.pl
parent:   3:50pm  up 11 days,  6:01,  4 users,  load average: 0.00, 0.02, 0.00
parent: USER     TTY      FROM              LOGIN@   IDLE   JCPU   PCPU  WHAT
parent: mwartak  pts/0    h00a0cce073f4.ne 11:52am  3:49m  0.20s  0.20s  -tcsh 
parent: mwartak  pts/1    h00a0cce073f4.ne 11:48am  3:58m  0.65s  0.44s  emacs -nw 
parent: couch    pts/2    blackhole.eecs.t  1:36pm  0.00s  0.26s  0.01s  /var/local/couc
parent: couch    pts/4    blackhole.eecs.t  2:54pm  2:02   0.40s  0.18s  /var/local/couc
lin09{couch}89:ls
...end of perl_ipc/dup.pl.out

Does almost exactly the same thing that fancy open calls do.

Kinds of dups
- STDOUT
```
 open STDOUT, ">&", \*OUTPUT; 
```
- STDIN
```
 open STDIN, "<&", \*INPUT; 
```
  (there's an implicit close when you open something)

Burning the candle at both ends

Sometimes you want to both read from and write to a child.
Answer: open2. Consider:
```
 use FileHandle;
 use IPC::Open2;
 $pid = open2( \*READER, \*WRITER, "cat -u -n" );
 WRITER->autoflush(); # default here, actually
 print WRITER "stuff\n";
 $got = <READER>;
```
- autoflush: set pipe to unbuffered (all writes occur immediately)
- \*READER: reference to the symbol READER. This is what you read to get back output.
- \*WRITER: reference to the symbol WRITER. This is what you write to specify input.
Watch out: buffering in the command can mess things up.
- cat -u: make cat unbuffered.
- at the mercy of how your command buffers input.
- writing everything, then reading won't work if output is larger than a pipe buffer (4096-8192 bytes, depending upon system).
Monstrous hack: make the dumb program think it's talking to a tty:
```
 require 'Comm.pl';
 $ph = open_proc('cat -n');
 for (1..10) {
     print $ph "a line\n";
     print "got back ", scalar <$ph>;
 }
```
- Comm.pl: opens a command, fools it into thinking it's talking to a tty (and is thus line buffered).
- must use no strict 'refs'; for this to work (Filehandle is a string).

Recall (from last time)

Processes accept signals via kill.
Processes react to signals by setting $SIG{SIGNAL} to a coderef to execute.
To make a new process, a process can fork itself into two processes.
To run a program, a process can exec another program.
Forked children have an identical execution context to the parent.
Exec'd processes inherit environment variables and file descriptors only, lose the rest of the execution environment.

Can manipulate a process's view of the world by duping file descriptors, e.g.,

 open STDIN, "<&", \*READER -- make STDIN read from file descriptor |READER|. 
 open STDOUT, ">&", \*WRITER -- make STDOUT write to file descriptor |WRITER|.

A pipe is a pair of file descriptors, one for writing to and one for reading from.

What's happening in fancy IPC

create pipes using pipe().
write in one end, read from other end.

Example: manual creation of IPC:

 use IO::Handle;     # thousands of lines just for autoflush :-(
 pipe(PARENT_RDR, CHILD_WTR);                # XXX: failure?
 pipe(CHILD_RDR,  PARENT_WTR);               # XXX: failure?
 CHILD_WTR->autoflush(1);
 PARENT_WTR->autoflush(1);
 
 if ($pid = fork) {
    close PARENT_RDR; close PARENT_WTR;
    print CHILD_WTR "Parent Pid $$ is sending this\n";
    chomp($line = <CHILD_RDR>);
    print "Parent Pid $$ just read this: `$line'\n";
    close CHILD_RDR; close CHILD_WTR;
    waitpid($pid,0); # wait for specific child ($pid)
 } else {
    die "cannot fork: $!" unless defined $pid;
    close CHILD_RDR; close CHILD_WTR;
    chomp($line = <PARENT_RDR>);
    print "Child Pid $$ just read this: `$line'\n";
    print PARENT_WTR "Child Pid $$ is sending this\n";
    close PARENT_RDR; close PARENT_WTR;
    exit;
 }
 # source: man perlipc

Or, more "elegant", use socketpair to create filehandles that can be used for both reading and writing:

 #!/usr/bin/perl -w
 # pipe2 - bidirectional communication using socketpair
 #   "the best ones always go both ways"
 
 use Socket;
 use IO::Handle;     # thousands of lines just for autoflush :-(
 # We say AF_UNIX because although *_LOCAL is the
 # POSIX 1003.1g form of the constant, many machines
 # still don't have it.
 socketpair(CHILD, PARENT, AF_UNIX, SOCK_STREAM, PF_UNSPEC)
 # AF_UNIX: unix address family (one machine, not internet protocol) 
 # SOCK_STREAM: make a tcp-like session (stream-based) 
 # PF_UNSPEC: no protocol family required for AF_UNIX
                          or  die "socketpair: $!";
 
 CHILD->autoflush(1);
 PARENT->autoflush(1);
 
 if ($pid = fork) {
    close PARENT;
    print CHILD "Parent Pid $$ is sending this\n";
    chomp($line = <CHILD>);
    print "Parent Pid $$ just read this: `$line'\n";
    close CHILD;
    waitpid($pid,0);
 } else {
    die "cannot fork: $!" unless defined $pid;
    close CHILD;
    chomp($line = <PARENT>);
    print "Child Pid $$ just read this: `$line'\n";
    print PARENT "Child Pid $$ is sending this\n";
    close PARENT;
    exit;
 } 
 # source: man perlipc

Step 3: understanding client-server programming

client: a process that needs a service.
server: a process that provides the service.
socket: the 'name' of a service, consisting of an IP address (of the machine) and a 'port number' (of the server process)
request: connect to a given socket, converse, get output, disconnect.

A simple time-of-day server

Consider

contents of perl_ipc/server0.pl...
#! /var/local/couch/bin/perl 
use strict;
BEGIN { $ENV{PATH} = '/usr/ucb:/bin' }
use Socket;
use Carp;
my $EOL = "\015\012";

sub logmsg { print "$0 $$: @_ at ", scalar localtime, "\n" }

my $port = shift || 2345;
my $proto = getprotobyname('tcp');

($port) = $port =~ /^(\d+)$/                        or die "invalid port";

socket(Server, PF_INET, SOCK_STREAM, $proto)        || die "socket: $!";
setsockopt(Server, SOL_SOCKET, SO_REUSEADDR,
				    pack("l", 1))   || die "setsockopt: $!";
bind(Server, sockaddr_in($port, INADDR_ANY))        || die "bind: $!";
listen(Server,SOMAXCONN)                            || die "listen: $!";

logmsg "server started on port $port";

my $paddr;

$SIG{CHLD} = \&REAPER;

for ( ; $paddr = accept(Client,Server); close Client) {
    my($port,$iaddr) = sockaddr_in($paddr);
    my $name = gethostbyaddr($iaddr,AF_INET);

    logmsg "connection from $name [",
	    inet_ntoa($iaddr), "]
	    at port $port";

    print Client "Hello there, $name, it's now ",
		    scalar localtime, $EOL;
}
# source: man perlipc

...end of perl_ipc/server0.pl

One talks to this via:

contents of perl_ipc/client0.pl...
#! /var/local/couch/bin/perl 
use strict;
use Socket;
my ($remote,$port, $iaddr, $paddr, $proto, $line);

$remote  = shift || 'localhost';
$port    = shift || 2345;  # random port
if ($port =~ /\D/) { $port = getservbyname($port, 'tcp') }
die "No port" unless $port;
$iaddr   = inet_aton($remote)               || die "no host: $remote"
;
$paddr   = sockaddr_in($port, $iaddr);

$proto   = getprotobyname('tcp');
socket(SOCK, PF_INET, SOCK_STREAM, $proto)  || die "socket: $!";
connect(SOCK, $paddr)    || die "connect: $!";
while (defined($line = <SOCK>)) {
    print $line;
}

close (SOCK)            || die "close: $!";
exit;
# source: man perlipc
...end of perl_ipc/client0.pl

Invoking the client produces:

contents of perl_ipc/client0.pl.out...
lin09{couch}72: client0.pl
Hello there, lin09, it's now Tue Apr  1 15:35:43 2003
lin09{couch}73: 
...end of perl_ipc/client0.pl.out

And the server responds:

contents of perl_ipc/server0.pl.out...
lin09{couch}64: server0.pl
server0.pl 20409: server started on port 2345 at Tue Apr  1 15:35:35 2003
server0.pl 20409: connection from lin09 [ 127.0.0.1 ]
            at port 1279 at Tue Apr  1 15:35:43 2003
...end of perl_ipc/server0.pl.out

Parts of a "server"

socket: create an internet-domain socket
```
 socket(Server, PF_INET, SOCK_STREAM, $proto);
```
- PF_INET: protocol-family: internet protocols.
- SOCK_STREAM: connection-oriented socket.
- $proto is numeric value of tcp in /etc/protocols
bind: associate this server process with the socket.
```
 bind(Server, sockaddr_in($port, INADDR_ANY)); 
```
- sockaddr_in($port,INADDR_ANY): accept connections to our port from any other machine and port.
listen: start listening for connections on the socket:
```
 listen(Server,SOMAXCONN); 
```
- SOMAXCONN: max number of simultaneous connections (queued).
accept: accept a particular connection:
```
 $paddr = accept(Client,Server);
```
- $paddr: address of Client.

Parts of a "client"

socket: create the client end of a socket.

 socket(SOCK, PF_INET, SOCK_STREAM, $proto);

connect: connect to a server:
```
 $paddr   = sockaddr_in($port, $iaddr);
 connect(SOCK, $paddr); 
```
- $paddr: combination of internet address and port.
- SOCK: a bi-directional filehandle connection to the server.

Multi-threading

Typical servers fork processes to deal with each request. Consider:

contents of perl_ipc/server1.pl...
#!/var/local/couch/bin/perl -Tw
use strict;
BEGIN { $ENV{PATH} = '/usr/ucb:/bin' }
use Socket;
use Carp;
my $EOL = "\015\012";

sub spawn;  # forward declaration
sub logmsg { print "$0 $$: @_ at ", scalar localtime, "\n" }

my $port = shift || 2345;
my $proto = getprotobyname('tcp');

($port) = $port =~ /^(\d+)$/                        or die "invalid port";

socket(Server, PF_INET, SOCK_STREAM, $proto)        || die "socket: $!";
setsockopt(Server, SOL_SOCKET, SO_REUSEADDR,
				    pack("l", 1))   || die "setsockopt: $!";
bind(Server, sockaddr_in($port, INADDR_ANY))        || die "bind: $!";
listen(Server,SOMAXCONN)                            || die "listen: $!";

logmsg "server started on port $port";

my $waitedpid = 0;
my $paddr;

use POSIX ":sys_wait_h";
sub REAPER {
    my $child;
    while (($waitedpid = waitpid(-1,WNOHANG)) > 0) {
	logmsg "reaped $waitedpid" . ($? ? " with exit $?" : '');
    }
    $SIG{CHLD} = \&REAPER;  # loathe sysV
}

$SIG{CHLD} = \&REAPER;

for ( $waitedpid = 0;
      ($paddr = accept(Client,Server)) || $waitedpid;
      $waitedpid = 0, close Client)
{
    next if $waitedpid and not $paddr;
    my($port,$iaddr) = sockaddr_in($paddr);
    my $name = gethostbyaddr($iaddr,AF_INET);

    logmsg "connection from $name [",
	    inet_ntoa($iaddr), "]
	    at port $port";

    spawn sub {
	$|=1;
	print "Hello there, $name, it's now ", scalar localtime, $EOL;
	exec '/usr/games/fortune'           # XXX: `wrong' line terminators
	    or confess "can't exec fortune: $!";
    };

}

sub spawn {
    my $coderef = shift;

    unless (@_ == 0 && $coderef && ref($coderef) eq 'CODE') {
	confess "usage: spawn CODEREF";
    }

    my $pid;
    if (!defined($pid = fork)) {
	logmsg "cannot fork: $!";
	return;
    } elsif ($pid) {
	logmsg "begat $pid";
	return; # I'm the parent
    }
    # else I'm the child -- go spawn

    open(STDIN,  "<&Client")   || die "can't dup client to stdin";
    open(STDOUT, ">&Client")   || die "can't dup client to stdout";
    ## open(STDERR, ">&STDOUT") || die "can't dup stdout to stderr";
    exit &$coderef();
}
# source: man perlipc 
...end of perl_ipc/server1.pl

One talks to this via the same client as before.

Invoking the client produces:

contents of perl_ipc/client1.pl.out...
lin09{couch}75: client0.pl
Hello there, lin09, it's now Tue Apr  1 15:36:56 2003
Higher education helps your earning capacity.  Ask any college professor.
lin09{couch}76: 
...end of perl_ipc/client1.pl.out

And the server reports:

contents of perl_ipc/server1.pl.out...
lin09{couch}66: server1.pl
server1.pl 20415: server started on port 2345 at Tue Apr  1 15:36:52 2003
server1.pl 20415: connection from lin09 [ 127.0.0.1 ]
            at port 1282 at Tue Apr  1 15:36:56 2003
server1.pl 20415: begat 20417 at Tue Apr  1 15:36:56 2003
server1.pl 20415: reaped 20417 at Tue Apr  1 15:36:56 2003
...end of perl_ipc/server1.pl.out

Object-oriented IPC

use IO::Socket : allows object-oriented calls that are otherwise identical to the ones before.

Here's a simple server:

contents of perl_ipc/server2.pl...
#!/var/local/couch/bin/perl -w
use IO::Socket;
use Net::hostent;              # for OO version of gethostbyaddr

$PORT = 9000;                  # pick something not in use
			       # >1024, not listed in /etc/services 

# recipe 

$server = IO::Socket::INET->new( Proto     => 'tcp',
                                 LocalPort => $PORT,
                                 Listen    => SOMAXCONN,
                                 Reuse     => 1);

die "can't setup server" unless $server;
print "[Server $0 accepting clients]\n";

# allow a client to connect 
while ($client = $server->accept()) {
   # $client is an I/O device that I can read and write 
   $client->autoflush(1);	# set character buffering: 
				# characters are sent when printed. 

   print $client "Welcome to $0; type help for command list.\n";
   # print a host name you connected to 
   $hostinfo = gethostbyaddr($client->peeraddr);
   printf "[Connect from %s]\n", $hostinfo->name || $client->peerhost;

   # read commands and process !
   print $client "Command? ";
   while ( <$client>) {
     next unless /\S/;       # blank line
     if    (/quit|exit/i)    { last;                                     }
     elsif (/date|time/i)    { printf $client "%s\n", scalar localtime;  }
     elsif (/who/i )         { print  $client `who 2>&1`;                }
     elsif (/cookie/i )      { print  $client `/usr/games/fortune 2>&1`; }
     elsif (/motd/i )        { print  $client `cat /etc/motd 2>&1`;      }
     else {
       print $client "Commands: quit date who cookie motd\n";
     }
   } continue {
      print $client "Command? ";
   }
   close $client;
}
# source: perlipc
...end of perl_ipc/server2.pl

And here's a sample interaction with that server:

 blackhole{couch}108: telnet lin09 9000
 Trying 10.1.2.241...
 Connected to lin09.eecs.tufts.edu.
 Escape character is '^]'.
 Welcome to server2.pl; type help for command list.
 Command? ho
 Commands: quit date who cookie motd
 Command? date
 Tue Mar 25 16:24:25 2003
 Command? who
 couch    pts/0    Mar 25 09:26 (blackhole.eecs.tufts.edu)
 mtoia01  pts/1    Mar 25 11:05 (resnet148-135.medford.tufts.edu)
 nsmith   pts/2    Mar 25 12:28 (resnet150-47.medford.tufts.edu)
 jco      pts/3    Mar 25 15:24 (arwen.eecs.tufts.edu)
 Command? cookie
 Do you have exactly what I want in a plaid poindexter bar bat??
 Command? motd
 Command? quit
 blackhole{couch}109:

Note that I was able to contact this server via telnet, with no special handling required. If it's up, all its information is publicly available to anyone at all.

A simple locking server

Goal: make sure two processes don't try to do something to the same resource at the same time.

One solution: simple locking server.

contents of perl_ipc/server3.pl...
#!/var/local/couch/bin/perl -w

# VERY SIMPLE SERVER keeps track of a globally accessible associative
# array %locked, and tells ALL CGI's whether something is locked or not. 

use IO::Socket;		       # in order to open listening port
use Net::hostent;              # for OO version of gethostbyaddr

$PORT = 9000;                  # pick something not in use

$server = IO::Socket::INET->new( Proto     => 'tcp',
                                 LocalPort => $PORT,
                                 Listen    => SOMAXCONN,
                                 Reuse     => 1);

die "can't setup server" unless $server;
print "[Server $0 accepting clients]\n";

while ($client = $server->accept()) {
   $client->autoflush(1);
   $hostinfo = gethostbyaddr($client->peeraddr);
   printf "[Connect from %s]\n", $hostinfo->name || $client->peerhost;
   $command = <$client>; chomp $command; 
   print "[command='$command']\n"; 
   if ($command =~ /^lock (.*)$/) { 
	$file = $1; 
	if (! $locked{$file}) { 
	    $locked{$file} = 1; 
	    print "[Locked file $file]\n"; 
	    print $client "yes\n"; 
	} else { 
	    print "[file $file already locked]\n"; 
	    print $client "no\n"; 
	} 
   } elsif ($command =~ /^unlock (.*)$/) { 
	$file = $1; 
	if ($locked{$file}) { 
	    delete $locked{$file}; 
	    printf "[Unlocked file $file]\n"; 
	    print $client "yes\n"; 
	} else { 
	    printf "[file $file already unlocked]\n"; 
	    print $client "no\n"; 
	} 
   } else {
       print $client "no\n";
   }
   close $client;
}
# source: man perlipc
...end of perl_ipc/server3.pl

Call this via:

contents of perl_ipc/client3.pl...
#!/var/local/couch/bin/perl 
use IO::Socket;

$host = shift(@ARGV) || "lin09";
$port = shift(@ARGV) || 9000; 

sub lock { 
    my $file = shift; 
    my $host = shift; 
    my $port = shift; 
    $remote = IO::Socket::INET->new( Proto     => "tcp",
				     PeerAddr  => $host,
				     PeerPort  => $port,
				   );
    unless ($remote) { die "cannot connect to lock daemon on $host" }
    $remote->autoflush(1);
    print $remote "lock $file\n";
    my $response = ''; 
    while ( <$remote> ) { $response .= $_; }
    close $remote;
    return 1 if ($response =~ /^yes/); 
    return 0; 
}

sub unlock { 
    my $file = shift; 
    my $host = shift; 
    my $port = shift; 
    $remote = IO::Socket::INET->new( Proto     => "tcp",
				     PeerAddr  => $host,
				     PeerPort  => $port,
				   );
    unless ($remote) { die "cannot connect to lock daemon on $host" }
    $remote->autoflush(1);
    print $remote "unlock $file\n";
    my $response = ''; 
    while ( <$remote> ) { $response .= $_; }
    close $remote;
    return 1 if ($response =~ /^yes/); 
    return 0; 
} 

print "foo locked? " . &lock('foo',$host,$port) . "\n"; 
print "foo locked? " . &lock('foo',$host,$port) . "\n"; 
print "foo unlocked? " . &unlock('foo',$host,$port) . "\n"; 
print "foo unlocked? " . &unlock('foo',$host,$port) . "\n"; 
# source: comp20 notes 
...end of perl_ipc/client3.pl

And the server prints:

contents of perl_ipc/server3.pl.out...
[Server server3.pl accepting clients]
[Connect from lin08.eecs.tufts.edu]
[command='lock foo']
[Locked file foo]
[Connect from lin08.eecs.tufts.edu]
[command='lock foo']
[file foo already locked]
[Connect from lin08.eecs.tufts.edu]
[command='unlock foo']
[Unlocked file foo]
[Connect from lin08.eecs.tufts.edu]
[command='unlock foo']
[file foo already unlocked]
...end of perl_ipc/server3.pl.out

While the client prints:

contents of perl_ipc/client3.pl.out...
foo locked? 1
foo locked? 0
foo unlocked? 1
foo unlocked? 0
...end of perl_ipc/client3.pl.out

Monstrous hack: a web server in perl

Consider:

contents of perl_ipc/server5.pl...
#!/var/local/couch/bin/perl 

# as a hack, the world's simplest web server

$rootdir = "/g/150PPP/public_html/"; 	# broadcast couch's files. 
$PORT = 9000;              	# pick something not in use

use CGI; 
use CGI::Carp "fatalsToBrowser"; 

use IO::Socket;		       # basic server module 
use Net::hostent;              # for OO version of gethostbyaddr

$server = IO::Socket::INET->new( Proto     => 'tcp',
                                 LocalPort => $PORT,
                                 Listen    => SOMAXCONN,
                                 Reuse     => 1);

die "can't setup server" unless $server;
print "[Server $0 accepting clients]\n";

# accept web service requests!

while ($client = $server->accept()) {
   $client->autoflush(1);	# don't buffer
   $hostinfo = gethostbyaddr($client->peeraddr);
   printf "[Connect from %s]\n", $hostinfo->name || $client->peerhost;
   # get a command
   $command = <$client>; 
   # if it's a GET, do it 
   if ($command =~ /GET (.*) HTTP\/1.0/i) {  
      $file = "$rootdir$1"; 	# find absolute pathname of file. 
      print "[COMMAND = GET $file]\n"; 
      if ($file =~ /.html$/ and -r $file) { 	# check that it's html
	   open(FILE, "<$file") or die "can't read $file : $!"; 
  	   print $client "Content-type: text/html\n\n"; 
	   while (<FILE>) { print $client $_; } 
	   close (FILE); 
      } else { 
          print $client <<EOF
Content-type: text/html

<html><body>
<h1>Oops: the file $file wasn't found on this server</h1>
</body></html>
EOF
;
      } 
   } else {
       print $client <<EOF
Content-type: text/html

<html><body>
<h1>Oops: the file $file wasn't found on this server</h1>
</body></html>
EOF
;

   }
   close $client;
}
# source: comp20 notes 

...end of perl_ipc/server5.pl

This is a fully functional (though quite limited) web server in perl.

Getting real:

To write a realistic server, lots of things must come together:
- dissociation from controlling terminal (daemonize).
- logging via Syslog (printing won't work once there's no controlling terminal!!!)
- taint mode for security.
- forking/multithreading if appropriate.
- protection from DDOS attacks.

A realistic server

problem: NIS+ authentication requires root access; need to authenticate people without being root.
solution: daemon runs as root, does authentication.

Consider:

contents of perl_ipc/webauth...
#!/var/local/couch/bin/perl
use IO::Socket;		# for service loop
use Net::hostent;       # for OO version of gethostbyaddr
use Sys::Syslog;        # built into Perl 5.8.0 
use Authen::PAM; 	# only works as keylogin'd root. 

use strict; 
no strict "refs"; 

# $main::opt_debug = 1; 	# whether debugging is on or not. 
$main::opt_failures = 3;	# number of login trials
$main::opt_minutes = 5; 	# number of minutes to wait after failing 
				# $main::opt_trials times

$main::failures = {}; 		# number of failures per user 
$main::nextlogin = {}; 		# next time user can try to login

# open system log for error messages. 
openlog "webauth", "pid", "daemon";

$main::port = 9000;            # pick something not in use
			       # >1024, not listed in /etc/services 
$main::timeout = 10; 	       # how long to keep a connection open

if (! $main::opt_debug) { 
    exit (0) if fork(); 		# dissociate from controlling terminal
} 

$SIG{'CHLD'} = \&reaper; 


# recipe 
$main::server = IO::Socket::INET->new( Proto     => 'tcp',
                                 LocalPort => $main::port,
                                 Listen    => SOMAXCONN,
                                 Reuse     => 1);

&shutdie("can't set up server") unless $main::server;

&debug("Server $0 accepting clients\n"); 
syslog "info", "Server $0 accepting clients"; 

# allow a client to connect 
while ($main::client = $main::server->accept()) {
    # $main::client is an I/O device that I can read and write 
    $main::client->autoflush(1);	# set character buffering: 
				# characters are sent when printed. 

    # print $main::client "Welcome to $0; type help for command list.\n";

    # print a host name you connected to 
    my $hostinfo = gethostbyaddr($main::client->peeraddr);
    if (inet_ntoa($hostinfo->addr) ne '127.0.0.1') { 
        syslog "info", "rejecting connect from %s:%d", 
	    $main::client->peerhost,$main::client->peerport; 
	close $main::client; 
        next; 
    } else { 
        syslog "info", "accepting connect from %s:%d",
	    $main::client->peerhost,$main::client->peerport;
    } 

    # read commands and process !
    # do this in an eval so you can time out for frozen connections. 
    eval {
	# print $main::client "Command? ";
	local $SIG{ALRM} = sub { die "alarm\n" };       # NB \n required
	alarm $main::timeout;
	my $input = <$main::client>; 
	chomp $input;
	&debug("received query '$input'\n"); 
	if ($input =~ /^\s*$/) {        # blank line
	    my $ret = "blank login name is unacceptable"; 
	    &debug("clause 1: $ret\n"); 
	    syslog "err", $ret; 
	    print $main::client $ret; 
	} elsif ($input =~ /^([^ ]*) (.*$)/) { 
	    my $username = $1; 
	    my $passwd = $2; 
	    &debug("clause 2: user=$username passwd=$passwd"
	        . " failures=$main::failures->{$username}"); 
            if (defined $main::nextlogin->{$username}) { 
		&debug(" nextlogin=".localtime($main::nextlogin->{$username})); 
            } 
	    &debug("\n"); 
	    my $ret = &checkUnixPassword($username,$passwd); 
	    delete $main::nextlogin->{$username} 
		if defined $main::nextlogin->{$username} 
		 && $main::nextlogin->{$username}<=time(); 
	    if (defined $main::nextlogin->{$username} 
             && $main::nextlogin->{$username}>time()) { 
		my $info = "$username, too many login failures; please wait till " 
                     . localtime($main::nextlogin->{$username}) 
                     . " to try again."; 
	        &debug("$info\n"); 	
		syslog("info", $info); 
	        print $main::client "$info\n"; 
	    } elsif (! defined $ret) { 
		delete $main::failures->{$username}; 
		&debug("user $username successfully authenticated\n"); 
		syslog "info", "user $username successfully authenticated";
		print $main::client "\n"; 
	    } else { 
		$main::failures->{$username}++; 
		if ($main::failures->{$username}>=$main::opt_failures) { 
		    my $info = "user $username: $main::failures->{$username} "
                          ."login failures";
	            &debug("$info\n"); 
		    syslog "info", $info;
		    $main::nextlogin->{$username} = time()
			+$main::opt_minutes*60; 
		    delete $main::failures->{$username}; 
		} 
		&debug("$ret\n"); 
		syslog "info", $ret;
		print $main::client "$ret\n"; 
	    } 
	} else { 
	    my $username = $input; 
	    my $ret = &checkUnixLogin($username); 
	    if (! defined $ret) { 
		&debug("user $username exists"); 
		syslog "info", "user $username exists";
		print $main::client "\n"; 
	    } else { 
		&debug($ret); 
		syslog "info", $ret;
		print $main::client "$ret\n"; 
	    } 
	} 
	alarm 0; 
    } ; 
    if ($@ && $@ ne "alarm\n") { 	# propogate errors 
        &debug($@."\n"); 
        syslog "err", $@; 
    } elsif ($@) { 			# announce timeout
        &debug("timed out: breaking connection to %s:%d", 
            $main::client->peerhost, $main::client->peerport); 
        syslog "warning", "timed out: breaking connection to %s:%d", 
            $main::client->peerhost, $main::client->peerport; 
    } 
    close $main::client;
}

# returns undef if password correct, error string if incorrect
sub checkUnixPassword { 
    my $username = shift; 
    local $main::passwd = shift; 
    my $pamh; 
    my $res = pam_start("sshd", $username, \&main::passwdWrapper, $pamh);
    if ($res == 0) { 
	my $out = pam_authenticate($pamh, &PAM_SILENT); 
	if ($out == 0) { 
	    my $out = pam_acct_mgmt($pamh, &PAM_SILENT); 
	    pam_end($pamh, 0);
	    return "password for '$username' expired" if $out == &PAM_NEW_AUTHTOK_REQD; 
	    return "account for '$username' disabled" if $out == &PAM_ACCT_EXPIRED; 
	    return undef;
	} else { 
	    pam_end($pamh, 0);
	    return undef if $out == 0; 
	    return "user '$username' unknown" if $out == &PAM_USER_UNKNOWN; 
	    return "insufficient credentials for web server; notify instructor" if $out == &PAM_CRED_INSUFFICIENT; 
	    return "authentication information unavailable; notify instructor" if $out == &PAM_AUTHINFO_UNAVAIL; 
	    return "max tries for '$username' reached" if $out == &PAM_MAXTRIES; 
	    return "incorrect password for '$username'" if $out == &PAM_AUTH_ERR; 
	    return "unknown authentication failure ($out) for '$username'"; 
	} 
    } else { 
	return "authentication service temporarily unavailable"; 
    } 
} 

####
# check that login is valid 
####
sub checkUnixLogin { 
    my $username = shift; 
    local $main::passwd = ""; 
    my $pamh; 
    my $res = pam_start("sshd", $username, \&main::passwdWrapper, $pamh);
    if ($res == 0) { 
	my $out = pam_authenticate($pamh, &PAM_SILENT); 
	pam_end($pamh, 0);
	return "user '$username' unknown" if $out == &PAM_USER_UNKNOWN; 
	return undef; 
    } else { 
	return "authentication service temporarily unavailable"; 
    } 
} 

# this callback passes the password under the table to PAM
# this is necessary because of PAM's callback assumptions
sub passwdWrapper {
    my @res;
    while ( @_ ) {
	my $msg_type = shift;
	my $msg = shift;
	if ($msg_type == 1) { 
	    my $ans = $main::passwd; 
	    push @res, (0,$ans);
	} else { 
	    push @res, (0,undef); 
	} 
	push @res, &PAM_SUCCESS();
    } 
    return @res;
}

####
# utility routines 
####

sub debug { 			# print debugging info if flag is set. 
    printf STDERR @_ if $main::opt_debug; 
} 

sub shutdie { 			# what to do if killed. 
   my $mess = shift; 
   &debug($mess); 		
   syslog "err", $mess; 
   closelog;
   exit 1; 
} 

sub reaper {			# reap child process
    my $waitedpid = wait;
    $SIG{'CHLD'} = \&reaper;  # loathe sysV
    # syslog "info", ("reaped $waitedpid" . ($? ? " with exit $?" : '')); 
}

1;
...end of perl_ipc/webauth

This is one heck of a complicated daemon.

Attributes:
- single-threaded (by design; low-impact role)
- uses syslog for both debugging and reporting.
- doesn't allow frequent retries to prohibit 'cracking' passwords.
- uses Portable Authentication Modules (PAM) to determine whether password is valid.

Inside `webauth`

first, we need to insure that with terminal dissociated, our error messages go somewhere:

 sub shutdie {                   # what to do if killed. 
    my $mess = shift; 
    &debug($mess);               
    syslog "err", $mess; 
    closelog;
    exit 1; 
 }

and then we call shutdie rather than die.

next, we open a garden-variety TCP server.

Then, we enter an eval loop and accept requests from the server:

 eval { 
   local $SIG{ALRM} = sub { die "alarm\n" };       # NB \n required
   alarm $main::timeout;
   my $input = <$main::client>; 
   # ...stuff omitted...
   if ($input =~ /^([^ ]*) (.*$)/) { 
      my $username = $1; 
      my $passwd = $2; 
      # ...stuff omitted...
      my $ret = &checkUnixPassword($username,$passwd); 
      print $main::client $ret; 
   } 
   alarm 0; 
 }

Note that we set an alarm in case the PAM transaction in checkUnixPassword fails!

Finally, the guts: call PAM to verify a password:

use dynamic scoping to make password available as callback value!
```
 my $username = shift; 
 local $main::passwd = shift; 
```

 my $res = pam_start("sshd", $username, \&main::passwdWrapper, $pamh);

call PAM to authenticate:

 my $out = pam_authenticate($pamh, &PAM_SILENT);

which implicitly calls passwdWrapper

 sub passwdWrapper {
     my @res;
     while ( @_ ) {
         my $msg_type = shift;
         my $msg = shift;
         if ($msg_type == 1) { # password request
             my $ans = $main::passwd; 
             push @res, (0,$ans);
         } else {              # unknown request
             push @res, (0,undef); 
         } 
         push @res, &PAM_SUCCESS(); # array terminator
     } 
     return @res;
 }

Finally, we need to ensure that our routine can't be used by abusers to crack our password file (safety):

 delete $main::nextlogin->{$username} 
     if defined $main::nextlogin->{$username} 
      && $main::nextlogin->{$username}<=time(); 
 if (defined $main::nextlogin->{$username} 
  && $main::nextlogin->{$username}>time()) { 
     my $info = "$username, too many login failures; please wait till " 
        . localtime($main::nextlogin->{$username}) 
        . " to try again."; 
     syslog("info", $info); 
     print $main::client "$info\n"; 
 }

Caveat on daemon writing

constructing the framework of a daemon is easy.
writing a safe daemon is hard.
must handle all potential difficulties.

lecture in color

downloaded on Oct-12-2008 11:04:22 AM,
was last modified on Dec-31-1969 07:00:00 PM.
All lecture note content is copyright 2003 by
Alva L. Couch, Computer Science, Tufts University
(couch at cs dot tufts dot edu)

Case study: IPC

Inter-process communication

Parts of IPC

First, the basics of processes

Signals

Responding to signals

Signal Handler caveats

Responding to CHLD

Special handlers:

Process groups:

Handling HUP for daemons

Creating a daemon

Step 2: understanding advanced file I/O

Fancy opens

What's going on inside |- and -|

Burning the candle at both ends

Recall (from last time)

What's happening in fancy IPC

Step 3: understanding client-server programming

A simple time-of-day server

Parts of a "server"

Parts of a "client"

Multi-threading

Object-oriented IPC

A simple locking server

Monstrous hack: a web server in perl

Getting real:

A realistic server

Inside webauth

Caveat on daemon writing

Responding to `CHLD`

Handling `HUP` for daemons

What's going on inside `|-` and `-|`

Inside `webauth`