Skip to content

Instantly share code, notes, and snippets.

@meisterluk

meisterluk/partner.pl

Created October 1, 2012 21:47
Show Gist options
  • Star 0 You must be signed in to star a gist
  • Fork 0 You must be signed in to fork a gist
  • Save meisterluk/3814675 to your computer and use it in GitHub Desktop.
Save meisterluk/3814675 to your computer and use it in GitHub Desktop.
Download ZIP
gdit_partner
Raw
partner.pl
#!/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/%sPartner%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;
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment