--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/qf.cgi	Fri Oct 05 12:30:45 2012 +0200
@@ -0,0 +1,168 @@
+#!/usr/bin/perl
+
+#    Copyright (C) 2012  Matthias Förste
+#
+#    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 3 of the License, or
+#    (at your option) any later version.
+#
+#    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.  See the
+#    GNU General Public License for more details.
+#
+#    You should have received a copy of the GNU General Public License
+#    along with this program.  If not, see <http://www.gnu.org/licenses/>.
+#
+#    Matthias Förste <foerste@schlittermann.de>
+
+=encoding utf8
+=cut
+
+use strict;
+use warnings;
+
+use CGI;
+#use Net::Sieve;
+use Net::ManageSieve;
+
+my $host = 'localhost';
+my $verify_crt = 0;
+my $requiretls = 'require';
+my $script_name = 'ius';
+
+my $status = 'OK';
+
+# error( [ { status => 'user visible message' } ] [,] [ @messages ] );
+sub error {
+
+    my $h;
+    $status = ( ref $_[0] eq 'HASH' and $h = shift and defined $h->{status} ) ? delete $h->{status} : 'Interner Fehler';
+    warn @_ if defined @_ and @_;
+    exit -1;
+
+}
+
+sub redirect {
+
+    my ($address, $keep) = @_;
+    error "need address" unless $address;
+    $address =~ s/"/\\"/g;
+    return "redirect \"$address\";" . $keep ? "\nkeep;" : '';
+
+}
+
+sub script_exists {
+
+    my ($sieve, $script) = @_;
+    my $scripts = $sieve->listscripts
+        or error "Can't list scripts: $@";
+    return $script ~~ @{$scripts};
+
+}
+
+sub script_isactive {
+
+    my ($sieve, $script) = @_;
+    my $scripts = $sieve->listscripts
+        or error "Can't list scripts: $@";
+    return $script eq $scripts->[-1];
+
+}
+
+my $css = <<EOC;
+body {
+        font-family: Helvetica, Arial, sans-serif;
+}
+h3#header {
+    background-color: #d60029;
+    color: #fff;
+    padding: 1em;
+}
+input[type=text], input[type=password] {
+    text-align: right;
+}
+EOC
+
+my $q = new CGI;
+my $title = 'Mailumleitung einrichten';
+
+
+print $q->header( -charset => 'UTF-8' );
+print $q->start_html(
+    -title  => $title,
+    -style  => { -code => $css },
+    -onload => q{document.forms['theform'].elements['user'].focus();}
+  ),
+  $q->h3( { -id => 'header' }, $title ),
+  $q->hr;
+
+my $p;
+$p->{$_} = $q->param($_) for qw(user pass address keep add del);
+
+print $q->start_form( -id => 'theform' ),
+  $q->table(
+    $q->Tr( $q->td('Ihr Nutzername'), $q->td( $q->textfield('user') ) ),
+    $q->Tr( $q->td('Ihr Passwort'), $q->td( $q->password_field('pass') ) ),
+    $q->Tr( $q->td('Umleitung zu'), $q->td( $q->textfield('address') ) ),
+    $q->Tr( $q->td( $q->checkbox(
+            -name => 'keep',
+            -label => 'Kopie behalten?',
+            -checked => 1) ) ),
+    $q->Tr( $q->td( $q->submit( { -name => 'add', -value => 'einrichten' } ) ),
+        $q->td( $q->submit( { -name => 'del', -value => 'Umleitung entfernen' } ) )
+    ),
+  ),
+  $q->end_form;
+
+error( { status => 'Bitte geben Sie Ihren Nutzernamen an.' } )  unless defined $p->{user} and $p->{user} ne '';
+error( { status => 'Bitte geben Sie Ihr Passwort an.' } )  unless defined $p->{pass} and $p->{pass} ne '';
+
+my $s = Net::ManageSieve->new(host => $host, tls => $requiretls ) or error "Can't connect sieve service";
+error( { status => 'Anmeldung fehlgeschlagen.' }, "auth failed: $@" ) unless ($s->login($p->{user}, $p->{pass}));
+
+if ( defined $p->{add} and $p->{add} ne '' ) {
+
+    error( { status => 'Bitte geben Sie eine Umleitungsaddresse an.' } ) unless defined $p->{address} and $p->{address} ne '';
+    error "Can't putscript: $@" unless $s->putscript($script_name, redirect($p->{address}, $p->{keep}));
+    error "Can't setactive: $@" unless $s->setactive($script_name);
+    $status = 'Umleitung eingerichtet.';
+
+} elsif ( defined $p->{del} and $p->{del} ne '' ) {
+
+    error "Can't setactive: $@" if script_isactive($s, $script_name) and not $s->setactive();
+    error "Can't deletescript: $@" if script_exists($s, $script_name) and not $s->deletescript($script_name);
+    $status = 'Umleitung entfernt.';
+
+} else { error "Nothing to do!"; }
+
+exit 0;
+
+END {
+    defined $s and $s->logout;
+    print $q->hr, $q->p( $status ), $q->end_html;
+}
+
+__END__
+
+=pod
+
+=head1 NAME
+
+qf.cgi - quick filter web interface
+
+=head1 SYNOPSIS
+
+qf.cgi
+
+=head1 DESCRIPTION
+
+Currently this script allows to set/remove a redirection for exactly one
+address.
+
+=head1 AUTHOR
+
+Matthias Förste <foerste@schlittermann.de>
+
+=cut