1 #!/usr/bin/perl

     2 

     3 #    Copyright (C) 2012  Matthias Förste

     4 #

     5 #    This program is free software: you can redistribute it and/or modify

     6 #    it under the terms of the GNU General Public License as published by

     7 #    the Free Software Foundation, either version 3 of the License, or

     8 #    (at your option) any later version.

     9 #

    10 #    This program is distributed in the hope that it will be useful,

    11 #    but WITHOUT ANY WARRANTY; without even the implied warranty of

    12 #    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the

    13 #    GNU General Public License for more details.

    14 #

    15 #    You should have received a copy of the GNU General Public License

    16 #    along with this program.  If not, see <http://www.gnu.org/licenses/>.

    17 #

    18 #    Matthias Förste <foerste@schlittermann.de>

    19 

    20 =encoding utf8

    21 =cut

    22 

    23 use strict;

    24 use warnings;

    25 

    26 use CGI;

    27 #use Net::Sieve;

    28 use Net::ManageSieve;

    29 

    30 my $host = 'localhost';

    31 my $verify_crt = 0;

    32 my $requiretls = 'require';

    33 my $script_name = 'ius';

    34 

    35 my $status = 'OK';

    36 

    37 # error( [ { status => 'user visible message' } ] [,] [ @messages ] );

    38 sub error {

    39 

    40     my $h;

    41     $status = ( ref $_[0] eq 'HASH' and $h = shift and defined $h->{status} ) ? delete $h->{status} : 'Interner Fehler';

    42     warn @_ if defined @_ and @_;

    43     exit -1;

    44 

    45 }

    46 

    47 sub redirect {

    48 

    49     my ($address, $keep) = @_;

    50     error "need address" unless $address;

    51     $address =~ s/"/\\"/g;

    52     return "redirect \"$address\";" . $keep ? "\nkeep;" : '';

    53 

    54 }

    55 

    56 sub script_exists {

    57 

    58     my ($sieve, $script) = @_;

    59     my $scripts = $sieve->listscripts

    60         or error "Can't list scripts: $@";

    61     return $script ~~ @{$scripts};

    62 

    63 }

    64 

    65 sub script_isactive {

    66 

    67     my ($sieve, $script) = @_;

    68     my $scripts = $sieve->listscripts

    69         or error "Can't list scripts: $@";

    70     return $script eq $scripts->[-1];

    71 

    72 }

    73 

    74 my $css = <<EOC;

    75 body {

    76         font-family: Helvetica, Arial, sans-serif;

    77 }

    78 h3#header {

    79     background-color: #d60029;

    80     color: #fff;

    81     padding: 1em;

    82 }

    83 input[type=text], input[type=password] {

    84     text-align: right;

    85 }

    86 EOC

    87 

    88 my $q = new CGI;

    89 my $title = 'Mailumleitung einrichten';

    90 

    91 

    92 print $q->header( -charset => 'UTF-8' );

    93 print $q->start_html(

    94     -title  => $title,

    95     -style  => { -code => $css },

    96     -onload => q{document.forms['theform'].elements['user'].focus();}

    97   ),

    98   $q->h3( { -id => 'header' }, $title ),

    99   $q->hr;

   100 

   101 my $p;

   102 $p->{$_} = $q->param($_) for qw(user pass address keep add del);

   103 

   104 print $q->start_form( -id => 'theform' ),

   105   $q->table(

   106     $q->Tr( $q->td('Ihr Nutzername'), $q->td( $q->textfield('user') ) ),

   107     $q->Tr( $q->td('Ihr Passwort'), $q->td( $q->password_field('pass') ) ),

   108     $q->Tr( $q->td('Umleitung zu'), $q->td( $q->textfield('address') ) ),

   109     $q->Tr( $q->td( $q->checkbox(

   110             -name => 'keep',

   111             -label => 'Kopie behalten?',

   112             -checked => 1) ) ),

   113     $q->Tr( $q->td( $q->submit( { -name => 'add', -value => 'einrichten' } ) ),

   114         $q->td( $q->submit( { -name => 'del', -value => 'Umleitung entfernen' } ) )

   115     ),

   116   ),

   117   $q->end_form;

   118 

   119 error( { status => 'Bitte geben Sie Ihren Nutzernamen an.' } )  unless defined $p->{user} and $p->{user} ne '';

   120 error( { status => 'Bitte geben Sie Ihr Passwort an.' } )  unless defined $p->{pass} and $p->{pass} ne '';

   121 

   122 my $s = Net::ManageSieve->new(host => $host, tls => $requiretls ) or error "Can't connect sieve service";

   123 error( { status => 'Anmeldung fehlgeschlagen.' }, "auth failed: $@" ) unless ($s->login($p->{user}, $p->{pass}));

   124 

   125 if ( defined $p->{add} and $p->{add} ne '' ) {

   126 

   127     error( { status => 'Bitte geben Sie eine Umleitungsaddresse an.' } ) unless defined $p->{address} and $p->{address} ne '';

   128     error "Can't putscript: $@" unless $s->putscript($script_name, redirect($p->{address}, $p->{keep}));

   129     error "Can't setactive: $@" unless $s->setactive($script_name);

   130     $status = 'Umleitung eingerichtet.';

   131 

   132 } elsif ( defined $p->{del} and $p->{del} ne '' ) {

   133 

   134     error "Can't setactive: $@" if script_isactive($s, $script_name) and not $s->setactive();

   135     error "Can't deletescript: $@" if script_exists($s, $script_name) and not $s->deletescript($script_name);

   136     $status = 'Umleitung entfernt.';

   137 

   138 } else { error "Nothing to do!"; }

   139 

   140 exit 0;

   141 

   142 END {

   143     defined $s and $s->logout;

   144     print $q->hr, $q->p( $status ), $q->end_html;

   145 }

   146 

   147 __END__

   148 

   149 =pod

   150 

   151 =head1 NAME

   152 

   153 qf.cgi - quick filter web interface

   154 

   155 =head1 SYNOPSIS

   156 

   157 qf.cgi

   158 

   159 =head1 DESCRIPTION

   160 

   161 Currently this script allows to set/remove a redirection for exactly one

   162 address.

   163 

   164 =head1 AUTHOR

   165 

   166 Matthias Förste <foerste@schlittermann.de>

   167 

   168 =cut