#!/usr/bin/env perl
#
# test samigo SOAP methods partly added by EDIA
#
# $Id$

# this is a parallellized version of ./sakai-list-assesssments.pl

use strict;
use warnings;

use SOAP::Lite;
#use SOAP::Lite +trace => [ all ];

use Parallel::ForkManager;
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:j:p:u:Nf:', \%opt ) or die "Cannot parse command line\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 $nrjobs   = $opt{j} // $ENV{SAKAI_TEST_PARALLELLISM} // 5;
my $http     = $opt{N} ? 'http' : ( $ENV{SAKAI_PROTOCOL} // 'https' );
my $format   = $opt{f} // $ENV{QTI_FORMAT} // 'QTI_1_2';

my @formats = qw(QTI_1_2 QTI_2_0 Markup);

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

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

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

#--- 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];
}

#--- 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";

# testing methods provided by

my $sakai_service = service('sakai');

my $getUDNFCU = call(
  $sakai_service,
  'getUserDisplayNameForCurrentUser',
  'sessionid' => $session
) or die "Cannot get display name for $user\n";

warn "the current user is ", $getUDNFCU->result, "\n";

my $sites =
 call( $sakai_service, '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);

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 @ids;

foreach my $name ( sort keys %sitetitle2id )
{
  #next unless $name eq 'Feature demo';
  #next unless $name eq "B. Koenig's playground";

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

    push( @ids, $id );
  }
}

@ids = sort { $a <=> $b } @ids;
#@ids = @ids[ 0 .. 9 ];

my %id2response;

my $pm = new Parallel::ForkManager($nrjobs);
$pm->run_on_finish(
  sub {
    my ( $pid, $rc, $ident, $sig, $core, $var ) = @_;

    my ( $id, $result, $fault, $faultstring ) = @$var;
    $id2response{$id} = [ $result, $fault, $faultstring ];
  }
);

warn "about to export ", scalar(@ids), " assignments ...\n";

foreach my $id (@ids)
{
  $pm->start and next;

  warn "exporting assignment $id\n";

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

  warn "exported  assignment $id\n";

  $pm->finish( 0, [ $id, $r->result, $r->fault, $r->faultstring ] );

  warn "finished  assignment $id\n";
}

warn "awaiting all results ...\n";

$pm->wait_all_children;

warn "printing ", scalar( keys %id2response ), " results ...\n";

foreach my $id (@ids)
{
  my ( $result, $fault, $faultstring ) = @{ $id2response{$id} };

  if ($fault)
  {
    warn "error calling exportAssessment($id):\n", $faultstring, "\n";
  }
  else
  {
    print $result;
  }
}