[LON-CAPA-cvs] cvs: modules /gerd signon.pl

Mon, 22 Jul 2002 12:28:08 -0000

www		Mon Jul 22 08:28:08 2002 EDT

  Added files:                 
    /modules/gerd	signon.pl 
  Log:
  Script to generate demo users on demo server. Should NOT ever make it into
  standard distribution.
  
  

Index: modules/gerd/signon.pl
+++ modules/gerd/signon.pl
#!/usr/bin/perl
# The LearningOnline Network with CAPA
# Generate Demo Users on Demo Server
#
# Only works on a library server!!!
# Has to be the only library server in the domain!!!
# Should not be used on a real production server.

use strict;

my $demodomain='worf';
my $demohome='worfl1';
my %perlvar=();
my %form=();
my $courses;

    my %formfields=('afirst' => 'First Name',
                    'blast'  => 'Last Name',
                    'ctitle' => 'Title',
                    'dinst'  => 'Company/School',
                    'eaddr'  => 'Street Address',
                    'fcity'  => 'City, State, ZIP',
                    'gemail' => 'EMail Address',
                    'huser'  => 'Desired Username',
                    'icomm'  => 'Area of Interest/Comments');

use lib '/home/httpd/lib/perl/';
use LONCAPA::Configuration;

use IO::File;
use IO::Socket;

# -------------------------------------------------- Non-critical communication
sub reply {
    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>;
    chomp($answer);
    if (!$answer) { $answer="con_lost"; }
    return $answer;
}

# ------------------------------------------------------------- Make a password

sub genpass {
    srand($$);
    my @chars=('A'..'Z','a'..'z',0..9);
    return join('',@chars[map{ rand @chars } (1..8)]);
}

sub inputline {
    my ($name,$output)=@_;
    print "\n<tr><td>$output:</td><td>".
"<input type='text' name='$name' value='$form{$name}' size='40'></td></tr>";
}

sub makeform {
    print 
   "\n<form method='post'><p>After successful generation of a username, ".
   "the access information will be emailed to you.<p><table>";
    foreach (sort keys %formfields) {
	&inputline($_,$formfields{$_});
    }
    print "</table>\n<input type='hidden' name='courses' value='$courses'>".
          "<input name='submitted' value='Generate Demo User' type='submit'>".
          "</form>\n";
}

# ----------------------------------------- Check the user supplied information
sub errorwrap {
    return '<font color="red">'.shift.'</font>';
}

sub checkform {
    unless ($form{'submitted'}) {
	return 'Please fill out the form below to generate a demo user.';
    }
# --- Sloppy check of email address
    unless ($form{'gemail'}=~/^[^\@]+\@[^\@]+\.\w+$/) {
	return &errorwrap('Not a valid email address');
    }
# --- Check Username
    $form{'huser'}=~s/[^A-Za-z0-9]//g;
    $form{'huser'}=~tr/A-Z/a-z/;
    $form{'huser'}=~s/^\d+//;
    $form{'huser'}=substr($form{'huser'},0,10);
    if (length($form{'huser'})<4) {
        return &errorwrap('Username too short');
    }
# see if user exists
    my $reply=&reply('home:'.$demodomain.':'.$form{'huser'},$demohome);
    if ($reply eq 'found') {
	return &errorwrap('Username '.$form{'huser'}.' already exists.');
    }
    unless ($reply eq 'not_found') {
        return &errorwrap('Sorry, demo logins currently not available.');
    }
    return 0;
}

sub sendemail {
}
# ================================================================ Main Program

print "Content-type: text/html\n\n".
      "<html><head><title>LON-CAPA Demo Signup</title></head>".
      "<body bgcolor='#FFFFFF'>\n".
"<h1>Welcome to the Learning<i>Online</i> Network with CAPA Demo Server!</h1>";

# ---------------------------------- Read loncapa_apache.conf and loncapa.conf
my $perlvarref=LONCAPA::Configuration::read_conf('loncapa_apache.conf',
                                                 'loncapa.conf');
%perlvar=%{$perlvarref};
undef $perlvarref;
delete $perlvar{'lonReceipt'};   # remove since sensitive and not needed
delete $perlvar{'lonSqlAccess'}; # remove since sensitive and not needed

# --------------------------------------------------------------- Get post vars

            my $buffer;
            read(STDIN,$buffer,$ENV{'CONTENT_LENGTH'});

            my @pairs=split(/&/,$buffer);
            my $pair;
            foreach $pair (@pairs) {
               my ($name,$value) = split(/=/,$pair);
               $value =~ tr/+/ /;
               $value =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg;
               $name  =~ tr/+/ /;
               $name  =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg;
               $name  =~ s/[\~\'\"]//g;
               $value =~ s/[\~\'\"]//g;
               $form{$name}=$value;
            }
# ------------------------------------------------ Get courses from get, if any
$courses=$ENV{'QUERY_STRING'};
$courses =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg;
$courses =~ s/[^a-z\&]//g;

# ------------------------------------------------------------ Check Form Input

my $error=&checkform();

if ($error) {
    print "<p><b>$error</b>";
    &makeform();
} else {
#if ($totalcount>200) {
#   print "mailing\n";
#   $emailto="$perlvar{'lonAdmEMail'},$perlvar{'lonSysEMail'}";
#   $subj="LON: $perlvar{'lonHostID'} E:$errors W:$warnings N:$notices"; 
#   system(
# "metasend -b -t $emailto -s '$subj' -f $statusdir/index.html -m text/html");
#}
}
# ------------------------------------------------------------------------- End
    print("</body></html>\n");
1;