#!/usr/bin/perl -w
#
# OSMIC (Open Structure for Media InterConnection) Server
#
# Originally coded by Ken'ichi Unnai <cloud@xanadu.net>, 1988
# Substantially rewritten and extended by Bek Oberin <gossamer@xanadu.net>
#
# OSMIC is a part of Ted Nelson's Xanadu project, see
# <URL:http://www.xanadu.net/> for details.
#
# The webpage for OSMIC is:
# <URL:http://www.xanadu.net/OSMIC/>.
#
# $Log: server.pl,v $
# Revision 1.6  1998/06/19 09:55:24  gossamer
# Reinstated require 5, misc small changes
#
#

require 5;

use strict;
use IO::Socket;
use Date::Manip; # Available at http://www.perl.org/CPAN/CPAN.html

#
# User Config
#

# File names for the two databases
my($PRIMEDIA) = "primedia";
my($CODEDB) = "opcode";

# Port we listen on
my($port) = 10000;            

# Set to 1 for the server to output extra information about what it's doing.
my($DEBUG) = 1;

#
# Helper Functions
#

# Pulls out the information from one line from the opcode DB.
sub divide_opcode($) 
{
   shift;

   #print STDERR "divide_opcode: \$_ is '$_'\n" if $DEBUG;
   return m@([^/]*)/([^/]*)/([^/]*)/([^/]*)/([^/]*)/(.*)@;
}

# Pulls info out of a line from the client.
sub divide_input($) 
{
   my $code = shift;

   #print STDERR "divide_input: \$code is '$code'\n" if $DEBUG;
   return $code =~ m@([^/]*)/([^/]*)/([^/]*)/([^/]*)/([^/]*)/(.*)@s;
}

# Seeks and reads the primedia, and returns the material.
sub get_primedia($$)
{
   my($start, $len) = @_; 
   my($material) = ""; # init buffer

   open(PRIMEDIA, $PRIMEDIA) or die "Can't open \" $PRIMEDIA\" for read: $!";
   seek(PRIMEDIA, $start, 0);      
   read(PRIMEDIA, $material, $len); 
   close(PRIMEDIA);

   return $material;
}                        

# Strips the [..+..] charactors from the pointer.
sub divide_pointer($)
{
   my($ptr) = @_;            
   my($start, $len);

   my(@ptr) = split(/\]/, $ptr);
   $_ = shift(@ptr);
   ($start, $len) = (split(/\+/ ,$_));       

   return ($start, $len); 
}

# Appends a new operation code to the opcode dababase.
sub record_opcode($)
{
   my($opcode) = @_;

   open(OPCODE, ">> $CODEDB") or die "Can't open \"$CODEDB\" for append: $!";
   print OPCODE "$opcode\n";
   close(OPCODE);

   return 1;
}


#
# Operator functions
# One for each of the codes in the protocol
#

# Accepts the new material from a front end, 
# appends it to the primedia database,
# with appending the edit operation information to opcode database.
# Then sends the pointer and material to the front end. 
sub insert($$)
{                  
   my($input, $socket) = @_;
   my($primedia_len, $start, $len, $output); 

   print STDERR "insert: \$input is '$input'\n" if $DEBUG;

   my($owner, $doc, $time, $version, $local, $material) = &divide_input($input); 

   open(PRIMEDIA, ">>$PRIMEDIA") or 
      die "Can't open \"$PRIMEDIA\" for append: $!";

   $primedia_len = -s $PRIMEDIA; 
   print PRIMEDIA "$material";
   close(PRIMEDIA);

   $len = length($material);      
   $start = $primedia_len; 
   $output = "[$start+$len]/$material";
   $socket->send($output, 0);

   my($code) = $owner . "/" . $doc . "/" . $version . "/" . $time . "/INS/" . $local . "[$start+$len]";
   &record_opcode($code);      

   return 1;
}

