# The LearningOnline Network
# TCP networking package
#
# Functions for use by content handlers:
#
# plaintext(short)   : plain text explanation of short term
# allowed(short,url) : returns codes for allowed actions
# appendenv(hash)    : adds hash to session environment
# store(hash)        : stores hash permanently for this url
# restore            : returns hash for this url
# eget(namesp,array) : returns hash with keys from array filled in from namesp
# get(namesp,array)  : returns hash with keys from array filled in from namesp
# put(namesp,hash)   : stores hash in namesp
# dump(namesp)       : dumps the complete namespace into a hash
# ssi(url)           : does a complete request cycle on url to localhost
# repcopy(filename)  : replicate file
# dirlist(url)       : gets a directory listing
#
# 6/1/99,6/2,6/10,6/11,6/12,6/14,6/26,6/28,6/29,6/30,
# 7/1,7/2,7/9,7/10,7/12,7/14,7/15,7/19,
# 11/8,11/16,11/18,11/22,11/23,12/22,
# 01/06,01/13,02/24,02/28,02/29,
# 03/01,03/02,03/06,03/07,03/13,
# 04/05,05/29,05/31,06/01,
# 06/05,06/26 Gerd Kortemeyer
# 06/26 Ben Tyszka
# 06/30,07/15,07/17 Gerd Kortemeyer

package Apache::lonnet;

use strict;
use Apache::File;
use LWP::UserAgent();
use HTTP::Headers;
use vars 
qw(%perlvar %hostname %homecache %spareid %hostdom %libserv %pr %prp $readit);
use IO::Socket;
use Apache::Constants qw(:common :http);

# --------------------------------------------------------------------- Logging

sub logthis {
    my $message=shift;
    my $execdir=$perlvar{'lonDaemons'};
    my $now=time;
    my $local=localtime($now);
    my $fh=Apache::File->new(">>$execdir/logs/lonnet.log");
    print $fh "$local ($$): $message\n";
    return 1;
}

sub logperm {
    my $message=shift;
    my $execdir=$perlvar{'lonDaemons'};
    my $now=time;
    my $local=localtime($now);
    my $fh=Apache::File->new(">>$execdir/logs/lonnet.perm.log");
    print $fh "$now:$message:$local\n";
    return 1;
}

# -------------------------------------------------- Non-critical communication
sub subreply {
    my ($cmd,$server)=@_;
    my $peerfile="$perlvar{'lonSockDir'}/$server";
    my $client=IO::Socket::UNIX->new(Peer    =>"$peerfile",
                                     Type    => SOCK_STREAM,
                                     Timeout => 10)
       or return "con_lost";
    print $client "$cmd\n";
    my $answer=<$client>;
    if (!$answer) { $answer="con_lost"; }
    chomp($answer);
    return $answer;
}

sub reply {
    my ($cmd,$server)=@_;
    my $answer=subreply($cmd,$server);
    if ($answer eq 'con_lost') { $answer=subreply($cmd,$server); }
    if (($answer=~/^error:/) || ($answer=~/^refused/) || 
        ($answer=~/^rejected/)) {
       &logthis("<font color=blue>WARNING:".
                " $cmd to $server returned $answer</font>");
    }
    return $answer;
}

# ----------------------------------------------------------- Send USR1 to lonc

sub reconlonc {
    my $peerfile=shift;
    &logthis("Trying to reconnect for $peerfile");
    my $loncfile="$perlvar{'lonDaemons'}/logs/lonc.pid";
    if (my $fh=Apache::File->new("$loncfile")) {
	my $loncpid=<$fh>;
        chomp($loncpid);
        if (kill 0 => $loncpid) {
	    &logthis("lonc at pid $loncpid responding, sending USR1");
            kill USR1 => $loncpid;
            sleep 1;
            if (-e "$peerfile") { return; }
            &logthis("$peerfile still not there, give it another try");
            sleep 5;
            if (-e "$peerfile") { return; }
            &logthis(
  "<font color=blue>WARNING: $peerfile still not there, giving up</font>");
        } else {
	    &logthis(
               "<font color=blue>WARNING:".
               " lonc at pid $loncpid not responding, giving up</font>");
        }
    } else {
     &logthis('<font color=blue>WARNING: lonc not running, giving up</font>');
    }
}

# ------------------------------------------------------ Critical communication

