[LON-CAPA-cvs] cvs: nsdl /nsdlloncapaorg harvester.pl signon.pl
www
lon-capa-cvs@mail.lon-capa.org
Mon, 28 Jul 2003 14:27:05 -0000
This is a MIME encoded message
--www1059402425
Content-Type: text/plain
www Mon Jul 28 10:27:05 2003 EDT
Added files:
/nsdl/nsdlloncapaorg harvester.pl signon.pl
Log:
Work on OAI and one-way gateway
--www1059402425
Content-Type: text/plain
Content-Disposition: attachment; filename="www-20030728102705.txt"
Index: nsdl/nsdlloncapaorg/harvester.pl
+++ nsdl/nsdlloncapaorg/harvester.pl
#!/usr/local/bin/perl
#
# lon-capa.pl
# Parse the LON-CAPA metadata
#
# Andy Dong <adong@smete.org> 10/23/2002
#
# Contact Gerd Kortemeyer (korte@lite.msu.edu)
use strict;
use LWP::UserAgent;
use Getopt::Std;
use DBI;
use DBD::ODBC;
require OAIcataloging_v2;
# -u flag specifies [u]pdate database; otherwise output to STDOUT
my $usage = << "EOT";
Usage: lon-capa.pl -u
-u (U)pdate the database
Without -u it simply prints SQL UPDATE statements to STDOUT
EOT
my %args;
getopts('u', \%args) || die $usage;
my $useDatabase = 1 if ($args{'u'});
#my $DBI_DSN='dbi:ODBC:needs2_mel_needs_3_1_dev.odbc';
my $DBI_DSN='dbi:ODBC:needs2_mel_needs_3_1.odbc';
my $DBI_USER='autocataloger';
my $DBI_PWD='regolatacotua';
my $dbh;
my $pub_month;
my $pub_year;
my @loncapa;
# HTTP requests
my $content;
my $content_regex = 'File Not Found';
# Configuration
my $debug = 0;
my $url = 'http://data.lite.msu.edu/cgi-bin/metadata_harvest.pl';
# The list of servers is from the LON-CAPA CVS repository in /loncapa/loncom/production_hosts.tab
my @servers = ( 'newscience.westshore.cc.mi.us', 's10.lite.msu.edu', 's12.lite.msu.edu', 'lon-capa.chem.sunysb.edu', 'schubert.tmcc.edu', 'dalton.chem.sfu.ca', 'capa2.phy.ohiou.edu', 'pollux.physics.fsu.edu', 'loncapa.physics.sc.edu', 'loncapa.math.ucf.edu', 'zappa.ags.udel.edu', 'loncapa.gwu.edu');
# End Configuration
#my $ua = new LWP::UserAgent;
#$ua->timeout(600);
#my $request = new HTTP::Request GET => $url;
#$request->authorization_basic('reaper', 'cat4u');
#my $response = $ua->request( $request );
#if ( $response->is_success ) {
# $content = $response->content;
# Delete all blank lines
# $content =~ s/(?<!.)\n//g;
# Replace all ^M with spaces
# $content =~ s//\s/g;
# Push the content into an array
# @loncapa = split /\n/, $content;
#} else {
# die 'LON-CAPA request failed: ' . $response->message;
#}
@loncapa=undef;
open (LON_FILE, 'metadata_harvest.txt') || die;
while (<LON_FILE>) {
chomp;
push(@loncapa,$_);
}
my %records = ();;
foreach my $metadata (@loncapa) {
chomp $metadata;
my @tkline = split('\|', $metadata);
my $title = $tkline[0];
next if ( $title eq '' );
my $author = $tkline[1];
next if ( $author eq '' );
my @authorname = split(' ', $author);
my $author_fname = $authorname[0];
my $author_lname = $authorname[1];
# We have to make an exception for Multimedia Physics which is an organization not a person
my $object_type;
if ( $author_lname eq 'Physics' ) {
$object_type = 'organization';
} else {
$object_type = 'person';
}
my $subject = $tkline[2];
next if ( ($subject eq 'Sample') || ($subject eq 'Something') );
my $resourceurl = 'http://lon-capa.smete.org' . $tkline[3];
next if ( $resourceurl =~ /(.*)\/demo\/(.*)/ );
my $keywords = $tkline[4];
my $version = $tkline[5];
my $notes = $tkline[6];
my $abstract = $tkline[7];
next if ($abstract eq '');
my $type = $tkline[8];
my $learning_resource_type;
if ( $type eq 'problem' ) {
$learning_resource_type = 114;
} elsif ( $type eq 'exam' ) {
$learning_resource_type = 114;
} elsif ( $type eq 'quiz' ) {
$learning_resource_type = 114;
} elsif ( $type eq 'assess' ) {
$learning_resource_type = 114;
} elsif ( $type eq 'survey' ) {
$learning_resource_type = 114;
} elsif ( $type eq 'form' ) {
$learning_resource_type = 114;
} elsif ( $type eq 'library' ) {
$learning_resource_type = 107;
} elsif ( $type eq 'page' ) {
$learning_resource_type = 104;
} elsif ( $type eq 'sequence' ) {
$learning_resource_type = 104;
} elsif ( $type eq 'spreadsheet' ) {
$learning_resource_type = 114;
} else {
$learning_resource_type = 0;
}
my $media_format;
if ( ($type eq 'htm') || ($type eq 'gif') || ($type eq 'mov') || ($type eq 'xml') ) {
$media_format = 70;
} else {
$media_format = 0;
}
my $language = $tkline[9]; # Look only for seniso
next if ( $language ne 'seniso');
my $primary_language='en-US';
my $creation_date = $tkline[10];
my ($pub_year,$pub_month,$pub_day) = ( $creation_date =~ /^(\d{4})-(\d{2})-(\d{2})\s(\d{2}):(\d{2}):(\d{2})$/ );
my $revision_date = $tkline[11];
my $owner = $tkline[12];
my $rights_description;
my $copyright = $tkline[13]; # public,domain,default,private (skip if private and domain)
# Public means no login required
if ( $copyright eq 'public' ) {
$rights_description = 'LON-CAPA Public Resource. No login required.';
} elsif ($copyright eq 'domain') {
$rights_description = 'Restricted to certain LON-CAPA domains.';
} else {
$rights_description = 'LON-CAPA Default Use Restriction. Login required.';
}
# Domain means restricted to a particular LON-CAPA domain
# Defaults mean access open to any registered LON-CAPA user
# Private means open only to author of material
next if ( $copyright eq 'private');
my $platform = "5"; # HTML Browser (not specified but construed from metadata)
# Connect to database
if ( $useDatabase ) {
$dbh= DBI->connect($DBI_DSN, $DBI_USER, $DBI_PWD, { RaiseError => 1, AutoCommit => 0 }) || die "Unable to connect to database $DBI_DSN as $DBI_USER: ($DBI::err) $DBI::errstr\n";;
# Configuration information for LON-CAPA
my $collection_id = OAIc_orgexists($dbh,'LearningOnline Network with CAPA');
my $submitter_id = OAIc_personexists($dbh,'adong@smete.org');
my $image = 'http://www.lite.msu.edu/liteani.gif';
my $cost = 1; # version.purchase_license_type_id
my $collection = 'LearningOnline Network with CAPA';
# LON-CAPA has single authors
my $reg_key;
if ( $object_type eq 'organization' ) {
if ( ! ($reg_key = OAIc_orgexists($dbh,join(' ',$author_fname,$author_lname))) ) {
printf("Inserting new organization %s\n", join(' ',$author_fname, $author_lname));
my $success = OAIc_insert_org($dbh,$collection_id,$submitter_id,'',join(' ',$author_fname,$author_lname),'','','','','','','','');
$reg_key = OAIc_orgexists($dbh,join(' ',$author_fname,$author_lname));
}
} else {
if ( ! ($reg_key = OAIc_personexists_name($dbh,join(' ',$author_fname,$author_lname))) ) {
printf("Inserting new person(author) %s\n", join(' ',$author_fname, $author_lname));
my $success = OAIc_insert_person($dbh,$collection_id,$submitter_id,$author_lname,$author_fname,'','');
$reg_key = OAIc_personexists_name($dbh,join(' ',$author_fname,$author_lname));
}
}
my $updated;
my $inserted;
if ( my $general_key = OAIc_loexists($dbh,$title) ) {
# Do nothing
$updated = $updated + 1;
} else {
printf("Inserting new record for %s\n",$title);
my $success = OAIc_insert_lo($dbh, $title, $primary_language, $abstract, $image, $pub_month, $pub_year, $keywords, $submitter_id, $reg_key, $collection_id, $collection_id, $media_format, $platform, , '', $resourceurl, '', 1, $reg_key, $collection_id, $collection_id, '', '', '', $learning_resource_type, $rights_description, $cost);
$inserted = $inserted + 1;
}
}
if (! $useDatabase ) { # Print information if no database updates requested
printf("Title: %s\n", $title);
printf("Author First Name: %s\n", $author_fname);
printf("Author Last Name: %s\n", $author_lname);
printf("Subject: %s\n", $subject);
printf("URL: %s\n", $resourceurl);
printf("Keywords: %s\n", $keywords);
printf("Version: %s\n", $version);
printf("Notes: %s\n", $notes);
printf("Abstract: %s\n", $abstract);
printf("Learning Resource Type: %d\n", $learning_resource_type);
printf("Media Format: %d\n", $media_format);
printf("Primary Language: %s\n", $primary_language);
printf("Creation Date: %s\n", $creation_date);
printf("Revision Date: %s\n", $revision_date);
printf("Copyright: %s\n", $copyright);
printf("Publication Year: %4d\tPublication Month: %02d\n", $pub_year, $pub_month);
}
if ( $useDatabase ) {
$dbh->commit;
$dbh->disconnect;
}
}
Index: nsdl/nsdlloncapaorg/signon.pl
+++ nsdl/nsdlloncapaorg/signon.pl
#!/usr/bin/perl
# The LearningOnline Network with CAPA
# Generate Demo Users on Demo Server
#
# Only works on a library server!!!
# Has to be the only library server in the domain!!!
# Should not be used on a real production server.
use strict;
my $demodomain='msudemo';
my $demohome='msudemol1';
my $admemail='lon-capa@lon-capa.org';
my $demoserver='demo.lon-capa.org';
my %perlvar=();
my %form=();
my %democourses=();
my $courses;
my %hostname=();
my %hostdom=();
my %domaindescription=();
my %libserv=();
my %hostip=();
my %formfields=('afirst' => 'First Name',
'blast' => 'Last Name',
'ctitle' => 'Title',
'dinst' => 'Company/School',
'eaddr' => 'Street Address',
'fcity' => 'City, State, ZIP',
'gemail' => 'EMail Address',
'huser' => 'Desired Username',
'icomm' => 'Area of Interest/Comments');
use lib '/home/httpd/lib/perl/';
use LONCAPA::Configuration;
use IO::File;
use IO::Socket;
# ------------------------------------------------------------- Declutters URLs
sub declutter {
my $thisfn=shift;
$thisfn=~s/^$perlvar{'lonDocRoot'}//;
$thisfn=~s/^\///;
$thisfn=~s/^res\///;
$thisfn=~s/\?.+$//;
return $thisfn;
}
# -------------------------------------------------------- Escape Special Chars
sub escape {
my $str=shift;
$str =~ s/(\W)/"%".unpack('H2',$1)/eg;
return $str;
}
# ----------------------------------------------------- Un-Escape Special Chars
sub unescape {
my $str=shift;
$str =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg;
return $str;
}
# ------------------------------------------------------------------- Log stuff
sub logthis {
my $message=shift;
my $execdir=$perlvar{'lonDaemons'};
my $now=time;
my $local=localtime($now);
open(FH,">>$execdir/logs/demo.log");
print FH "$local ($$): $message\n";
close(FH);
return 1;
}
# -------------------------------------------------- Non-critical communication
sub reply {
my ($cmd,$server)=@_;
my $peerfile="$perlvar{'lonSockDir'}/$server";
my $client=IO::Socket::UNIX->new(Peer =>"$peerfile",
Type => SOCK_STREAM,
Timeout => 10)
or return "con_lost";
print $client "$cmd\n";
my $answer=<$client>;
chomp($answer);
if (!$answer) { $answer="con_lost"; }
return $answer;
}
sub put {
my ($namespace,$storehash,$udomain,$uname)=@_;
my $uhome=&homeserver($uname,$udomain);
my $items='';
foreach (keys %$storehash) {
$items.=&escape($_).'='.&escape($$storehash{$_}).'&';
}
$items=~s/\&$//;
return &reply("put:$udomain:$uname:$namespace:$items",$uhome);
}
# ------------- Modified routines from lonnet to make a new student in a course
# ---------------------- Find the homebase for a user from domain's lib servers
sub homeserver {
my ($uname,$udom)=@_;
my $index="$uname:$udom";
my $tryserver;
foreach $tryserver (keys %libserv) {
if ($hostdom{$tryserver} eq $udom) {
my $answer=reply("home:$udom:$uname",$tryserver);
if ($answer eq 'found') {
return $tryserver;
}
}
}
return 'no_host';
}
# ----------------------------------------------------------------- Assign Role
sub assignrole {
my ($uname,$url,$role,$end,$start)=@_;
my $command="encrypt:rolesput:$demodomain:auto:".
"$demodomain:$uname:$url".'_'."$role=$role";
if ($end) { $command.='_'.$end; }
if ($start) {
if ($end) {
$command.='_'.$start;
} else {
$command.='_0_'.$start;
}
}
return &reply($command,$demohome);
}
# --------------------------------------------------------------- Modify a user
sub modifyuser {
my ($uname, $upass, $first, $last)=@_;
my $udom=$demodomain;
my $desiredhome=$demohome;
my $middle='';
my $gene='';
my $umode='internal';
$udom=~s/\W//g;
$uname=~s/\W//g;
&logthis('Call to modify user '.$udom.', '.$uname.', '.
$umode.', '.$first.', '.
$last.', '.$desiredhome);
my $uhome=$demohome;
# ----------------------------------------------------------------- Create User
if (($umode) && ($upass)) {
my $unhome=$desiredhome;
if (($unhome eq '') || ($unhome eq 'no_host')) {
return 'error: unable to find a home server for '.$uname.
' in domain '.$udom;
}
my $reply=&reply('encrypt:makeuser:'.$udom.':'.$uname.':'.$umode.':'.
&escape($upass),$unhome);
unless ($reply eq 'ok') {
return 'error makeuser '.$udom.' '.$unhome.': '.$reply;
}
$uhome=&homeserver($uname,$udom,'true');
if (($uhome eq '') || ($uhome eq 'no_host') || ($uhome ne $unhome)) {
return 'error: verify home';
}
} # End of creation of new user
# -------------------------------------------------------------- Add names, etc
my %names;
if ($first) { $names{'firstname'} = $first; }
if ($last) { $names{'lastname'} = $last; }
my $reply = &put('environment', \%names, $udom,$uname);
if ($reply ne 'ok') { return 'error: '.$reply; }
&logthis('Success modifying user '.$udom.', '.$uname.', '.
$umode.', '.$first.', '.
$last);
return 'ok';
}
# -------------------------------------------------------------- Modify student
sub modifystudent {
my ($uname,$upass,$first,$last,$cnum,$cdom,$chome)=@_;
my $udom=$demodomain;
my $start=time;
my $end=$start+60*60*24*100;
# --------------------------------------------------------------- Make the user
my $reply=&modifyuser($uname,$upass,$first,$last);
unless ($reply eq 'ok') { return $reply; }
# -------------------------------------------------- Add student to course list
$reply=reply('put:'.$cdom.':'.$cnum.':classlist:'.
&escape($uname.':'.$udom).'='.
&escape($end.':'.$start),
$chome);
unless (($reply eq 'ok') || ($reply eq 'delayed')) {
return "error course list ".$reply;
}
# ---------------------------------------------------- Add student role to user
my $uurl='/'.$cdom.'_'.$cnum;
$uurl=~s/\_/\//g;
return &assignrole($uname,$uurl,'st',$end,$start);
}
sub enroll {
my ($uname,$upass,$first,$last)=@_;
&logthis("Going to enroll $uname for $courses");
my $returnval='';
foreach (split(/\&/,$courses)) {
my ($cdom,$chome,$cid)=split(/\:/,$democourses{$_});
if ($cid) {
$returnval.=
&modifystudent
($uname,$upass,$first,$last,$cid,$cdom,$chome)."<br>\n";
}
}
return $returnval;
}
# ------------------------------------------------------------- Make a password
sub genpass {
srand($$);
my @chars=('A'..'Z','a'..'z',0..9);
return join('',@chars[map{ rand @chars } (1..8)]);
}
sub inputline {
my ($name,$output)=@_;
print "\n<tr><td>$output:</td><td>".
"<input type='text' name='$name' value='$form{$name}' size='40'></td></tr>";
}
sub makeform {
print
"\n<form method='post'><p>After successful generation of a username, ".
"the access information will be emailed to you.<p><table>";
foreach (sort keys %formfields) {
&inputline($_,$formfields{$_});
}
print "</table>\n<input type='hidden' name='courses' value='$courses'>".
"<input name='submitted' value='Generate Demo User' type='submit'>".
"</form>\n";
}
# ----------------------------------------- Check the user supplied information
sub errorwrap {
my $msg=shift;
return '<font color="red">'.$msg.'</font>';
}
sub checkform {
unless ($form{'submitted'}) {
return 'Please fill out the form below to generate a demo user.';
}
# --- Sloppy check of email address
unless ($form{'gemail'}=~/^[^\@]+\@[^\@]+\.\w+$/) {
return &errorwrap('Not a valid email address');
}
# --- Check Username
$form{'huser'}=~s/[^A-Za-z0-9]//g;
$form{'huser'}=~tr/A-Z/a-z/;
$form{'huser'}=~s/^\d+//;
$form{'huser'}=substr($form{'huser'},0,10);
if (length($form{'huser'})<4) {
return &errorwrap('Username too short');
}
# see if user exists
my $reply=&reply('home:'.$demodomain.':'.$form{'huser'},$demohome);
if ($reply eq 'found') {
return &errorwrap('Username '.$form{'huser'}.' already exists.');
}
unless ($reply eq 'not_found') {
return &errorwrap('Sorry, demo logins currently not available.');
}
return 0;
}
sub sendemail {
my $upass=shift;
open(MAILOUT,"|mail '$form{'gemail'}' -c '$admemail' -s 'Your LON-CAPA Demo Access Info'");
print MAILOUT "Welcome to LON-CAPA!\n\n";
print MAILOUT "Somebody at $ENV{'REMOTE_ADDR'}, probably you, signed up\n";
print MAILOUT "for a demo login to\n\n http://$demoserver/\n\n";
print MAILOUT " Username: $form{'huser'}\n Password: $upass\n\n";
print MAILOUT "Additional information provided was:\n\n";
foreach (sort keys %formfields) {
print MAILOUT ' '.$formfields{$_}.': '.$form{$_}."\n";
}
print MAILOUT "\nCourse(s): $courses\n\nThank you for your interest in LON-CAPA!\n".&footer;
close MAILOUT;
}
sub readdemo {
open(IN,$perlvar{'lonTabDir'}.'/democourses.tab') ||
die "Could not open demo course file from ".$perlvar{'lonTabDir'};
while (my $line=<IN>) {
chomp($line);
my ($name,$descr)=split(/\&/,$line);
$democourses{$name}=$descr;
}
close(IN);
}
sub footer {
return (<<'ENDFOOTER');
--
www.lon-capa.org
lon-capa@lon-capa.org
User Help: http://help.lon-capa.org/
Bugs and Enhancements: http://bugs.lon-capa.org/
Mailing Lists: http://mail.lon-capa.org/
ENDFOOTER
}
# ================================================================ Main Program
print "Content-type: text/html\n\n".
"<html><head><title>LON-CAPA Demo Signup</title></head>".
"<body bgcolor='#FFFFFF'>\n".
"<h1>Welcome to the Learning<i>Online</i> Network with CAPA Demo Server!</h1>";
# ---------------------------------- Read loncapa_apache.conf and loncapa.conf
my $perlvarref=LONCAPA::Configuration::read_conf('loncapa_apache.conf',
'loncapa.conf');
%perlvar=%{$perlvarref};
undef $perlvarref;
delete $perlvar{'lonReceipt'}; # remove since sensitive and not needed
delete $perlvar{'lonSqlAccess'}; # remove since sensitive and not needed
&readdemo();
# ------------------------------------------------------------- Read hosts file
{
open(CONFIG,"$perlvar{'lonTabDir'}/hosts.tab");
while (my $configline=<CONFIG>) {
chomp($configline);
my ($id,$domain,$role,$name,$ip,$domdescr)=split(/:/,$configline);
$hostname{$id}=$name;
$hostdom{$id}=$domain;
$hostip{$id}=$ip;
if ($domdescr) {
$domaindescription{$domain}=$domdescr;
}
if ($role eq 'library') { $libserv{$id}=$name; }
}
close(CONFIG);
}
# --------------------------------------------------------------- Get post vars
my $buffer;
read(STDIN,$buffer,$ENV{'CONTENT_LENGTH'});
my @pairs=split(/&/,$buffer);
my $pair;
foreach $pair (@pairs) {
my ($name,$value) = split(/=/,$pair);
$value =~ tr/+/ /;
$value =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg;
$name =~ tr/+/ /;
$name =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg;
$name =~ s/[\~\'\"]//g;
$value =~ s/[\~\'\"]//g;
$form{$name}=$value;
}
# ------------------------------------------------ Get courses from get, if any
$courses=$ENV{'QUERY_STRING'};
$courses =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg;
$courses =~ s/[^a-z\&]//g;
unless ($courses) { $courses='default'; }
# ------------------------------------------------------------ Check Form Input
my $error=&checkform();
if ($error) {
print "<p><b>$error</b>";
&makeform();
} else {
my $upass=&genpass();
my $result=&enroll($form{'huser'},$upass,$form{'afirst'},$form{'blast'});
if ($result=~/error/) {
&logthis($result);
print &errorwrap('Sorry, demo functionality currently not available');
} else {
print "Your access information will be emailed to ".$form{'gemail'};
&sendemail($upass);
}
}
# ------------------------------------------------------------------------- End
print('<p><pre>'.&footer()."</pre></body></html>\n");
1;
--www1059402425--