The Parts Server Code

#!/usr/local/bin/perl/perl
# $Id: familyd,v 1.4 1996/07/18 19:27:05 fparts Exp $
# add server directory to INCLUDE path.
unshift(@INC, '/usr2/cuser/fparts/server/');
require 'sys/socket.ph';
require 'sys/errno.ph';
require 'sys/wait.ph';
require 'sys/ipc.ph';

# spawn child to be the server master process and exit
# (automatic background execution)
fork && exit;

# customizations
$logfile = "/usr2/cuser/fparts/server/server-log-exp";
$pidfile = "/usr2/cuser/fparts/server/server-pid-exp";
$maintainer = "gmm7689@sudcv91.ed.ray.com";
$port = 4000;
$IPC_KEY = 4000;  # semaphore and queue number
$display = "localhost:1.0";
# end customizations

# store server PID in $pidfile, after making sure another isn't running.

# make the file writable
chmod(0640, $pidfile);

# open the file for read/write
open(PIDFILE, "+< $pidfile") || open(PIDFILE, "+> $pidfile") || 
  die "Unable to open $pidfile: $!";

# check if a PID is in the file
if(($_ = <PIDFILE>) > 0)  
  {
    # lose the newline
    chop;

    # if the process is running, ps will return two lines, else one line.
    (`ps $_ | wc -l` == 2) && 
        die("\n$0: The server is already running, exiting.\n");
  }
# return to the beginning of the file
seek(PIDFILE, 0, 0);
# write our PID
print PIDFILE "$$\n";
# truncate the file to the length of our PID plus newline (current position)
truncate(PIDFILE, tell(PIDFILE));
# close the file
close(PIDFILE);
# make it read-only
chmod(0440, $pidfile);

# identify this as the master process (via ps)
$0 = "Family of Parts Server Master";

# change the DISPLAY for this process to the Xvfb server
$ENV{'DISPLAY'} = $display;

# create System V IPC queue to receive log messages
$queue = msgget($IPC_KEY, 0600 | &IPC_CREAT);

# reset the server log on a SIGHUP.  (Useful for nightly maintenance.)
$SIG{'HUP'} = 'reset_log';

# if we were able to create a queue, spawn the logger process
if(defined($queue)) 
  {
    if($master = fork) {
      # pass TERM to server master so it can clean up.
      $SIG{'TERM'} = 'pass_sigterm';

      # identify this as the logger process (via ps)
      $0 = "Family of Parts Server Logger";
      # create a filehandle to the server log and select it
      (open(LOGFILE, ">>$logfile") && select(LOGFILE)) ||
      warn "Unable to open server log.\n";

      # force a flush after every write or print
      $| = 1;

      # record that a logger started
      print "$$:".&t.": Logger started.\n";
      print "$$:".&t.": Logger spawned master process $master.\n";

      # receive and save messages forever
      while(1)
        {
          msgrcv($queue, $message, 1024, 0, 0);
          print $message;
        }
    
      exit 0;
    }

    # $logger is parent process
    $logger = getppid; 
  }
else # no queue, so individual processes will do their own logging 
  {
    $error = $!;
    # create a filehandle to the server log and select it
    (open(LOGFILE, ">>$logfile") && select(LOGFILE)) ||
    warn "Unable to open server log.\n";

    # force a flush after every write or print
    $| = 1;

    # record the failure
    print "$$:".&t.": Unable to create logger queue. $error\n";
  }

# create System V IPC semaphore for the children, to prevent multiple
# children running CADDS at the same time.
$semaphore = semget($IPC_KEY, 1, 0600 | &IPC_CREAT );

if(defined($semaphore))
  {
    # remove semaphore locking on SIGUSR1 (signaled on a semaphore error.)
    # this is to (hopefully) prevent children from hanging forever
    # because of a semaphore error.
    $SIG{'USR1'} = 'sem_remove';
  }
else
  {
    $error = $!;
    &report("semaphore: $!.  Continuing without semaphores.\n");

    # report error to proper person
    open(MAIL, "|/usr/ucb/mail -s 'Generate Server Error' $maintainer");
    print MAIL "Semaphore error.  Locking disabled.\n";
    print MAIL "$error\n";
    close(MAIL);
  }

