#!/usr/bin/env perl
#
# copy Sakai assessments, to test samigo SOAP methods partly added by EDIA
#
# $Id$

# a script to copy assessments in QTI format

use strict;
use warnings;

use open qw(:std :utf8);

use SOAP::Lite;
#use SOAP::Lite +trace => [ 'all' ];
use File::Path qw(make_path);

use Data::Dumper;
$Data::Dumper::Indent = 1;

use XML::LibXML;
use XML::LibXML::XPathContext;

use Getopt::Std;

use open ':std', ':encoding(UTF-8)';    # support UTF-8 output

#--- parameter specification: ---#
#

my %opt;
getopts( 'H:P:d:hp:u:Nf:1?', \%opt ) or die "Cannot parse command line\n";

HELP_MESSAGE() if $opt{h} || $opt{'?'};

my ( $upordown, $sitename ) = @ARGV;

if ( !defined($sitename) || !grep { $_ eq $upordown } qw(up down) )
{
  die "Specify 'up' or 'down' and the site name; use -h for help\n";
}

my $user      = $opt{u} // $ENV{SAKAI_USER} // 'admin';
my $password  = $opt{p} // $ENV{SAKAI_PASSWORD} // 'minda';
my $host      = $opt{H} // $ENV{SAKAI_HOST} // 'sakai2.win.tue.nl';
my $port      = $opt{P} // $ENV{SAKAI_PORT} // ( $opt{N} ? 80 : 443 );
my $http      = $opt{N} ? 'http' : ( $ENV{SAKAI_PROTOCOL} // 'https' );
my $format    = $opt{f} // $ENV{QTI_FORMAT} // 'QTI_1_2';
my $directory = $opt{d} // 'qti';
my $uniqnames = $opt{1} // 0;

my @formats = qw(QTI_1_2 QTI_2_0 Markup);

grep { $format eq $_ } @formats
 or die join( ' ', 'format must be one of:', @formats ), "\n";

if ( $upordown eq 'up' && $format ne 'QTI_1_2' )
{
  die "Sorry, uploading is only implemented for format QTI_1_2\n";
}

my $server = "$http://$host:$port/";

my $ns_uri = 'http://webservices.sakaiproject.org/';

#--- Usage ---#
#

sub HELP_MESSAGE
{
  print STDERR <<ZZ;

Usage: $0 [options] [up|down] title

to upload or download the assessments (tests and quizzes)
from the Sakai site with the given title.

Argument values:

  up

    Upload assignments to the Sakai site.
    Works only with QTI_1_2 format.
    A warning will be shown:
      Element 'xmlstring' uses the reserved prefix 'XML' (in any case) at /usr/local/share/perl5/site_perl/5.26/SOAP/Lite.pm line 1483.
    but this is harmless.

  down

    Download assignments from the qti site.
    The download directory (see -d) must not yet exist, it will be created.

  title

    This must be a valid Sakai site title.
    Note: if it contains special characters, such as spaces,
    enclose it in single quotes.

Options:

  -1

     When uploading, skip assessments
     when an assessment with the same title already exists.
     This can be used to avoid creating duplicates.

  -d directory

    The directory containing the QTI files.
    The default is 'qti'.
    Must exist when 'up' is specified;
    must not exist when 'down' is specified.

  -f QTI_1_2|QTI_2_0|Markup

     The format in which to download/upload the assignments.
     Can also be specified in the \$QTI_FORMAT environment variable.
     The default is QTI_1_2.
     Uploading is only supported with QTI_1_2.

  -u username

     The Sakai username to use.
     Can also be specified in the \$SAKAI_USER environment variable.

  -p password

     The password for the Sakai username to use.
     Can also be specified in the \$SAKAI_PASSWORD environment variable.

  -H host

     The Sakai server's hostname, if non-default.
     Can also be specified in the \$SAKAI_HOST environment variable.

  -P port

     The Sakai server's port number, if non-default.
     Can also be specified in the \$SAKAI_PORT environment variable.

  -N

     Use http, not https.
     Alternatively, set the \$SAKAI_PROTOCOL environment variable to 'http'.

ZZ

  exit(0);
}

#--- call input construction: ---#
#

sub service
{
  my $proxy = $server . 'sakai-ws/soap/' . $_[0];

  SOAP::Lite->uri($ns_uri)->proxy($proxy)->on_action( sub { return '' } )
   or die "No SOAP login object for service $proxy\n";
}

sub method
{
  SOAP::Data->name( "ns1:" . $_[0] )->attr( { 'xmlns:ns1' => $ns_uri } );
}

sub soap_data_name
{
  #warn sprintf("SOAP parameter: %s => %s\n", @_);
  SOAP::Data->name(@_)->type('string')    # assessmentIds are strings!
}

sub param
{
  # feed the arguments pairwise to SOAP::Data->name()
  map { soap_data_name( $_[$_], $_[ $_ + 1 ] ) }
   grep { !( $_ % 2 ) } ( 0 .. $#_ );
}

sub call
{
  my ( $service, $method, @params ) = @_;

  $service->call( method($method), param(@params) )
   or die sprintf( "failed call %s(%s)\n", $method, join( ', ', @params ) );
}

#--- for deconstructing output: ---#
#

my $xml_parser = new XML::LibXML(
  line_numbers     => 1,
  load_ext_dtd     => 0,    # disables validation, says the documentation
  no_blanks        => 1,
  clean_namespaces => 1,
  no_network       => 1,
  pedantic_parser  => 1
) or die "cannot create the XML parser\n";

my $xpath_context = new XML::LibXML::XPathContext;

sub xmldoc
{
  my $doc = eval { $xml_parser->parse_string( $_[0] ) }
   or die "cannot parse SOAP result: $@\n";
  $doc->getDocumentElement;
}

sub xpath
{
  ref( $_[1] ) and $_[1]->can('findnodes')
   or die "bug: xpath() called with wrong argument(s)\n";

  my @nodes = $xpath_context->findnodes(@_)->get_nodelist;
  wantarray() ? @nodes : $nodes[0];
}

sub save_qti
{
  my ( $dir, $id, $xml ) = @_;

  open( my $fh, '>', "$dir/$id.qti" )
   or die "Cannot write to $dir/$id.qti: $!\n";

  print $fh $xml;

  close($fh)
   or die "Error writing to $dir/$id.qti: $!\n";

  warn "saved $dir/$id.qti\n";
}

sub open_qti
{
  my ( $dir, $id ) = @_;

  open( my $fh, '<', "$dir/$id.qti" )
   or die "Cannot read from $dir/$id.qti: $!\n";

  my $xml = join( '', <$fh> );

  close($fh)
   or die "Error reading from $dir/$id.qti: $!\n";

  warn "read $dir/$id.qti\n";

  $xml;
}

sub qti_ids_in
{
  my ($dir) = @_;

  map { m#/(\d+)\.qti$# ? ($1) : () } glob("$dir/*.qti");
}

sub assessment_title
{
  my ($xmldoc) = @_;

  if ( $format eq 'QTI_1_2' )
  {
    my @assmt = xpath( '//assessment', $xmldoc )
     // die "cannot find assessment, malformed QTI?\n";
    my $title = $assmt[0]->getAttribute('title')
     // die "cannot find assessment title, malformed QTI?\n";
    $title;
  }
  else
  {
    die "sorry, cannot determine assessment title for format $format\n";
  }
}

#--- here we go ---#
#

my $login_service = service('login');

#my $login = $login_service->loginToServer(id=>$user, pw=>$password)
my $login = call(
  $login_service,
  'loginToServer',
  'id' => $user,
  'pw' => $password
);

my ( $session, $server_direct ) = split( /,/, $login->result )
 or die "Cannot log in as $user to site $server\n";

#warn "session is: $session\n";

my $sites =
 call( service('sakai'), 'getAllSitesForCurrentUser', 'sessionid' => $session );

#print $sites->result;
# returns <list><item+><siteId>text</siteId><siteTitle>text</siteTitle><siteId></item+></list>

my %siteid2title;

foreach my $site ( xpath( '//list/item', xmldoc( $sites->result ) ) )
{
  my ($id)    = xpath( 'siteId',    $site )->textContent;
  my ($title) = xpath( 'siteTitle', $site )->textContent;
  #warn "site $id has title $title\n";

  $siteid2title{$id} = $title;
}

my %sitetitle2id = reverse(%siteid2title);

if ( !defined $sitetitle2id{$sitename} )
{
  warn "No site found with name $sitename\n";

  if ( my @sitenames = sort keys %sitetitle2id )
  {
    warn "Try one of these:\n";
    warn "$_\n" for @sitenames;
  }
  else
  {
    warn "As a matter of fact, no sites can be found at all.\n";
  }

  die "Thank you for your patronage. Please call again.\n";
}

my $tnq_service = service('testsandquizzes');

my %site2assignments;

my @assmt_attrs = ( 'id', 'title', 'status' );

sub site2assessments
# given a site id,
# returns the list of its assessments, each as a hashref
{
  my ($site_id) = @_;

  my $assessments = call(
    $tnq_service,
    'listAssessmentsForSite',
    'sessionId' => $session,
    'siteId'    => $site_id
  );

  #print $assessments->result, "\n";
  # returns <list><item+><assessmentId>number</assessmentId><assessmentTitle>text</assessmentTitle><assessmentStatus>TEXT</assessmentStatus></item>

  my @assmts;

  foreach my $assmt ( xpath( '/list/item', xmldoc( $assessments->result ) ) )
  {
    my %attr;

    foreach my $name (@assmt_attrs)
    {
      my $Name = $name =~ s/./\U$&/r;

      $attr{$name} = xpath( "assessment$Name", $assmt )->textContent;
    }

    push( @assmts, {%attr} );
  }

  @assmts;
}

my $site_id = $sitetitle2id{$sitename};

my @assmts = site2assessments($site_id);
warn sprintf( "%d assessments in site %s\n", scalar(@assmts), $sitename );
#warn join( ' ', 'with ids:', map { $_->{id} } @assmts ), "\n";

# with -1, don't import an assessment if one with that title already exists
my %title2assmt = map { $_->{title} => $_ } @assmts;
#warn sprintf( "%d different assessment titles\n", scalar( keys %title2assmt ) );
#warn "$_\n" for sort keys %title2assmt;

if ( $upordown eq 'down' )
{
  # download all assessments in site $sitename to $directory/$id.qti

  @assmts
   or die "No assessments found in site $sitename\n";

  if ( -d $directory )
  {
    die "aborting, download directory already exists: $directory\n";
  }
  elsif ( !make_path($directory) )
  {
    die "Directory for QTI assignments cannot be made: $directory\n";
  }

  foreach my $assmt (@assmts)
  {
    my $id = $assmt->{id} // die "whoops, assessment without id!\n";

    #warn sprintf( "assessment %s (%s) is %s\n", map { $assmt->{$_} } @assmt_attrs );

    my $export = call(
      $tnq_service,
      'exportAssessment',
      'sessionId'    => $session,
      'assessmentId' => $id,
      'format'       => $format
    ) // die "cannot export assessment $id\n";

    if ( $export->fault )
    {
      warn "error calling exportAssessment($id):\n", $export->faultstring, "\n";
    }
    else
    {
      save_qti( $directory, $id, $export->result );
    }
  }
}
else
{
  # upload all assessments from $directory/$id.qti to site $sitename
  #
  if ( !-d $directory )
  {
    die
     "Directory with QTI assignments not found or no directory: $directory\n";
  }

  my @ids = qti_ids_in($directory)
   or die "no QTI assignments found in $directory\n";

  foreach my $id (@ids)
  {
    my $xml = open_qti( $directory, $id );

    my $xmldoc = xmldoc($xml);

    if ( !$xmldoc )
    {
      warn "Skipping. not a valid XML document: $directory/$id.qti\n";
      next;
    }

    my $title = assessment_title($xmldoc);

    warn "assessment $id has title: $title\n";

    if ( $uniqnames && defined $title2assmt{$title} )
    {
      warn "an assessment with this title already exists, skipping it\n";
      next;
    }

    my $import = call(
      $tnq_service,
      'createAssessmentFromExport',
      'sessionid' => $session,
      'siteid'    => $site_id,
      #'siteproperty' => 'SITE_ID',  # unclear what to specify here
      # but when searching for site id, we can leave it blank (not: omit it), see
      # webservices/cxf/src/java/org/sakaiproject/webservices/TestsAndQuizzes.java
      'siteproperty' => '',
      'xmlstring'    => $xml
    ) // die "cannot import assessment $id\n";

    if ( $import->fault )
    {
      warn "error calling createAssessmentFromExport($id):\n",
       $import->faultstring, "\n";
    }
    elsif ( !$import->result )
    {
      warn "importing failed for assessment $id\n";
    }
  }
}