# Accepts the pointer from a front end, and sends back the material.
sub request_by_pointer($$)
{
   my($input, $socket) = @_;

   print STDERR "request_by_pointer: \$input is '$input'\n" if $DEBUG;

   my(@ptrs) = split(/\[/, $input);
   shift(@ptrs);  # discard the first undef char

   my($output) = "";
   foreach (@ptrs) {
      my($start, $len) = &divide_pointer($_);
      my($material) = &get_primedia($start, $len);
      $output .= $material;
   }

   $socket->send($output, 0);

   return 1;
}

# Accepts the pointers, swaps them, then sends them back to the front end.  
sub rearrange_by_pointer($$)
{
   my($input, $socket) = @_;

   print STDERR "rearrange_by_pointer: \$input is '$input'\n" if $DEBUG;

   my($pointers) = join("", reverse(split(/\s+/, $input)));
   $socket->send($pointers, 0);

   return 1;
}

# Accepts the pointer information, 
# appending the edit operation information to opcode database.
# Then sends the pointer(s) to the front end.
sub delete($$)
{   
   my($input, $socket) = @_;
   my($start, $len, @ptrs, $whitespace, @outptr);      

   print STDERR "delete: \$input is '$input'\n" if $DEBUG;

   my($owner, $doc, $time, $version, $local, $ptr) = &divide_input($input);

   @ptrs = split(/\[/, $ptr);
   shift(@ptrs);

   my($outmat) = "";
   foreach (@ptrs) {
      ($start ,$len) = &divide_pointer($_);
      $whitespace = " " x $len;
      push(@outptr, "[$start+$len]");
      $outmat .= $whitespace;
   }

   my($output) = join("", @outptr) . "/$outmat";
   $socket->send($output, 0);

   my($code) = 
     $owner . "/" . $doc . "/" . $version . "/" . $time . "/DEL/" . $local . join("", @outptr);
   &record_opcode($code);

   return 1;
}

# Accepts the pointer information,
# appending the edit operation information to opcode database.
# Then sends the pointer and material to the front end.
sub transclude($$)
{            
   my($input, $socket) = @_;
   my($start, $len, @ptrs, $material, @outptr);

   print STDERR "transclude: \$input is '$input'\n" if $DEBUG;

   my($owner, $doc, $time, $version, $local, $ptr) = &divide_input($input);
   @ptrs = split(/\[/, $ptr);

   shift(@ptrs);  # discard the first undef char
   my($outmat) = "";
   foreach (@ptrs) {
      ($start, $len) = &divide_pointer($_); 
      $material = &get_primedia($start, $len);
      push(@outptr, "[$start+$len]");
      $outmat .= $material;   
   }

   my($output) = join("", @outptr) . "/$outmat";
   $socket->send($output, 0);

   my($code) = 
     $owner . "/" . $doc . "/" . $version . "/" . $time . "/TNS/" . $local . join("", @outptr);
   &record_opcode($code);

   return 1;
}

# Accepts the pointer information,
# appending the edit operation information to opcode database.
# Then sends the pointer and material to the front end.
sub rearrange($$)
{
   my($input, $socket) = @_;
   my($start, $len, @ptrs, @swapped, $material, @outptr); 

   print STDERR "rearrange: \$input is '$input'\n" if $DEBUG;

   my($owner, $doc, $time, $version, $local, $pointers) = &divide_input($input); 

   my(@pointers) = split(/\*/, $pointers); # different delimeter!
   my($before) = qq(@pointers); # Note: 

   my @newptrs = split(/\[/, join("", reverse(@pointers)));
   shift(@newptrs); # discard the first undef char

   my($outmat) = "";
   foreach (@newptrs) {
      ($start, $len) = &divide_pointer($_);
      $material = &get_primedia($start, $len);

      push(@outptr, "[$start+$len]");
      $outmat .= $material;
   }            
   my($output) = join("", @outptr) . "/" . $outmat;
   $socket->send($output, 0);

   my($code) = $owner . "/" . $doc . "/" . $version . "/" . $time . "/REA/" . $local . $before; 
   &record_opcode($code);

   return 1;
}

# Finds the matarial by DOCUMENT NAME.
sub request_by_document_name($$)  
{
   my($input, $socket) = @_;
   my($codebuf) = "";
   my(@send);

   print STDERR "request_by_document_name: \$input is '$input'\n" if $DEBUG;

   my ($docowner, $docmt, $vers) = $input =~ m@^([^/]*)/([^/]*)/(.*)$@s;
   my(@request) = split(/\n+/, $vers);

   open(CODE, $CODEDB) or die "Can't open \"$CODEDB\" for read: $!";
   my @codes = <CODE>;
   close(CODE);

   foreach my $ver (@request) {
      foreach (@codes) {
         chomp;
         my($owner, $doc, $version, $time, $type, $local_ptrs) = &divide_opcode($_);
         if (($docmt eq $doc) && ($version eq $ver)) {
            push(@send, $version . "/" . $type . "/" . $local_ptrs);
         }
      }
   }
   
   my($send);

   if (defined @send) {
      $send = join("\n", reverse(@send)) . "\n";
   } else { 
      $send = "Not found";
   }
   $socket->send($send, 0);

   return 1;
}


# Finds the material by DOCUMENT OWNER NAME.
sub request_version_list($$)
{
   my($input, $socket) = @_;
   my(@send);

   print STDERR "request_version_list: \$input is '$input'\n" if $DEBUG;

   my ($docowner, $docmt) = $input =~ m@^([^/]*)/(.*)$@;

   my($latest) = 0;
   my($latest_ver);

   open(CODE, $CODEDB) or die "Can't open \"$CODEDB\" for read: $!";
   foreach (<CODE>) {
      chomp;
      my($owner, $doc, $version, $time, $type, $local_ptrs) = &divide_opcode($_);

      if ((($docowner eq $owner) || !$docowner) &&
          ($docmt eq $doc)) {
         push(@send, $version);
         $time = &ParseDate($time);
         if ($time gt $latest) {
            $latest = $time;
            $latest_ver = $version;
         }
      }
   }
   close(CODE);

   my($send) = join("\n", @send);
   if ($send eq "") {
      $send = "Not found";
   } else {
      $send = $send . "\n" . $latest_ver . "\n";
   }
   $socket->send($send, 0);

   return 1;
}

# Seeks and reads the corresponding material from the primedia.
sub version_compare($$)
{
   my($input, $socket) = @_;
   my(@material);

   print STDERR "version_compare: \$input is '$input'\n" if $DEBUG;

   my(@bytes) = split(/\,/, $input);

   foreach (@bytes) {
      push(@material, &get_primedia($_, 1));
   }

   $socket->send(join("", @material), 0);

   return 1;
}

#
# Main
#

$SIG{CHLD} = sub { wait }; # Kill zombie!!;-)

# Open the server socket
my $socket = IO::Socket::INET->new(LocalPort => $port, Listen => 5, Reuse => 1);
die "Could not open socket for listen: $!" unless $socket;

print STDERR "Main: Listening to port = $port\n" if $DEBUG; 

my $connection = 0;
while (++$connection) {

   print STDERR "Main: Listening for connection $connection...\n" if $DEBUG;
   my $newsocket = $socket->accept() or die("Accept: $!");   

   if (!fork()) {
      # This is the child process

      print STDERR "$connection: Accepted connection from host " .  $newsocket->peerhost() .  ", port " . $newsocket->peerport .  "\n" if $DEBUG;
 
      $newsocket->recv(my $data, 10000000, 0); 

      $data =~ s@^([^/]*)/@@;
      my $opcode = $1;
      if ($opcode eq "INS") {
         &insert($data, $newsocket);
      } elsif ($opcode eq "DEL") {
         &delete($data, $newsocket); 
      } elsif ($opcode eq "TNS") {
         &transclude($data, $newsocket); 
      } elsif ($opcode eq "REA") {
         &rearrange($data, $newsocket); 
      } elsif ($opcode eq "REQ") {
         &request_by_document_name($data, $newsocket); 
      } elsif ($opcode eq "DOC") {
         &request_version_list($data, $newsocket); 
      } elsif ($opcode eq "!INS") {
         &request_by_pointer($data, $newsocket); 
      } elsif ($opcode eq "!REA") {
         &rearrange_by_pointer($data, $newsocket); 
      } elsif ($opcode eq "!VCP") {
         &version_compare($data, $newsocket); 
      } else { 
         print STDERR "$connection: Error: operation type '$opcode' unknown.\n";
      }

      $newsocket->close();

      print STDERR "$connection: Connection closed.\n" if $DEBUG;
      exit;  # Child only
   }
}

#
# End.
#