# report server master process
&report("Server process master\n");

# get $proto necessary for socket()
($name, $aliases, $proto) = getprotobyname('tcp');

# build an internet domain port address
$sockaddr = 'S n a4 x8';
$thisport = pack($sockaddr, &AF_INET, $port, "\0\0\0\0");

# create a socket in the internet domain, of type stream, using tcp
unless(socket(S, &AF_INET, &SOCK_STREAM, $proto))
  {
    $error = $!;
    &report("socket: $!\n");
    kill 'TERM', $logger;
    die "socket: $error";
  }
&report("socket ok\n");

# bind the socket to the port
unless(bind(S, $thisport))
  {
    $error = $!;
    &report("bind: $!\n");
    kill 'TERM', $logger;
    die "bind: $error";
  }
&report("bind ok\n");

# listen to the socket
unless(listen(S, 5))
  {
    $error = $!;
    &report("listen: $!\n");
    kill 'TERM', $logger;
    die "listen: $error";
  }
&report("listen ok\n");

# add subroutine to shutdown socket and server on a SIGTERM
$SIG{'TERM'} = 'server_exit';

# clean up after exited child on a USR2 signal.
$SIG{'USR2'} = 'cleanup';

# force a flush after every write or print on NS and S
select(NS); $| = 1; 
select(S); $| = 1; 
unless($queue){select(LOGFILE);}

$con = 0;

# loop forever, keeping track of number of connections
while(1)
  {
    $con++;
    &report("Listening for connect $con.\n");
 
    # wait for a connection, accept only returns on a connection or an
    # error
ACCEPT:
    unless($addr = accept(NS, S)) 
      {    
        # set $dont_log to 1 when handling HUP and USR2 signals
	if($dont_log) { $dont_log = 0; }
        else
	  {
            # report accept failure
	    &report("accept: $!\n");
          }
          
        goto ACCEPT;
      }

    &report("accept ok\n");

    # spawn a child to deal with connection
    fork && next;
    
    # get pid of master process
    $master = getppid;

    # ignore TERM signals
    $SIG{'TERM'} = 'IGNORE';

    # identify this child (viewed by ps)
    $0 = "Family of Parts Server Connection $con";
  
    # child that actually handles the connection
    print "$master:".&t.": Child $$ forked.\n";

    # get remote hostname, IP, and remote port from connection
    ($af, $port, $inetaddr) = unpack($sockaddr, $addr);
    ($name) = gethostbyaddr($inetaddr, &AF_INET);
    $inetaddr = join('.', unpack('C4', $inetaddr));

    # report connection with hostname, IP and remote port
    &report("Connect from $name ($inetaddr) port $port.\n");

    # do something with the connection.
    $status = &handle_connection();

    print NS "$status\n";
    # close the connection
    close(NS);

    # log that we've closed the connection
    &report("Connection $con closed.\n");

    # log that we're exiting, and exit
    &report("Exiting with generate status $status.\n");

    unlink("$lockfile$$", "$tmp_message_log", "$tmp_output_log",
           "$tmp_cadds_script");

    # tell the master process to clean up after us
    kill 'USR2', $master;

    exit 0;
  }

exit;

# end of main routine

# clean up after an exited child, don't log the accept failure
sub cleanup { 
  $dont_log = 1;
  sleep(5);  # sleep long enough for the child to exit
  while($status = waitpid(-1, &WNOHANG)){}
}
  
sub server_exit {
  # shut down the socket, (no more connections)
  shutdown(S, 2);

  &report("Waiting for children to exit.\n");

  # stop accepting USR2 cleanup requests;
  $SIG{'USR2'} = 'IGNORE';

  # wait returns -1 when no children are left.
  while(wait != -1){}

  &report("Children exited.  Killing logger and exiting.\n");

  # give logger time to record message
  sleep(5);

  # kill the logger, in case logger didn't send the TERM
  if($queue){ kill 'TERM', $logger; }

  unlink($pidfile);
  exit 0;
}

