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>