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