# pass TERM to master from logger, collect queue messages while waiting
# for master to exit, close the log, and exit.
sub pass_sigterm {
  # ignore any more TERM signals
  $SIG{'TERM'} = 'IGNORE';

  # record that we received the signal and pass it along.
  print "$$:".&t.": Logger received TERM, passing to master.\n";
  kill 'TERM', $master; 

  # record messages while waiting for master to exit
  while(waitpid($master, &WNOHANG) == 0)
    {
      if(msgrcv($queue, $message, 1024, 0, &IPC_NOWAIT)) { print $message; }
    }

  # log any remaining messages
  while(msgrcv($queue, $message, 1024, 0, 0)) { print $message; }

  # log that we're exiting, close the log, and exit
  print "$$:".&t.": Logger exiting.\n";
  close(LOGFILE);
  exit 0;
}

sub reset_log {
  truncate(LOGFILE, 0);
  seek(LOGFILE, 0, 0);
  print "$$:".&t.": Logfile restarted.\n";

  # have to clear out $message or it will get recorded in the new log.
  $message = "";

  # set $log_reset to 1 so accept failure isn't recorded in the new
  # log.
  $log_reset = 1;
}

# returns <day of year>:hh:mm.ss
# for time stamp of log entries.
sub t {
  ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday) = localtime();
  $date = sprintf("%03d:%02d:%02d.%02d", $yday, $hour, $min, $sec);
}

# semaphore error, so don't use it anymore
sub sem_remove { undef($semaphore); }

sub report {
  local($report) = @_;
  $message = "$$:".&t.": $report";

  # if we are using a queue and logger, send the message to the queue,
  # else print it to the logfile.
  if(defined($queue)) {
    msgsnd($queue, $message, 0); }
  else {
    print $message; }
}

