Annotation of nsdl/nsdlloncapaorg/signon.pl, revision 1.2
1.1 www 1: #!/usr/bin/perl
2: # The LearningOnline Network with CAPA
1.2 ! www 3: # Generate Guest Users on NSDL Server
1.1 www 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:
1.2 ! www 11: my $demodomain='nsdl';
! 12: my $demohome='nsdll1';
1.1 www 13: my $admemail='lon-capa@lon-capa.org';
1.2 ! www 14: my $demoserver='nsdl.lon-capa.org';
1.1 www 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:
1.2 ! www 198: sub modifyrole {
! 199: my ($uname,$upass,$first,$last)=@_;
1.1 www 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; }
1.2 ! www 206:
! 207: # ------------------------------------------------------ Add guest role to user
! 208: return &assignrole($uname,'nsdl','dg',$end,$start);
1.1 www 209: }
210:
211: sub enroll {
212: my ($uname,$upass,$first,$last)=@_;
1.2 ! www 213: &logthis("Going to enroll $uname as guest");
! 214: my $returnval.=
! 215: &modifyrole($uname,$upass,$first,$last)."<br>\n";
1.1 www 216: return $returnval;
217: }
218: # ------------------------------------------------------------- Make a password
219:
220: sub genpass {
221: srand($$);
222: my @chars=('A'..'Z','a'..'z',0..9);
223: return join('',@chars[map{ rand @chars } (1..8)]);
224: }
225:
226: sub inputline {
227: my ($name,$output)=@_;
228: print "\n<tr><td>$output:</td><td>".
229: "<input type='text' name='$name' value='$form{$name}' size='40'></td></tr>";
230: }
231:
232: sub makeform {
233: print
234: "\n<form method='post'><p>After successful generation of a username, ".
235: "the access information will be emailed to you.<p><table>";
236: foreach (sort keys %formfields) {
237: &inputline($_,$formfields{$_});
238: }
239: print "</table>\n<input type='hidden' name='courses' value='$courses'>".
1.2 ! www 240: "<input name='submitted' value='Generate Guest User' type='submit'>".
1.1 www 241: "</form>\n";
242: }
243:
244: # ----------------------------------------- Check the user supplied information
245: sub errorwrap {
246: my $msg=shift;
247: return '<font color="red">'.$msg.'</font>';
248: }
249:
250: sub checkform {
251: unless ($form{'submitted'}) {
1.2 ! www 252: return 'Please fill out the form below to generate a guest user.';
1.1 www 253: }
254: # --- Sloppy check of email address
255: unless ($form{'gemail'}=~/^[^\@]+\@[^\@]+\.\w+$/) {
256: return &errorwrap('Not a valid email address');
257: }
258: # --- Check Username
259: $form{'huser'}=~s/[^A-Za-z0-9]//g;
260: $form{'huser'}=~tr/A-Z/a-z/;
261: $form{'huser'}=~s/^\d+//;
262: $form{'huser'}=substr($form{'huser'},0,10);
263: if (length($form{'huser'})<4) {
264: return &errorwrap('Username too short');
265: }
266: # see if user exists
267: my $reply=&reply('home:'.$demodomain.':'.$form{'huser'},$demohome);
268: if ($reply eq 'found') {
269: return &errorwrap('Username '.$form{'huser'}.' already exists.');
270: }
271: unless ($reply eq 'not_found') {
1.2 ! www 272: return &errorwrap('Sorry, guest logins currently not available.');
1.1 www 273: }
274: return 0;
275: }
276:
277: sub sendemail {
278: my $upass=shift;
279: open(MAILOUT,"|mail '$form{'gemail'}' -c '$admemail' -s 'Your LON-CAPA Demo Access Info'");
280: print MAILOUT "Welcome to LON-CAPA!\n\n";
281: print MAILOUT "Somebody at $ENV{'REMOTE_ADDR'}, probably you, signed up\n";
1.2 ! www 282: print MAILOUT "for an NSDL guest login to\n\n http://$demoserver/\n\n";
1.1 www 283: print MAILOUT " Username: $form{'huser'}\n Password: $upass\n\n";
284: print MAILOUT "Additional information provided was:\n\n";
285: foreach (sort keys %formfields) {
286: print MAILOUT ' '.$formfields{$_}.': '.$form{$_}."\n";
287: }
1.2 ! www 288: print MAILOUT "\nNSDL Guest User\n\nThank you for your interest in LON-CAPA!\n".&footer;
1.1 www 289: close MAILOUT;
290: }
291:
292: sub footer {
293: return (<<'ENDFOOTER');
294: --
295: www.lon-capa.org
296: lon-capa@lon-capa.org
297: User Help: http://help.lon-capa.org/
298: Bugs and Enhancements: http://bugs.lon-capa.org/
299: Mailing Lists: http://mail.lon-capa.org/
300: ENDFOOTER
301: }
302: # ================================================================ Main Program
303:
304: print "Content-type: text/html\n\n".
1.2 ! www 305: "<html><head><title>LON-CAPA NSDL Guest Signup</title></head>".
! 306: "<body bgcolor='#BBBBAA'>\n".
! 307: "<h1>Welcome to the Learning<i>Online</i> Network with CAPA NSDL Gateway Server!</h1><img src='/adm/lonDomLogos/nsdl.gif' align='right' />";
1.1 www 308:
309: # ---------------------------------- Read loncapa_apache.conf and loncapa.conf
310: my $perlvarref=LONCAPA::Configuration::read_conf('loncapa_apache.conf',
311: 'loncapa.conf');
312: %perlvar=%{$perlvarref};
313: undef $perlvarref;
314: delete $perlvar{'lonReceipt'}; # remove since sensitive and not needed
315: delete $perlvar{'lonSqlAccess'}; # remove since sensitive and not needed
316:
317:
318: # ------------------------------------------------------------- Read hosts file
319: {
320: open(CONFIG,"$perlvar{'lonTabDir'}/hosts.tab");
321:
322: while (my $configline=<CONFIG>) {
323: chomp($configline);
324: my ($id,$domain,$role,$name,$ip,$domdescr)=split(/:/,$configline);
325: $hostname{$id}=$name;
326: $hostdom{$id}=$domain;
327: $hostip{$id}=$ip;
328: if ($domdescr) {
329: $domaindescription{$domain}=$domdescr;
330: }
331: if ($role eq 'library') { $libserv{$id}=$name; }
332: }
333: close(CONFIG);
334: }
335:
336:
337: # --------------------------------------------------------------- Get post vars
338:
339: my $buffer;
340: read(STDIN,$buffer,$ENV{'CONTENT_LENGTH'});
341:
342: my @pairs=split(/&/,$buffer);
343: my $pair;
344: foreach $pair (@pairs) {
345: my ($name,$value) = split(/=/,$pair);
346: $value =~ tr/+/ /;
347: $value =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg;
348: $name =~ tr/+/ /;
349: $name =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg;
350: $name =~ s/[\~\'\"]//g;
351: $value =~ s/[\~\'\"]//g;
352: $form{$name}=$value;
353: }
354:
355: my $error=&checkform();
356:
357: if ($error) {
358: print "<p><b>$error</b>";
359: &makeform();
360: } else {
361: my $upass=&genpass();
362: my $result=&enroll($form{'huser'},$upass,$form{'afirst'},$form{'blast'});
363: if ($result=~/error/) {
364: &logthis($result);
1.2 ! www 365: print &errorwrap('Sorry, guest functionality currently not available');
1.1 www 366: } else {
367: print "Your access information will be emailed to ".$form{'gemail'};
368: &sendemail($upass);
369: }
370: }
371: # ------------------------------------------------------------------------- End
372:
1.2 ! www 373: 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>');
1.1 www 374: 1;
375:
376:
377:
378:
379:
380:
381:
382:
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