#!/usr/bin/perl -w

=encoding utf8

=head1 NAME

partner - partner pages for GDI course at TUGraz.

=head1 SYNOPSIS

You can use this program to adjust permissions according to an
association of partners provided. This way you don't have to set
two-way permissions for each pair of partners.

=head1 DESCRIPTION

=over
=item 1. Create a TWiki page I<PartnerAssignment>.
         This page shall contain a table with 2 columns.
         In the left column you have to provide the WikiName of the
         first partner and the second column contains the second partner.
         Actually you can provide as many columns as you would like too.
=item 2. Run this script as a TWiki page.
=item 3. This script will grant a student access to other student's
         "%WIKINAME%Partner%NUMBER%" page.
=back

=head1 EXAMPLE

A table provided in I<PartnerAssignment> looks like this:

    | LukasProkop | DonKnuth |
    | KarlVoit | WolfgangSlany |

If you run this script in the browser (with option C<assignment=2> set),
the page I<LukasProkopPartner2> will be modified from

    * Set ALLOWTOPICVIEW = Main.GdiTutorenGroup

to 

    * Set ALLOWTOPICVIEW = Main.GdiTutorenGroup, Main.DonKnuth

The empty (but existing) page I<DonKnuthPartner2> will contain

    * Set ALLOWTOPICVIEW = Main.LukasProkop

now. The same applies to the partners I<KarlVoit> and I<WolfgangSlany>.

=head1 WARNING

Please make sure that page I<PartnerAssignment> cannot be changed by
a student or students can add permissions for arbitrary other students
without leaving traces.

=head1 LICENSE

This script is heavily inspired by F<configure.pl>.

    Copyleft (C) 2012 Lukas Prokop.

    This program is free software; you can redistribute it and/or
    modify it under the terms of the GNU General Public License
    as published by the Free Software Foundation; either version 2
    of the License, or (at your option) any later version. For
    more details read LICENSE in the root of this distribution.

    This program is distributed in the hope that it will be useful,
    but WITHOUT ANY WARRANTY; without even the implied warranty of
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.

    As per the GPL, removal of this notice is prohibited.

=head1 FUNCTIONS

=cut

# Configuration, Setup, TWiki and CGI

package TWiki;

require 'setlib.cfg';

use strict;
use warnings;

use CGI;
use File::Basename;
use Tie::File;
use Data::Dumper;

BEGIN {
    # Set default current working directory (needed for mod_perl)
    if( $ENV{"SCRIPT_FILENAME"} && $ENV{"SCRIPT_FILENAME"} =~ /^(.+)\/[^\/]+$/ ) {
        chdir $1;
    }
    # Set library paths in @INC, at compile time
    unshift @INC, '.';
    require 'setlib.cfg';
}
use TWiki;

my $DEBUG = 0;
my $WEB = 'Main';

my $query = new CGI();
my $url = $query->url();
my $action = $query->param('action') || 'form';

my @meta = (
    CGI::meta({ 'http-equiv'=>'Pragma', content=>'no-cache' }),
    CGI::meta({ 'http-equiv'=>'Cache-Control', content=>'no-cache' }),
    CGI::meta({ 'http-equiv'=>'Expires', content=>0 }),
    CGI::meta({ name=>'robots', content=>'noindex' }),
);

# Generate standard page header
my $hdr = CGI::start_html(
    -title => 'TWiki Partner Configuration',
    -head => \@meta,
    -class => 'patternNoViewPage');

print CGI::header('text/html'). $hdr;














=head2 uniq

uniq - remove duplicate from a list

Take a list as first parameter and return a list with all duplicates removed.

=cut

sub uniq {
    return keys %{{ map { $_ => 1 } @_ }};
}


=head2 trim

trim - remove whitespace at start and end of string

Take some string as parameter and return a trimmed (remove whitespace
at beginning or end of string) version of it.

=cut

sub trim {
    for (@_ ? @_ : $_) {
        s/^\s+//, s/\s+$//
    }
    return $_[0];
}


=head2 default_ass_num

default_ass_num - Default assignment number

Based on the current timestamp the corresponding assignment number
will be returned.

=cut

