Annotation of nsdl/nsdlloncapaorg/signon.pl, revision 1.1
1.1 ! www 1: #!/usr/bin/perl
! 2: # The LearningOnline Network with CAPA
! 3: # Generate Demo Users on Demo Server
! 4: #
! 5: # Only works on a library server!!!
! 6: # Has to be the only library server in the domain!!!
! 7: # Should not be used on a real production server.
! 8:
! 9: use strict;
! 10:
! 11: my $demodomain='msudemo';
! 12: my $demohome='msudemol1';
! 13: my $admemail='lon-capa@lon-capa.org';
! 14: my $demoserver='demo.lon-capa.org';
! 15:
! 16:
! 17:
! 18: my %perlvar=();
! 19: my %form=();
! 20: my %democourses=();
! 21: my $courses;
! 22: my %hostname=();
! 23: my %hostdom=();
! 24: my %domaindescription=();
! 25: my %libserv=();
! 26: my %hostip=();
! 27:
! 28: my %formfields=('afirst' => 'First Name',
! 29: 'blast' => 'Last Name',
! 30: 'ctitle' => 'Title',
! 31: 'dinst' => 'Company/School',
! 32: 'eaddr' => 'Street Address',
! 33: 'fcity' => 'City, State, ZIP',
! 34: 'gemail' => 'EMail Address',
! 35: 'huser' => 'Desired Username',
! 36: 'icomm' => 'Area of Interest/Comments');
! 37:
! 38: use lib '/home/httpd/lib/perl/';
! 39: use LONCAPA::Configuration;
! 40:
! 41: use IO::File;
! 42: use IO::Socket;
! 43:
! 44:
! 45: # ------------------------------------------------------------- Declutters URLs
! 46:
! 47: sub declutter {
! 48: my $thisfn=shift;
! 49: $thisfn=~s/^$perlvar{'lonDocRoot'}//;
! 50: $thisfn=~s/^\///;
! 51: $thisfn=~s/^res\///;
! 52: $thisfn=~s/\?.+$//;
! 53: return $thisfn;
! 54: }
! 55:
! 56: # -------------------------------------------------------- Escape Special Chars
! 57:
! 58: sub escape {
! 59: my $str=shift;
! 60: $str =~ s/(\W)/"%".unpack('H2',$1)/eg;
! 61: return $str;
! 62: }
! 63:
! 64: # ----------------------------------------------------- Un-Escape Special Chars
! 65:
! 66: sub unescape {
! 67: my $str=shift;
! 68: $str =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg;
! 69: return $str;
! 70: }
! 71:
! 72:
! 73: # ------------------------------------------------------------------- Log stuff
! 74:
! 75: sub logthis {
! 76:
! 77: my $message=shift;
! 78: my $execdir=$perlvar{'lonDaemons'};
! 79: my $now=time;
! 80: my $local=localtime($now);
! 81: open(FH,">>$execdir/logs/demo.log");
! 82: print FH "$local ($$): $message\n";
! 83: close(FH);
! 84: return 1;
! 85: }
! 86: # -------------------------------------------------- Non-critical communication
! 87: sub reply {
! 88: my ($cmd,$server)=@_;
! 89: my $peerfile="$perlvar{'lonSockDir'}/$server";
! 90: my $client=IO::Socket::UNIX->new(Peer =>"$peerfile",
! 91: Type => SOCK_STREAM,
! 92: Timeout => 10)
! 93: or return "con_lost";
! 94: print $client "$cmd\n";
! 95: my $answer=<$client>;
! 96: chomp($answer);
! 97: if (!$answer) { $answer="con_lost"; }
! 98: return $answer;
! 99: }
! 100:
! 101:
! 102: sub put {
! 103: my ($namespace,$storehash,$udomain,$uname)=@_;
! 104: my $uhome=&homeserver($uname,$udomain);
! 105: my $items='';
! 106: foreach (keys %$storehash) {
! 107: $items.=&escape($_).'='.&escape($$storehash{$_}).'&';
! 108: }
! 109: $items=~s/\&$//;
! 110: return &reply("put:$udomain:$uname:$namespace:$items",$uhome);
! 111: }
! 112:
! 113:
! 114: # ------------- Modified routines from lonnet to make a new student in a course
! 115:
! 116: # ---------------------- Find the homebase for a user from domain's lib servers
! 117:
! 118: sub homeserver {
! 119: my ($uname,$udom)=@_;
! 120: my $index="$uname:$udom";
! 121: my $tryserver;
! 122: foreach $tryserver (keys %libserv) {
! 123: if ($hostdom{$tryserver} eq $udom) {
! 124: my $answer=reply("home:$udom:$uname",$tryserver);
! 125: if ($answer eq 'found') {
! 126: return $tryserver;
! 127: }
! 128: }
! 129: }
! 130: return 'no_host';
! 131: }
! 132:
! 133:
! 134: # ----------------------------------------------------------------- Assign Role
! 135:
! 136: sub assignrole {
! 137: my ($uname,$url,$role,$end,$start)=@_;
! 138: my $command="encrypt:rolesput:$demodomain:auto:".
! 139: "$demodomain:$uname:$url".'_'."$role=$role";
! 140: if ($end) { $command.='_'.$end; }
! 141: if ($start) {
! 142: if ($end) {
! 143: $command.='_'.$start;
! 144: } else {
! 145: $command.='_0_'.$start;
! 146: }
! 147: }
! 148: return &reply($command,$demohome);
! 149: }
! 150:
! 151: # --------------------------------------------------------------- Modify a user
! 152:
! 153: sub modifyuser {
! 154: my ($uname, $upass, $first, $last)=@_;
! 155: my $udom=$demodomain;
! 156: my $desiredhome=$demohome;
! 157: my $middle='';
! 158: my $gene='';
! 159: my $umode='internal';
! 160: $udom=~s/\W//g;
! 161: $uname=~s/\W//g;
! 162: &logthis('Call to modify user '.$udom.', '.$uname.', '.
! 163: $umode.', '.$first.', '.
! 164: $last.', '.$desiredhome);
! 165: my $uhome=$demohome;
! 166: # ----------------------------------------------------------------- Create User
! 167: if (($umode) && ($upass)) {
! 168: my $unhome=$desiredhome;
! 169: if (($unhome eq '') || ($unhome eq 'no_host')) {
! 170: return 'error: unable to find a home server for '.$uname.
! 171: ' in domain '.$udom;
! 172: }
! 173: my $reply=&reply('encrypt:makeuser:'.$udom.':'.$uname.':'.$umode.':'.
! 174: &escape($upass),$unhome);
! 175: unless ($reply eq 'ok') {
! 176: return 'error makeuser '.$udom.' '.$unhome.': '.$reply;
! 177: }
! 178: $uhome=&homeserver($uname,$udom,'true');
! 179: if (($uhome eq '') || ($uhome eq 'no_host') || ($uhome ne $unhome)) {
! 180: return 'error: verify home';
! 181: }
! 182: } # End of creation of new user
! 183:
! 184: # -------------------------------------------------------------- Add names, etc
! 185: my %names;
! 186: if ($first) { $names{'firstname'} = $first; }
! 187: if ($last) { $names{'lastname'} = $last; }
! 188: my $reply = &put('environment', \%names, $udom,$uname);
! 189: if ($reply ne 'ok') { return 'error: '.$reply; }
! 190: &logthis('Success modifying user '.$udom.', '.$uname.', '.
! 191: $umode.', '.$first.', '.
! 192: $last);
! 193: return 'ok';
! 194: }
! 195:
! 196: # -------------------------------------------------------------- Modify student
! 197:
! 198: sub modifystudent {
! 199: my ($uname,$upass,$first,$last,$cnum,$cdom,$chome)=@_;
! 200: my $udom=$demodomain;
! 201: my $start=time;
! 202: my $end=$start+60*60*24*100;
! 203: # --------------------------------------------------------------- Make the user
! 204: my $reply=&modifyuser($uname,$upass,$first,$last);
! 205: unless ($reply eq 'ok') { return $reply; }
! 206: # -------------------------------------------------- Add student to course list
! 207: $reply=reply('put:'.$cdom.':'.$cnum.':classlist:'.
! 208: &escape($uname.':'.$udom).'='.
! 209: &escape($end.':'.$start),
! 210: $chome);
! 211: unless (($reply eq 'ok') || ($reply eq 'delayed')) {
! 212: return "error course list ".$reply;
! 213: }
! 214: # ---------------------------------------------------- Add student role to user
! 215: my $uurl='/'.$cdom.'_'.$cnum;
! 216: $uurl=~s/\_/\//g;
! 217: return &assignrole($uname,$uurl,'st',$end,$start);
! 218: }
! 219:
! 220: sub enroll {
! 221: my ($uname,$upass,$first,$last)=@_;
! 222: &logthis("Going to enroll $uname for $courses");
! 223: my $returnval='';
! 224: foreach (split(/\&/,$courses)) {
! 225: my ($cdom,$chome,$cid)=split(/\:/,$democourses{$_});
! 226: if ($cid) {
! 227: $returnval.=
! 228: &modifystudent
! 229: ($uname,$upass,$first,$last,$cid,$cdom,$chome)."<br>\n";
! 230: }
! 231: }
! 232: return $returnval;
! 233: }
! 234: # ------------------------------------------------------------- Make a password
! 235:
! 236: sub genpass {
! 237: srand($$);
! 238: my @chars=('A'..'Z','a'..'z',0..9);
! 239: return join('',@chars[map{ rand @chars } (1..8)]);
! 240: }
! 241:
! 242: sub inputline {
! 243: my ($name,$output)=@_;
! 244: print "\n<tr><td>$output:</td><td>".
! 245: "<input type='text' name='$name' value='$form{$name}' size='40'></td></tr>";
! 246: }
! 247:
! 248: sub makeform {
! 249: print
! 250: "\n<form method='post'><p>After successful generation of a username, ".
! 251: "the access information will be emailed to you.<p><table>";
! 252: foreach (sort keys %formfields) {
! 253: &inputline($_,$formfields{$_});
! 254: }
! 255: print "</table>\n<input type='hidden' name='courses' value='$courses'>".
! 256: "<input name='submitted' value='Generate Demo User' type='submit'>".
! 257: "</form>\n";
! 258: }
! 259:
! 260: # ----------------------------------------- Check the user supplied information
! 261: sub errorwrap {
! 262: my $msg=shift;
! 263: return '<font color="red">'.$msg.'</font>';
! 264: }
! 265:
! 266: sub checkform {
! 267: unless ($form{'submitted'}) {
! 268: return 'Please fill out the form below to generate a demo user.';
! 269: }
! 270: # --- Sloppy check of email address
! 271: unless ($form{'gemail'}=~/^[^\@]+\@[^\@]+\.\w+$/) {
! 272: return &errorwrap('Not a valid email address');
! 273: }
! 274: # --- Check Username
! 275: $form{'huser'}=~s/[^A-Za-z0-9]//g;
! 276: $form{'huser'}=~tr/A-Z/a-z/;
! 277: $form{'huser'}=~s/^\d+//;
! 278: $form{'huser'}=substr($form{'huser'},0,10);
! 279: if (length($form{'huser'})<4) {
! 280: return &errorwrap('Username too short');
! 281: }
! 282: # see if user exists
! 283: my $reply=&reply('home:'.$demodomain.':'.$form{'huser'},$demohome);
! 284: if ($reply eq 'found') {
! 285: return &errorwrap('Username '.$form{'huser'}.' already exists.');
! 286: }
! 287: unless ($reply eq 'not_found') {
! 288: return &errorwrap('Sorry, demo logins currently not available.');
! 289: }
! 290: return 0;
! 291: }
! 292:
! 293: sub sendemail {
! 294: my $upass=shift;
! 295: open(MAILOUT,"|mail '$form{'gemail'}' -c '$admemail' -s 'Your LON-CAPA Demo Access Info'");
! 296: print MAILOUT "Welcome to LON-CAPA!\n\n";
! 297: print MAILOUT "Somebody at $ENV{'REMOTE_ADDR'}, probably you, signed up\n";
! 298: print MAILOUT "for a demo login to\n\n http://$demoserver/\n\n";
! 299: print MAILOUT " Username: $form{'huser'}\n Password: $upass\n\n";
! 300: print MAILOUT "Additional information provided was:\n\n";
! 301: foreach (sort keys %formfields) {
! 302: print MAILOUT ' '.$formfields{$_}.': '.$form{$_}."\n";
! 303: }
! 304: print MAILOUT "\nCourse(s): $courses\n\nThank you for your interest in LON-CAPA!\n".&footer;
! 305: close MAILOUT;
! 306: }
! 307:
! 308: sub readdemo {
! 309: open(IN,$perlvar{'lonTabDir'}.'/democourses.tab') ||
! 310: die "Could not open demo course file from ".$perlvar{'lonTabDir'};
! 311: while (my $line=<IN>) {
! 312: chomp($line);
! 313: my ($name,$descr)=split(/\&/,$line);
! 314: $democourses{$name}=$descr;
! 315: }
! 316: close(IN);
! 317: }
! 318:
! 319: sub footer {
! 320: return (<<'ENDFOOTER');
! 321: --
! 322: www.lon-capa.org
! 323: lon-capa@lon-capa.org
! 324: User Help: http://help.lon-capa.org/
! 325: Bugs and Enhancements: http://bugs.lon-capa.org/
! 326: Mailing Lists: http://mail.lon-capa.org/
! 327: ENDFOOTER
! 328: }
! 329: # ================================================================ Main Program
! 330:
! 331: print "Content-type: text/html\n\n".
! 332: "<html><head><title>LON-CAPA Demo Signup</title></head>".
! 333: "<body bgcolor='#FFFFFF'>\n".
! 334: "<h1>Welcome to the Learning<i>Online</i> Network with CAPA Demo Server!</h1>";
! 335:
! 336: # ---------------------------------- Read loncapa_apache.conf and loncapa.conf
! 337: my $perlvarref=LONCAPA::Configuration::read_conf('loncapa_apache.conf',
! 338: 'loncapa.conf');
! 339: %perlvar=%{$perlvarref};
! 340: undef $perlvarref;
! 341: delete $perlvar{'lonReceipt'}; # remove since sensitive and not needed
! 342: delete $perlvar{'lonSqlAccess'}; # remove since sensitive and not needed
! 343:
! 344: &readdemo();
! 345:
! 346: # ------------------------------------------------------------- Read hosts file
! 347: {
! 348: open(CONFIG,"$perlvar{'lonTabDir'}/hosts.tab");
! 349:
! 350: while (my $configline=<CONFIG>) {
! 351: chomp($configline);
! 352: my ($id,$domain,$role,$name,$ip,$domdescr)=split(/:/,$configline);
! 353: $hostname{$id}=$name;
! 354: $hostdom{$id}=$domain;
! 355: $hostip{$id}=$ip;
! 356: if ($domdescr) {
! 357: $domaindescription{$domain}=$domdescr;
! 358: }
! 359: if ($role eq 'library') { $libserv{$id}=$name; }
! 360: }
! 361: close(CONFIG);
! 362: }
! 363:
! 364:
! 365: # --------------------------------------------------------------- Get post vars
! 366:
! 367: my $buffer;
! 368: read(STDIN,$buffer,$ENV{'CONTENT_LENGTH'});
! 369:
! 370: my @pairs=split(/&/,$buffer);
! 371: my $pair;
! 372: foreach $pair (@pairs) {
! 373: my ($name,$value) = split(/=/,$pair);
! 374: $value =~ tr/+/ /;
! 375: $value =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg;
! 376: $name =~ tr/+/ /;
! 377: $name =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg;
! 378: $name =~ s/[\~\'\"]//g;
! 379: $value =~ s/[\~\'\"]//g;
! 380: $form{$name}=$value;
! 381: }
! 382: # ------------------------------------------------ Get courses from get, if any
! 383: $courses=$ENV{'QUERY_STRING'};
! 384: $courses =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg;
! 385: $courses =~ s/[^a-z\&]//g;
! 386: unless ($courses) { $courses='default'; }
! 387: # ------------------------------------------------------------ Check Form Input
! 388:
! 389: my $error=&checkform();
! 390:
! 391: if ($error) {
! 392: print "<p><b>$error</b>";
! 393: &makeform();
! 394: } else {
! 395: my $upass=&genpass();
! 396: my $result=&enroll($form{'huser'},$upass,$form{'afirst'},$form{'blast'});
! 397: if ($result=~/error/) {
! 398: &logthis($result);
! 399: print &errorwrap('Sorry, demo functionality currently not available');
! 400: } else {
! 401: print "Your access information will be emailed to ".$form{'gemail'};
! 402: &sendemail($upass);
! 403: }
! 404: }
! 405: # ------------------------------------------------------------------------- End
! 406:
! 407: print('<p><pre>'.&footer()."</pre></body></html>\n");
! 408: 1;
! 409:
! 410:
! 411:
! 412:
! 413:
! 414:
! 415:
! 416:
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>
![[BACK]](/icons/back.gif){kind=icon}
Return to signon.pl CVS log ![[TXT]](/icons/text.gif){kind=icon}
![[DIR]](/icons/dir.gif){kind=icon}
Up to [LON-CAPA] / nsdl / nsdlloncapaorg