sub critical {
    my ($cmd,$server)=@_;
    my $answer=reply($cmd,$server);
    if ($answer eq 'con_lost') {
        my $pingreply=reply('ping',$server);
	&reconlonc("$perlvar{'lonSockDir'}/$server");
        my $pongreply=reply('pong',$server);
        &logthis("Ping/Pong for $server: $pingreply/$pongreply");
        $answer=reply($cmd,$server);
        if ($answer eq 'con_lost') {
            my $now=time;
            my $middlename=$cmd;
            $middlename=substr($middlename,0,16);
            $middlename=~s/\W//g;
            my $dfilename=
             "$perlvar{'lonSockDir'}/delayed/$now.$middlename.$server";
            {
             my $dfh;
             if ($dfh=Apache::File->new(">$dfilename")) {
                print $dfh "$cmd\n";
	     }
            }
            sleep 2;
            my $wcmd='';
            {
	     my $dfh;
             if ($dfh=Apache::File->new("$dfilename")) {
                $wcmd=<$dfh>;
	     }
            }
            chomp($wcmd);
            if ($wcmd eq $cmd) {
		&logthis("<font color=blue>WARNING: ".
                         "Connection buffer $dfilename: $cmd</font>");
                &logperm("D:$server:$cmd");
	        return 'con_delayed';
            } else {
                &logthis("<font color=red>CRITICAL:"
                        ." Critical connection failed: $server $cmd</font>");
                &logperm("F:$server:$cmd");
                return 'con_failed';
            }
        }
    }
    return $answer;
}

# ---------------------------------------------------------- Append Environment

sub appenv {
    my %newenv=@_;
    my @oldenv;
    {
     my $fh;
     unless ($fh=Apache::File->new("$ENV{'user.environment'}")) {
	return 'error';
     }
     @oldenv=<$fh>;
    }
    for (my $i=0; $i<=$#oldenv; $i++) {
        chomp($oldenv[$i]);
        if ($oldenv[$i] ne '') {
           my ($name,$value)=split(/=/,$oldenv[$i]);
	   $newenv{$name}=$value;
        }
    }
    {
     my $fh;
     unless ($fh=Apache::File->new(">$ENV{'user.environment'}")) {
	return 'error';
     }
     my $newname;
     foreach $newname (keys %newenv) {
	 print $fh "$newname=$newenv{$newname}\n";
     }
    }
    return 'ok';
}

# ------------------------------ Find server with least workload from spare.tab

sub spareserver {
    my $tryserver;
    my $spareserver='';
    my $lowestserver=100;
    foreach $tryserver (keys %spareid) {
       my $answer=reply('load',$tryserver);
       if (($answer =~ /\d/) && ($answer<$lowestserver)) {
	   $spareserver="http://$hostname{$tryserver}";
           $lowestserver=$answer;
       }
    }    
    return $spareserver;
}

# --------- Try to authenticate user from domain's lib servers (first this one)

sub authenticate {
    my ($uname,$upass,$udom)=@_;
    $upass=escape($upass);
    if (($perlvar{'lonRole'} eq 'library') && 
        ($udom eq $perlvar{'lonDefDomain'})) {
    my $answer=reply("encrypt:auth:$udom:$uname:$upass",$perlvar{'lonHostID'});
        if ($answer =~ /authorized/) {
              if ($answer eq 'authorized') {
                 &logthis("User $uname at $udom authorized by local server"); 
                 return $perlvar{'lonHostID'}; 
              }
              if ($answer eq 'non_authorized') {
                 &logthis("User $uname at $udom rejected by local server"); 
                 return 'no_host'; 
              }
	}
    }

    my $tryserver;
    foreach $tryserver (keys %libserv) {
	if ($hostdom{$tryserver} eq $udom) {
           my $answer=reply("encrypt:auth:$udom:$uname:$upass",$tryserver);
           if ($answer =~ /authorized/) {
              if ($answer eq 'authorized') {
                 &logthis("User $uname at $udom authorized by $tryserver"); 
                 return $tryserver; 
              }
              if ($answer eq 'non_authorized') {
                 &logthis("User $uname at $udom rejected by $tryserver");
                 return 'no_host';
              } 
	   }
       }
    }
    &logthis("User $uname at $udom could not be authenticated");    
    return 'no_host';
}

# ---------------------- Find the homebase for a user from domain's lib servers

sub homeserver {
    my ($uname,$udom)=@_;

    my $index="$uname:$udom";
    if ($homecache{$index}) { return "$homecache{$index}"; }

    my $tryserver;
    foreach $tryserver (keys %libserv) {
	if ($hostdom{$tryserver} eq $udom) {
           my $answer=reply("home:$udom:$uname",$tryserver);
           if ($answer eq 'found') { 
	      $homecache{$index}=$tryserver;
              return $tryserver; 
	   }
       }
    }    
    return 'no_host';
}

