[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--