sub default_ass_num {
    # assignment 3, if date > Aug 14th, else 2
    my @time = localtime(time);
    return (($time[4] == 11 and $time[3] > 16) or ($time[4] > 11)) ? 3 : 2;
}

=head2 split_commaseparated_list

split_commaseparated_list - take a string and split it by commas

=over
=item 1. Take some string and split it by commas.
=item 2. For each element: trim string.
=item 3. Return list
=back

=cut

sub split_commaseparated_list {
    my $char = ($#_ > 0) ? $_[1] : ',';
    my @lst = split(quotemeta($char), $_[0]);
    @lst = map { trim($_) } @lst;
    @lst = grep { $_ } @lst;
    return @lst;
}


=head2 replace_permline

replace_permline - Iterate over lines and replace permission line.

Take a list of source lines as first argument and a list of partners as second
argument. Iterate over source lines and search for a permission line looking
similar to this one:

       * Set ALLOWTOPICVIEW = Main.GdiTutorenGroup

The function will return the number of permission line occurences and the first
argument with a modified permission line
unless not B<exactly one permission line> was found.
If C<partners> is provided with C<("Main.DonKnuth", "Main.GdiTutorenGroup")>,
the permission line will be replaced by:

       * Set ALLOWTOPICVIEW = Main.GdiTutorenGroup, Main.DonKnuth

Therefore the set of WikiNames is merged. The order will not be preserved.

=cut

sub replace_permline {

    my $LINES = shift;
    my $partners = shift;
    my $regex = '^(\s+\*\s+Set\s+ALLOWTOPICVIEW\s*=\s*)(.*)\s*$';
    my $found = 0;

    foreach my $line (@$LINES) {
        if ($line =~ /$regex/i) {
            $found++;
        }
    }

    if ($found > 1 or $found == 0) {
        return $found, @$LINES;
    }

    $found = 0;
    foreach my $lineno (0 .. $#{@$LINES}) {

        my $line = @$LINES[$lineno];
        my @matches = ($line =~ /$regex/i);

        if (@matches) {
            next if $found++ > 0;

            my @all;
            my @list = split_commaseparated_list($matches[1]);

            if ($DEBUG) {
                print "<pre>\nDEBUG: replace_permline\n";
                print '  Found existing permission entries:   '.join(', ', @list)."\n";
                print '  Add provided partners:               '.join(', ', @$partners)."\n";
                print "\n</pre>\n";
            }

            push @all, @list;
            push @all, @$partners;
            @all = uniq @all;
            my $new_line = $matches[0] . join(', ', @all) . "\n";
            @$LINES[$lineno] = $new_line;
        }
    }

    return $found, @$LINES;
}


=head2 introduce_permline

introduce_permline - Introduce a new permission line in source code lines.

The following parameters are required:
=over
=item a list of source code lines (eg. C<(' ', '-- Main.LukasProkop')>)
=item the owner of the source code we are modifying
=item a list of TWiki members receiving Editor permissions (I<partners>)
=back

Make sure all WikiNames already have the Web name prepended!
Only the third parameter is allowed to be empty.

=cut

sub introduce_permline {
    my $lines_ = shift;
    my @LINES = @$lines_;

    my $owner = $WEB.'.'.${shift()};
    my @partners = shift->[0];

    if (!@partners) {
        return @LINES;
    }

    my $line1 = "<!--\n";
    my $line2 = '   * Set ALLOWTOPICVIEW = '.join(', ', ($owner, 'Main.GdiTutorenGroup', @partners))."\n";
    my $line3 = '   * Set ALLOWTOPICCHANGE = '.$owner."\n";
    my $line4 = '   * Set ALLOWTOPICRENAME = '.$owner."\n";
    my $line5 = "-->\n";

    unshift @LINES, $line5;
    unshift @LINES, $line4;
    unshift @LINES, $line3;
    unshift @LINES, $line2;
    unshift @LINES, $line1;

    if ($DEBUG) {
        print "<pre>\nDEBUG: introduce_permline\n";
        print '  Introduce VIEW permissions for ', join(', ', @partners), "\n</pre>\n";
    }

    return @LINES;
}


=head2 set_permissions

set_permissions - Set permissions to grant partners edit permissions
                  for assignment page.

=over
=item 1. First argument is the number of the assignment.
         Currently only {1, 2} is supported according to GDI WS 2012/13.
=item 2. Second argument has to be the TWikiName of the page owner.
=item 3. A list of partners (WikiNames) to grant permissions to
=back

=cut

sub set_permissions {

    my $ass_num = $_[0];
    my $page_owner = $_[1];
    my @partners = @_[2 .. $#_];

    if ($DEBUG) {
        print "<pre>\nDEBUG: set_permissions\n";
        print '  Assignment number:   '.$ass_num."\n";
        print '  Page owner:          '.$page_owner."\n";
        print '  Partners:            {'.join(', ', @partners)."}\n</pre>\n";
    }

    my $ass_file = sprintf('%s/%s/%sAbgabe%d.txt', $TWiki::cfg{DataDir},
                           $WEB, $page_owner, $ass_num);

    # add web before WikiName
    @partners = map { $WEB.'.'.$_ } @partners;

    if (-e $ass_file) {

        if (!open(FILEDESC, '<', $ass_file)) {
            print '  <p style="color:red">ERROR: Could not open "'.basename($ass_file).'" for reading.</p>'
                 ."\n".'  <!-- '.$ass_file.' -->';
            return 0;
        }

        my @LINES = <FILEDESC>;
        my $LINES;

        if ($DEBUG) {
            print '<p>Source code before:</p>', "\n", '<pre style="color:#CCC">';
            print join("", @LINES);
            print '</pre>';
        }

        my @result = replace_permline(\@LINES, \@partners);
        my $found = $result[0];
        shift @result;
        @LINES = @result;

        if ($found == 0) {
            # Set ALLOWTOPICVIEW not found in document
            # Introduce permission settings line in HTML comment.
            @LINES = introduce_permline(\@LINES, \$page_owner, \@partners);
            print '  <p>Set permissions for "'.$page_owner
                 .'" by introducing a new permission line.</p>'."\n";

        } elsif ($found == 1) {
            # Perfect. One occurence replaced.
            print '  <p>Set permissions for "'.$page_owner.'" by adding '
                 .'partners {'.join(', ', @partners).'}.</p>'."\n";

        } else {
            # Unusual situation. Abort.
            print '  <p style="color:red">ERROR: I have found several '
                 .'permission lines in "'.basename($ass_file).'". '
                 .'Before screwing up, I will leave the file and abort.'
                 .'</p>'."\n".'  <!-- '.$ass_file.' -->'."\n";
            return 0;
        }

        if ($DEBUG) {
            print '<p>Source code after:</p>', "\n", '<pre style="color:#CCC">';
            print join("", @LINES);
            print '</pre>';
        }

        close FILEDESC;

        if (!open FILEDESC, '>', $ass_file) {
            print '  <p style="color:red">ERROR: Could not write new '
                 .'permissions to file "'.basename($ass_file).'.</p>'."\n"
                 .'  <!-- '.$ass_file.' -->'."\n";
            return 0;
        }
        print FILEDESC join('', @LINES);
        close FILEDESC;

        return 1;

    } else {

        print '  <p style="color:red">ERROR: File "'.basename($ass_file).'" not found.</p>'
             ."\n".'  <!-- '.$ass_file.' -->'."\n";
        return 0;
    }
}


=head2 read_partners

read_partners - Read page PartnerAssignment and return
                an array (success, list of list of partners).

=cut

sub read_partners {

    my $pattern = '%s/%s/PartnerAssignment.txt';
    my $pa_file = sprintf($pattern, $TWiki::cfg{DataDir}, $WEB);
    my @partners = ();
    my ($errmsg, @return) = '', ();

    if (-e $pa_file) {

        $errmsg = "Could not read file ".basename($pa_file);
        open(my $file, $pa_file) or return (($errmsg), ());

        foreach my $line (<$file>) {
            if ($line =~ /^(\s*\|\s*)([^|]+\|\s*)*$/)
            {
                my @lst = split_commaseparated_list($line, '|');

                my $find = 0;
                for my $name (@lst) {
                    if ($name =~ /[ ]/) {
                        print '  <p style="color:red">ERROR: Table cell '
                              .'contains name with space ("'.$name.'"). '
                              .'I will exclude this line.</p>'."\n";
                        $find = 1;
                    }
                }
                if ($find) {
                    next;
                }

                if ($#lst > 0) {
                    push @partners, [@lst];
                } else {
                    print '  <p style="color:red">ERROR: Found table line with "'.
                          "@lst\" but it does not contain another partner.</p>\n";
                }
            }
        }

        if ($DEBUG) {
            print "<pre>\nDEBUG: read_partners\n";
            for my $clique (@partners) {
                print '  new row'."\n";
                foreach (@$clique) {
                    print "    col: '", $_, "'\n";
                }
            }
            print "</pre>\n";
        }

        close($file);
        return (\@return, \@partners);

    } else {

        $errmsg = sprintf('No such file "%s". '
                         .'Did you create this Wiki page? <!-- %s -->',
                         basename($pa_file), $pa_file);
        return ([$errmsg], []);
    }
}

=head2 print_errors

print_errors - Print errors from the list of error messages provided.

=cut

sub print_errors {

    my @errors = shift;

    print '  <p>'."\n";
    print '    Error parsing partner assignments.'."\n";
    print '    The following error message was returned:'."\n";
    print '  </p>'."\n";

    print '  <ul>'."\n";
    foreach (@errors) {
         print '    <li style="color:red">ERROR: '.$_.'</li>'."\n";
    }
    print '  </ul>'."\n";
}


=head1 ROUTE form (default route)

HTML form to provide parameters to set permissions.

=cut

sub page_form {

    print '  <h1>Set partner permissions</h1>'."\n";
    print '  <p>'."\n";
    print '    I was looking for TWiki tables in "'.$WEB.'PartnerAssignment" ';
    print     'and have found the following set of partners.'."\n";
    print '  </p>'."\n\n";
    print '  <h2>Partners</h2>'."\n";

    my ($errors, $partner_cliques) = read_partners();

    if (@$errors) {

        print_errors(@$errors);

    } else {

        print '  <ul>'."\n";
        for my $partners (@$partner_cliques) {
             my $list = join(', ', @$partners);
	     print '    <li>('.$list.')</li>'."\n";
        }
        if (!@$partner_cliques) {
             print '    <li style="color:#999">No partners could be found.</li>'."\n";
        }
        print '  </ul>'."\n\n";

        print '  <h2>Set permissions</h2>'."\n";
        print '  <form action="partner" method="post">'."\n";
        print '    <input type="submit" value="Set permissions" /> for all partners at'."\n";
        print '    %WIKINAME%Partner<input type="text" readonly="true" size="1" name="ass_num" value="'.default_ass_num().'" />'."\n";
        print '    <input type="hidden" name="action" value="set">'."\n";
        print '  </form>'."\n";
    }

    print '</body>'."\n";
    print '</html>'."\n";

    return 1;
}

=head1 ROUTE set

Set permission by modifying assignment files.
Requires POST parameter C<ass_num>.

=cut

sub page_set {

    my ($errors, $partner_cliques) = read_partners();

    if (@$errors) {

        print_errors(@$errors);

    } else {

        # this loop iterates over all cliques, selects one person
        # and calls set_permissions with the person as owner
        #                           and his clique as partners

        my $all = 1;
        for my $partners (@$partner_cliques) {
            for my $partner (@$partners) {
                my @clique = grep { $_ ne $partner } @$partners;

                if ($DEBUG) {
                    print "<pre>\nDEBUG: page_set\n";
                    print '  Complete group:      {', join(', ', @$partners), '}'."\n";
                    print '  Partners:            {', join(', ', @clique), '}'."\n";
                    print '  Owner:               ', $partner, "\n";
                    print '  assignment number:   ', $query->param('ass_num'), "\n</pre>\n";
                }

                my $success = set_permissions($query->param('ass_num'), $partner, @clique);
                if (!$success) {
                    print '  <p style="color:red">ERROR: Abort processing "'.$partner.'".</p>'."\n";
                    $all = 0;
                }
            }
        }

        if ($all) {
            print '  <p style="color:green">All permissions were set successfully.</p>'."\n";
        }
    }

    print "\n";
    print '  </body>'."\n";
    print '</html>'."\n";

    return 1;
}




if ( $action eq 'set' ) {
    page_set() or die('Fatal error');
} else {  # $action eq 'form'
    page_form() or die('Fatal error');
}

1;