# return status:
# 0: success
# 1: failure
# 2: aborted because member directory exists. (if part exists, CADDS
# hangs because it asks "Part exists.  Overwrite?" in a dialog)
sub handle_connection
{
  # create names for output log and CADDS script
  $tmp_output_log = "/tmp/family-parts.$$.out";
  $tmp_cadds_script = "/tmp/family-parts.$$.csh";

  # create name for message file, in Unix and CADDS formats
  $tmp_message_log = "/tmp/family-parts.$$.mes";
  $message_log = "=tmp.family-parts@$$";

  # remove any existing files, start new ones
  open(OUT, ">$tmp_message_log");
  close(OUT);
  open(OUT, ">$tmp_output_log");

  # get request to generate parts
  chop($_ = <NS>);
  ($master, $member, $directory) = split;

  # report request to output log and server log
  print OUT "Request: $master $member $directory\n";
  &report("Request: $master $member $directory\n");

  unless($directory =~ /\w/)
    { 
      # bad arguments, report error to proper person
      open(MAIL, "|/usr/ucb/mail -s 'Generate Server Error' $maintainer");
      print MAIL "Invalid Input Received: $master $member $directory";
      close(MAIL);

      return(1);
    }

  # build the name of the directory that will hold the parts
  ($part_dir = "$directory-family/$member") =~ "/(.*)/\L\1\E/";

  # check to see if it exists.
  if(-e $part_dir)
    {
      print OUT "Directory for member part exists.\n";
      &report("Directory for member part exists.\n");
      close(OUT);

      # report error to proper person
      system("cat $tmp_output_log | ".
             "/usr/ucb/mail -s 'Generate Server Error' $maintainer");

      return(2);
    }

  close(OUT);

  # find the users .caddsrc file
  if(-f "$ENV{'HOME'}/.caddsrc") 
    { 
      $caddsrc = "$ENV{'HOME'}/.caddsrc"; 
    }
  elsif(-f "/usr/apl/cadds/scripts/templates/.caddsrc") 
    {
      $caddsrc = "/usr/apl/cadds/scripts/templates/.caddsrc"; 
    }
  else
    { 
      # report error to proper person
      open(MAIL, "|/usr/ucb/mail -s 'Generate Server Error' $maintainer");
      print MAIL "File Error.  Unable to find a .caddsrc\n";
      print MAIL "$!\n";
      close(MAIL);
      &report("Warning: NO .caddsrc file found"); 
    }

  # Read the local file if one exists
  if(-f "$ENV{'HOME'}/.caddsrc-local") 
    { 
      $caddsrc .= " $ENV{'HOME'}/.caddsrc-local";
    }

  unless(open(SCRIPT, ">$tmp_cadds_script"))
    {  
      &report("Unable to write script.\n");
      
      # report error to proper person
      open(MAIL, "|/usr/ucb/mail -s 'Generate Server Error' $maintainer");
      print MAIL "File Error.  Unable to write script file.\n";
      print MAIL "$!\n";
      close(MAIL);
      return(1);
    }

  # make sure no parts or assemblies are read into the LDM
  # run cadds, -cron keeps windows from being mapped, -ldm starts in ldm,
  # passing a command to read the command file
  # -cron removed so windows will show up in an xwud of the Xserver image
  $cadds_command =  "#!/bin/csh -f
source $caddsrc
setenv CV_DB_PARTLISTLIMIT 0
setenv CADDSASSEMBLYLISTLIMIT 0
/usr/apl/cadds/scripts/cadds5 -ldm << EOF >>& $tmp_output_log
Write Message Append name $message_log
Generate Family Filename $master Member $member
Exit Cadds
EOF
";

  print SCRIPT $cadds_command;
  close(SCRIPT);
  chmod(0700, "$tmp_cadds_script");

  # semaphore wait and set
  if(defined($semaphore))
    {
      # wait for semaphore to be zero
      $opstring = pack("sss", 0, 0, 0);
      # Increment the semaphore count
      $opstring .= pack("sss", 0, 1, 0);
      unless(semop($semaphore, $opstring))
        {
	  $error = $!;
          &report("semaphore: $!.  Continuing without semaphores.\n");
	  undef($semaphore);
	  kill 'USR1', getppid, getpgrp;

          # report error to proper person
          open(MAIL, "|/usr/ucb/mail -s 'Generate Server Error' $maintainer");
          print MAIL "Semaphore error.  Locking disabled.\n";
	  print MAIL "$error\n";
          close(MAIL);
        }
      $semset = 1;
    }

  system("$tmp_cadds_script");

  # semaphore remove
  if(defined($semaphore))
    {
      # Decrement the semaphore count
      $opstring = pack("sss", 0, -1, 0);
      unless(semop($semaphore, $opstring))
        {
          $error = $!;
          &report("semaphore: $!.  Continuing without semaphores.\n");
	  undef($semaphore);
	  kill 'USR1', getppid, getpgrp;

          # report error to proper person
          open(MAIL, "|/usr/ucb/mail -s 'Generate Server Error' $maintainer");
          print MAIL "Semaphore error.  Locking disabled.\n";
	  print MAIL "$error\n";
          close(MAIL);
        }
      $semset = 0;
    }

  # look for string in log file indicating success, count how many times it
  # occurs.  If it doesn't occur, generation failed.
  if(`grep -c '1 family member parts filed' $tmp_message_log` == 0) 
    {
      &report("Generation failed.\n");

      # generation failed, report error to proper person
      system("cat $tmp_output_log $tmp_message_log | ".
	     "/usr/ucb/mail -s 'Generate Member Failure'".
	     $maintainer);
      
      return(1);
    }
  
  &report("Generation successful.\n");
  
  $member =~ s/(.*)/\L\1\E/;

  # set the permissions on the -family directory and all part
  # directories everyone can read or write in the part directory,
  # but not delete any files they don't own.  This is necessary
  # for creation of lock and temp files when activating a part, as
  # well as tvf's. 
  chmod(0755, "$directory-family");
  chmod(01775, <$directory-family/*>);
  
  # create the vp_links directory
  mkdir("$directory-family/$member/vp_links", 0);

  # set the permissions on the part files
  chmod(0444, <$directory-family/$member/*>);
  chmod(01775, "$directory-family/$member/vp_links");

  return(0);
}

Last Modified: Wed Aug 28 14:41:29 EDT 1996