# ----------------------------- Subscribe to a resource, return URL if possible

sub subscribe {
    my $fname=shift;
    my $author=$fname;
    $author=~s/\/home\/httpd\/html\/res\/([^\/]*)\/([^\/]*).*/$1\/$2/;
    my ($udom,$uname)=split(/\//,$author);
    my $home=homeserver($uname,$udom);
    if (($home eq 'no_host') || ($home eq $perlvar{'lonHostID'})) { 
        return 'not_found'; 
    }
    my $answer=reply("sub:$fname",$home);
    return $answer;
}
    
# -------------------------------------------------------------- Replicate file

sub repcopy {
    my $filename=shift;
    my $transname="$filename.in.transfer";
    if ((-e $filename) || (-e $transname)) { return OK; }
    my $remoteurl=subscribe($filename);
    if ($remoteurl eq 'con_lost') {
	   &logthis("Subscribe returned con_lost: $filename");
           return HTTP_SERVICE_UNAVAILABLE;
    } elsif ($remoteurl eq 'not_found') {
	   &logthis("Subscribe returned not_found: $filename");
	   return HTTP_NOT_FOUND;
    } elsif ($remoteurl eq 'forbidden') {
	   &logthis("Subscribe returned forbidden: $filename");
           return FORBIDDEN;
    } else {
           my @parts=split(/\//,$filename);
           my $path="/$parts[1]/$parts[2]/$parts[3]/$parts[4]";
           if ($path ne "$perlvar{'lonDocRoot'}/res") {
               &logthis("Malconfiguration for replication: $filename");
	       return HTTP_BAD_REQUEST;
           }
           my $count;
           for ($count=5;$count<$#parts;$count++) {
               $path.="/$parts[$count]";
               if ((-e $path)!=1) {
		   mkdir($path,0777);
               }
           }
           my $ua=new LWP::UserAgent;
           my $request=new HTTP::Request('GET',"$remoteurl");
           my $response=$ua->request($request,$transname);
           if ($response->is_error()) {
	       unlink($transname);
               my $message=$response->status_line;
               &logthis("<font color=blue>WARNING:"
                       ." LWP get: $message: $filename</font>");
               return HTTP_SERVICE_UNAVAILABLE;
           } else {
	       if ($remoteurl!~/\.meta$/) {
                  my $mrequest=new HTTP::Request('GET',$remoteurl.'.meta');
                  my $mresponse=$ua->request($mrequest,$filename.'.meta');
                  if ($mresponse->is_error()) {
		      unlink($filename.'.meta');
                      &logthis(
                     "<font color=yellow>INFO: No metadata: $filename</font>");
                  }
	       }
               rename($transname,$filename);
               return OK;
           }
    }
}

# --------------------------------------------------------- Server Side Include

sub ssi {

    my $fn=shift;

    my $ua=new LWP::UserAgent;
    my $request=new HTTP::Request('GET',"http://".$ENV{'HTTP_HOST'}.$fn);
    $request->header(Cookie => $ENV{'HTTP_COOKIE'});
    my $response=$ua->request($request);

    return $response->content;
}

# ------------------------------------------------------------------------- Log

sub log {
    my ($dom,$nam,$hom,$what)=@_;
    return reply("log:$dom:$nam:$what",$hom);
}

# ----------------------------------------------------------------------- Store

sub store {
    my %storehash=shift;
    my $namevalue='';
    map {
        $namevalue.=escape($_).'='.escape($storehash{$_}).'&';
    } keys %storehash;
    $namevalue=~s/\&$//;
    return reply("store:$ENV{'user.domain'}:$ENV{'user.name'}:"
               ."$ENV{'user.class'}:$ENV{'request.filename'}:$namevalue",
		 "$ENV{'user.home'}");
}

# --------------------------------------------------------------------- Restore

sub restore {
    my $answer=reply("restore:$ENV{'user.domain'}:$ENV{'user.name'}:"
               ."$ENV{'user.class'}:$ENV{'request.filename'}",
                "$ENV{'user.home'}");
    my %returnhash=();
    map {
	my ($name,$value)=split(/\=/,$_);
        $returnhash{&unescape($name)}=&unescape($value);
    } split(/\&/,$answer);
    return %returnhash;
}

# -------------------------------------------------------- Get user priviledges

sub rolesinit {
    my ($domain,$username,$authhost)=@_;
    my $rolesdump=reply("dump:$domain:$username:roles",$authhost);
    if (($rolesdump eq 'con_lost') || ($rolesdump eq '')) { return ''; }
    my %allroles=();
    my %thesepriv=();
    my $userroles='';
    my $now=time;
    my $thesestr;

    if ($rolesdump ne '') {
        map {
	  if ($_!~/rolesdef\&/) {
            my ($area,$role)=split(/=/,$_);
            my ($trole,$tend,$tstart)=split(/_/,$role);
            if ($tend!=0) {
	        if ($tend<$now) {
	            $trole='';
                } 
            }
            if ($tstart!=0) {
                if ($tstart>$now) {
                   $trole='';        
                }
            }
            if (($area ne '') && ($trole ne '')) {
               $userroles.='user.role.'.$trole.'.'.$area.'='.
                           $tstart.'.'.$tend."\n";
               my ($tdummy,$tdomain,$trest)=split(/\//,$area);
               if ($trole =~ /^cr\//) {
		   my ($rdummy,$rdomain,$rauthor,$rrole)=split(/\//,$trole);
                   my $homsvr=homeserver($rauthor,$rdomain);
                   if ($hostname{$homsvr} ne '') {
                      my $roledef=
			  reply("get:$rdomain:$rauthor:roles:rolesdef&$rrole",
                                $homsvr);
                      if (($roledef ne 'con_lost') && ($roledef ne '')) {
                         my ($syspriv,$dompriv,$coursepriv)=
			     split(/&&/,$roledef);
 	                 $allroles{'/'}.=':'.$syspriv;
                         if ($tdomain ne '') {
                             $allroles{'/'.$tdomain.'/'}.=':'.$dompriv;
                             if ($trest ne '') {
		                $allroles{$area}.=':'.$coursepriv;
                             }
	                 }
                      }
                   }
               } else {
	           $allroles{'/'}.=':'.$pr{$trole.':s'};
                   if ($tdomain ne '') {
                      $allroles{'/'.$tdomain.'/'}.=':'.$pr{$trole.':d'};
                      if ($trest ne '') {
		          $allroles{$area}.=':'.$pr{$trole.':c'};
                      }
	           }
	       }
            }
          } 
        } split(/&/,$rolesdump);
        map {
            %thesepriv=();
            map {
                if ($_ ne '') {
		    my ($priviledge,$restrictions)=split(/&/,$_);
                    if ($restrictions eq '') {
			$thesepriv{$priviledge}='F';
                    } else {
                        if ($thesepriv{$priviledge} ne 'F') {
			    $thesepriv{$priviledge}.=$restrictions;
                        }
                    }
                }
            } split(/:/,$allroles{$_});
            $thesestr='';
            map { $thesestr.=':'.$_.'&'.$thesepriv{$_}; } keys %thesepriv;
            $userroles.='user.priv.'.$_.'='.$thesestr."\n";
        } keys %allroles;            
    }
    return $userroles;  
}

# --------------------------------------------------------------- get interface

sub get {
   my ($namespace,@storearr)=@_;
   my $items='';
   map {
       $items.=escape($_).'&';
   } @storearr;
   $items=~s/\&$//;
 my $rep=reply("get:$ENV{'user.domain'}:$ENV{'user.name'}:$namespace:$items",
                 $ENV{'user.home'});
   my @pairs=split(/\&/,$rep);
   my %returnhash=();
   map {
      my ($key,$value)=split(/=/,$_);
      $returnhash{unespace($key)}=unescape($value);
   } @pairs;
   return %returnhash;
}

# -------------------------------------------------------------- dump interface

sub dump {
   my $namespace=shift;
   my $rep=reply("dump:$ENV{'user.domain'}:$ENV{'user.name'}:$namespace",
                $ENV{'user.home'});
   my @pairs=split(/\&/,$rep);
   my %returnhash=();
   map {
      my ($key,$value)=split(/=/,$_);
      $returnhash{unespace($key)}=unescape($value);
   } @pairs;
   return %returnhash;
}

# --------------------------------------------------------------- put interface

sub put {
   my ($namespace,%storehash)=@_;
   my $items='';
   map {
       $items.=escape($_).'='.escape($storehash{$_}).'&';
   } keys %storehash;
   $items=~s/\&$//;
   return reply("put:$ENV{'user.domain'}:$ENV{'user.name'}:$namespace:$items",
                 $ENV{'user.home'});
}

# -------------------------------------------------------------- eget interface

sub eget {
   my ($namespace,@storearr)=@_;
   my $items='';
   map {
       $items.=escape($_).'&';
   } @storearr;
   $items=~s/\&$//;
 my $rep=reply("eget:$ENV{'user.domain'}:$ENV{'user.name'}:$namespace:$items",
                 $ENV{'user.home'});
   my @pairs=split(/\&/,$rep);
   my %returnhash=();
   map {
      my ($key,$value)=split(/=/,$_);
      $returnhash{unespace($key)}=unescape($value);
   } @pairs;
   return %returnhash;
}

# ------------------------------------------------- Check for a user priviledge

sub allowed {
    my ($priv,$uri)=@_;
    $uri=~s/^\/res//;
    $uri=~s/^\///;
    if ($uri=~/^adm\//) {
	return 'F';
    }
    my $thisallowed='';
    if ($ENV{'user.priv./'}=~/$priv\&([^\:]*)/) {
       $thisallowed.=$1;
    }
    if ($ENV{'user.priv./'.(split(/\//,$uri))[0].'/'}=~/$priv\&([^\:]*)/) {
       $thisallowed.=$1;
    }
    if ($ENV{'user.priv./'.$uri}=~/$priv\&([^\:]*)/) {
       $thisallowed.=$1;
    }
    return $thisallowed;
}

# ----------------------------------------------------------------- Define Role

sub definerole {
  if (allowed('mcr','/')) {
    my ($rolename,$sysrole,$domrole,$courole)=@_;
    my $command="encrypt:rolesput:$ENV{'user.domain'}:$ENV{'user.name'}:".
                "$ENV{'user.domain'}:$ENV{'user.name'}:".
	        "rolesdef&$rolename=$sysrole&&$domrole&&$courole";
    return reply($command,$ENV{'user.home'});
  } else {
    return 'refused';
  }
}

# ------------------------------------------------------------------ Plain Text

sub plaintext {
    return $prp{$_};
}

# ----------------------------------------------------------------- Assign Role

sub assignrole {
}

# ------------------------------------------------------------ Directory lister

sub dirlist {
    my $uri=shift;
    $uri=~s/^\///;
    $uri=~s/\/$//;
    $uri=~/^res\/(\w+)\/(\w+)/;
    my $listing=reply('ls:'.$perlvar{'lonDocRoot'}.'/'.$uri,homeserver($2,$1));
    return split(/:/,$listing);
}

# -------------------------------------------------------- Escape Special Chars

sub escape {
    my $str=shift;
    $str =~ s/(\W)/"%".unpack('H2',$1)/eg;
    return $str;
}

# ----------------------------------------------------- Un-Escape Special Chars

sub unescape {
    my $str=shift;
    $str =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg;
    return $str;
}

# ================================================================ Main Program

sub BEGIN {
if ($readit ne 'done') {
# ------------------------------------------------------------ Read access.conf
{
    my $config=Apache::File->new("/etc/httpd/conf/access.conf");

    while (my $configline=<$config>) {
        if ($configline =~ /PerlSetVar/) {
	   my ($dummy,$varname,$varvalue)=split(/\s+/,$configline);
           chomp($varvalue);
           $perlvar{$varname}=$varvalue;
        }
    }
}

# ------------------------------------------------------------- Read hosts file
{
    my $config=Apache::File->new("$perlvar{'lonTabDir'}/hosts.tab");

    while (my $configline=<$config>) {
       my ($id,$domain,$role,$name,$ip)=split(/:/,$configline);
       $hostname{$id}=$name;
       $hostdom{$id}=$domain;
       if ($role eq 'library') { $libserv{$id}=$name; }
    }
}

# ------------------------------------------------------ Read spare server file
{
    my $config=Apache::File->new("$perlvar{'lonTabDir'}/spare.tab");

    while (my $configline=<$config>) {
       chomp($configline);
       if (($configline) && ($configline ne $perlvar{'lonHostID'})) {
          $spareid{$configline}=1;
       }
    }
}
# ------------------------------------------------------------ Read permissions
{
    my $config=Apache::File->new("$perlvar{'lonTabDir'}/roles.tab");

    while (my $configline=<$config>) {
       chomp($configline);
       my ($role,$perm)=split(/ /,$configline);
       if ($perm ne '') { $pr{$role}=$perm; }
    }
}

# -------------------------------------------- Read plain texts for permissions
{
    my $config=Apache::File->new("$perlvar{'lonTabDir'}/rolesplain.tab");

    while (my $configline=<$config>) {
       chomp($configline);
       my ($short,$plain)=split(/:/,$configline);
       if ($plain ne '') { $prp{$short}=$plain; }
    }
}

$readit='done';
&logthis('<font color=yellow>INFO: Read configuration</font>');
}
}
1;