Annotation of nsdl/nsdlloncapaorg/signon.pl, revision 1.3
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:
1.3 ! www 28: my $firsturl=&unescape($ENV{'QUERY_STRING'});
! 29: unless ($firsturl=~/^\//) { $firsturl='/'.$firsturl; }
! 30:
1.1 www 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:
1.2 www 201: sub modifyrole {
202: my ($uname,$upass,$first,$last)=@_;
1.1 www 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; }
1.2 www 209:
210: # ------------------------------------------------------ Add guest role to user
211: return &assignrole($uname,'nsdl','dg',$end,$start);
1.1 www 212: }
213:
214: sub enroll {
215: my ($uname,$upass,$first,$last)=@_;
1.2 www 216: &logthis("Going to enroll $uname as guest");
217: my $returnval.=
218: &modifyrole($uname,$upass,$first,$last)."<br>\n";
1.1 www 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'>".
1.2 www 243: "<input name='submitted' value='Generate Guest User' type='submit'>".
1.1 www 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'}) {
1.2 www 255: return 'Please fill out the form below to generate a guest user.';
1.1 www 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') {
1.2 www 275: return &errorwrap('Sorry, guest logins currently not available.');
1.1 www 276: }
277: return 0;
278: }
279:
280: sub sendemail {
281: my $upass=shift;
1.3 ! www 282: open(MAILOUT,"|mail '$form{'gemail'}' -c '$admemail' -s 'Your LON-CAPA Guest Access Info'");
1.1 www 283: print MAILOUT "Welcome to LON-CAPA!\n\n";
284: print MAILOUT "Somebody at $ENV{'REMOTE_ADDR'}, probably you, signed up\n";
1.3 ! www 285: print MAILOUT "for an NSDL guest login to\n\n http://$demoserver$firsturl?username=$form{'huser'}\n\n";
1.1 www 286: print MAILOUT " Username: $form{'huser'}\n Password: $upass\n\n";
1.3 ! www 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";
1.1 www 288: print MAILOUT "Additional information provided was:\n\n";
289: foreach (sort keys %formfields) {
290: print MAILOUT ' '.$formfields{$_}.': '.$form{$_}."\n";
291: }
1.2 www 292: print MAILOUT "\nNSDL Guest User\n\nThank you for your interest in LON-CAPA!\n".&footer;
1.1 www 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".
1.2 www 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' />";
1.1 www 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);
1.2 www 369: print &errorwrap('Sorry, guest functionality currently not available');
1.1 www 370: } else {
371: print "Your access information will be emailed to ".$form{'gemail'};
372: &sendemail($upass);
373: }
374: }
375: # ------------------------------------------------------------------------- End
376:
1.2 www 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>');
1.1 www 378: 1;
379:
380:
381:
382:
383:
384:
385:
386:
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