account.pm
branchfoerste-cms
changeset 72 66bf85163780
parent 36 59c7146ec6f0
--- a/account.pm	Tue Jul 31 10:46:37 2007 +0000
+++ b/account.pm	Fri Feb 21 11:56:39 2014 +0100
@@ -1,23 +1,24 @@
 package account;
+
 # © Heiko Schlittermann
 # $Id$
 # $URL$
 
 use strict;
 use warnings;
+use File::Path qw(remove_tree);
 use Net::LDAP;
-use Net::LDAP::Constant qw(LDAP_ALREADY_EXISTS LDAP_NO_SUCH_OBJECT LDAP_TYPE_OR_VALUE_EXISTS);
+use Net::LDAP::Constant
+  qw(LDAP_ALREADY_EXISTS LDAP_NO_SUCH_OBJECT LDAP_TYPE_OR_VALUE_EXISTS);
 use Net::LDAP::Entry;
-use Cyrus::IMAP::Admin;
+use Mail::IMAPTalk;
 use Text::Wrap;
 use password;
 
-
 my $Cf;
-my ($ldap, $ubase, $abase);
-my ($imap);
-END { $imap and $imap = undef; };
-
+my ( $ldap, $ubase, $abase );
+my ( $imap, $imap_password );
+END { $imap and $imap = undef; }
 
 sub _add();
 sub _list();
@@ -25,6 +26,7 @@
 sub _mkpw($);
 sub uniq(@);
 sub verbose(@);
+sub _mbox($);
 
 sub OU_ACCOUNTS();
 sub OU_ALIASES();
@@ -33,73 +35,82 @@
 sub AT_ADDRESS();
 sub AT_GROUP();
 sub AT_FORWARDINGADDRESS();
+sub AT_QUOTA();
+sub AT_ACLGROUPS();
 
 sub import(@) {
     $Cf = shift;
 
     require constant;
-    import constant OU_ACCOUNTS => $Cf->ldap_ou_accounts;
-    import constant OU_ALIASES => $Cf->ldap_ou_aliases;
-    import constant OC_RECIPIENT => $Cf->ldap_oc_recipient;
-    import constant AT_PRIMARYADDRESS => $Cf->ldap_at_primaryaddress;
-    import constant AT_ADDRESS => $Cf->ldap_at_address;
-    import constant AT_GROUP => $Cf->ldap_at_group;
+    import constant OU_ACCOUNTS          => $Cf->ldap_ou_accounts;
+    import constant OU_ALIASES           => $Cf->ldap_ou_aliases;
+    import constant OC_RECIPIENT         => $Cf->ldap_oc_recipient;
+    import constant AT_PRIMARYADDRESS    => $Cf->ldap_at_primaryaddress;
+    import constant AT_ADDRESS           => $Cf->ldap_at_address;
+    import constant AT_GROUP             => $Cf->ldap_at_group;
     import constant AT_FORWARDINGADDRESS => $Cf->ldap_at_forwardingaddress;
+    import constant AT_QUOTA             => $Cf->ldap_at_quota;
+    import constant AT_ACLGROUPS         => $Cf->ldap_at_aclgroups;
 
     $ubase = OU_ACCOUNTS . "," . $Cf->ldap_base;
     $abase = OU_ALIASES . "," . $Cf->ldap_base;
 }
 
 sub run($) {
+
     # Eigentlich brauchen wir für alles imap und ldap
     $ldap = new Net::LDAP $Cf->ldap_server or die;
-    my $r = $ldap->bind($Cf->ldap_bind_dn,
-	password => $Cf->ldap_password || $ENV{LDAP_PASS} || password::ask("LDAP (". $Cf->ldap_bind_dn .") password: "));
+    my $r = $ldap->bind( $Cf->ldap_bind_dn,
+             password => $Cf->ldap_password
+          || $ENV{LDAP_PASS}
+          || password::ask( "LDAP (" . $Cf->ldap_bind_dn . ") password: " ) );
     die $r->error, "\n" if $r->code;
 
-    $imap = new Cyrus::IMAP::Admin or die $@;
-    $imap->authenticate(-server => $Cf->imap_server, -user => $Cf->imap_admin, 
-	-password => $Cf->imap_password || $ENV{IMAP_PASS} || password::ask("IMAP (". $Cf->imap_admin .") password: "))
-    or die $@;
-
+    $imap =
+      Mail::IMAPTalk->new( Server => $Cf->imap_server, Port => $Cf->imap_port )
+      or die "Can't connect to IMAP Server '", $Cf->imap_server, "', Port '",
+      $Cf->imap_port, "': ", $@;
+    $imap_password =
+         $Cf->imap_password
+      || $ENV{IMAP_PASS}
+      || password::ask( "IMAP (" . $Cf->imap_admin . ") password: " );
 
-    if ($Cf->list) { _list() }
-    elsif ($Cf->add) { _add() }
-    elsif ($Cf->delete) { _delete() }
-    elsif ($Cf->modify) { _modify() }
-    else { die "Need action (--add|--modify|--list|--delete)\n" };
+    if    ( $Cf->list )   { _list() }
+    elsif ( $Cf->add )    { _add() }
+    elsif ( $Cf->delete ) { _delete() }
+    elsif ( $Cf->modify ) { _modify() }
+    else { die "Need action (--add|--modify|--list|--delete)\n" }
 
 }
 
 sub _add() {
-# Beim Hinzufügen tragen wir nur das unbedingt notwendige
-# ein.  Wenn es schon eine mailPrimaryAddress gibt oder eine
-# mail, machen wir gar nichts.
-# Ansonsten:
-# uid wird hinzugefügt
-# cn, sn bleiben unangetastet
-# Wenn die mailbox-Option gesetzt ist, wird die
-# IMAP-Mailbox angelegt.
 
+    # Beim Hinzufügen tragen wir nur das unbedingt notwendige
+    # ein.  Wenn es schon eine mailPrimaryAddress gibt oder eine
+    # mail, machen wir gar nichts.
+    # Ansonsten:
+    # uid wird hinzugefügt
+    # cn, sn bleiben unangetastet
+    # Wenn die mailbox-Option gesetzt ist, wird die
+    # IMAP-Mailbox angelegt.
 
     die "Need user name for creation\n" if not @ARGV;
     my $user = shift @ARGV;
-    my $mailPrimaryAddress = $Cf->primary || $user;	    # evtl. mit !
-    my $mailAddress = [$user, split /,/, $Cf->other || ""]; # ditto
+    my $mailPrimaryAddress = $Cf->primary || $user;    # evtl. mit !
+    my $mailAddress = [ $user, split /,/, $Cf->other || "" ];    # ditto
 
-    $user =~ s/!$//;					    # jetzt können wir ! nicht mehr brauchn
-    my $mbox = "user/$user";
+    $user =~ s/!$//;    # jetzt können wir ! nicht mehr brauchn
     my $cn = $Cf->fullname || $user;
-    my $sn = (reverse split " ", $cn)[0];
-    my $mailGroup = [split /,/, $Cf->group || ""];
-    my $mailForwardingAddress = [split /,/, $Cf->forward || ""];
-    my $pw = _mkpw($Cf->password || "{pwgen}");
+    my $sn = ( reverse split " ", $cn )[0];
+    my $mailGroup             = [ split /,/, $Cf->group   || "" ];
+    my $mailForwardingAddress = [ split /,/, $Cf->forward || "" ];
+    my $pw = _mkpw( $Cf->password || "{pwgen}" );
+    my $mbox = _mbox($user);
 
-    if ($mailPrimaryAddress !~ /@/) {
-	$mailPrimaryAddress .= "@" . $Cf->default_domain;
+    if ( $mailPrimaryAddress !~ /@/ ) {
+        $mailPrimaryAddress .= "@" . $Cf->default_domain;
     }
 
-
     my $dn = "uid=$user,$ubase";
     my $r;
 
@@ -365,55 +376,99 @@
 sub _list() {
     my $filter;
     @ARGV = ("*") unless @ARGV;
-    $filter = "(|" . join("", map { "(uid=$_)" } @ARGV) . ")";
+    $filter = "(|" . join( "", map { "(uid=$_)" } @ARGV ) . ")";
 
     my $r = $ldap->search(
-	filter => $filter,
-	base => $ubase,
-	#attrs => [qw/uid cn mail userPassword/, (AT_PRIMARYADDRESS)]
+        filter => $filter,
+        base   => $ubase,
+
+        #attrs => [qw/uid cn mail userPassword/, (AT_PRIMARYADDRESS)]
     );
     die $r->error if $r->code;
 
     #if (-t STDOUT) { open(LESS, "|less -F -X") and select LESS; }
 
+    while ( my $e = $r->shift_entry ) {
+        my $uid  = $e->get_value("uid");
+        my $cn   = join( ", ", $e->get_value("cn") );
+        my $mr   = $e->get_value(AT_PRIMARYADDRESS) || "";                  # ??
+        my $ml   = join( ", ", $e->get_value(AT_ADDRESS) ) || "";           # ??
+        my $mg   = join( ", ", $e->get_value(AT_GROUP) ) || "";             # ??
+        my $forw = join( ", ", $e->get_value(AT_FORWARDINGADDRESS) ) || "";
+        my $ag   = $e->get_value(AT_ACLGROUPS);
+        $ag      = '$' . join ',$', split /,/, $ag if $ag;
 
-    while (my $e = $r->shift_entry) {
-	my $uid = $e->get_value("uid");
-	my $cn = join(", ", $e->get_value("cn"));
-	my $mr = $e->get_value(AT_PRIMARYADDRESS) || "";	# ??
-	my $ml = join(", ", $e->get_value(AT_ADDRESS)) || "";	# ??
-	my $mg = join(", ", $e->get_value(AT_GROUP)) || "";	# ??
-	my $forw = join (", ", $e->get_value(AT_FORWARDINGADDRESS)) || "";
-	my $mbox = "user/$uid";
+        print "$uid: $cn <$mr>";
+
+        #if (($e->get_value("iusRestrictedMail")||"") eq "TRUE") {
+        #print " INTERNAL";
+        #}
 
-	print "$uid: $cn <$mr>";
+        # das imap protokoll sieht keine zustandsänderung von 'authenticated'
+        # zu 'not authenticated' vor - daher müssen wir für jeden nutzer eine
+        # eigene verbindung aufbauen
+        $imap = Mail::IMAPTalk->new(
+            Server => $Cf->imap_server,
+            Port   => $Cf->imap_port
+          )
+          or die "Can't connect to IMAP Server '", $Cf->imap_server,
+          "', Port '", $Cf->imap_port, "': ", $@;
+        $imap->login( "$uid*" . $Cf->imap_admin, $imap_password ) or die $@;
 
-	#if (($e->get_value("iusRestrictedMail")||"") eq "TRUE") {
-	    #print " INTERNAL";
-	#}
+        my %q;
+        if ( $imap->capability->{quota} ) {
+
+            # prepare patterns for shared folders - we want to ignore them in
+            # quota calculations (TODO: what happens if a user has/attempts to
+            # create a folder with the name of a namespace? he could avoid
+            # quota limits that way?)
+            my $ns = $imap->namespace() or die $@;
+            my @p = map qr{^\Q$_->[0]\E}, ( @{ $ns->[1] }, @{ $ns->[2] } );
+
+            my $folders = $imap->list( '', '*' ) or die $@;
+
+            for my $f ( @{$folders} ) {
 
-	MBOX: {
-	    if (!$imap->list($mbox)) {
-		print ", no mbox";
-		last MBOX;
-	    }
-	    print ", mbox";
-	    my %q = $imap->listquota($mbox);
-	    my ($used, $max) = map { int($_ / 1024) } @{$q{STORAGE}};
+                # single folder sieht wie folgt aus: [[flag1, flag2, ...], separator, foldername]
+                #next if '\\Noselect' ~~ $f->[0];
+                # ignore shared folders
+                map { next if ( $f->[2] . $f->[1] ) =~ $_ } @p;
+                my $q = $imap->getquotaroot( $f->[2] )
+                  or $@ eq
+                  q{IMAP Command : 'getquotaroot' failed. Response was : no - Not showing other users' quota.}
+                  or die $@;
+                delete $q->{quotaroot};
+                %q = ( %q, %{$q} );
+
+            }
+
+        }
+
+        $imap->logout or die $@;
 
-	    if (!$max) {
-		print ", no quota";
-		last MBOX;
-	    }
-	    print ", quota ($used/$max): " . int(100 * $used/$max) . "%";
-	}
-	print "\n";
+        # da wir uns anmelden konnten haben wir auch eine 'mbox'
+        print ", mbox";
+        my $has_quota;
+        for my $qr ( keys %q ) {
+            my @q    = @{ $q{$qr} };
+            my $elem = '';
+            $elem = shift @q while defined $elem and $elem ne 'STORAGE';
+            my ( $used, $max ) = map { int( $_ / 1024 ) } @q[ 0 .. 1 ];
+            $max ||= 1;
+            print ", quota '$qr': $used/${max}MB "
+              . int( 100 * $used / $max ) . "%";
+            $has_quota = 1;
+        }
+        print ", no quota" unless $has_quota;
+        print "\n";
 
-	print "\tPassword: ", $> == 0 ? $e->get_value("userPassword") : "*", "\n";
-	
-	print  wrap("\t", "\t\t", "Other Adresses: $ml\n") if $ml;
-	print wrap("\t", "\t\t", "Mail Groups: $mg\n") if $mg;
-	print wrap("\t", "\t\t", "Forwardings: $forw\n") if $forw;
+        print "\tPassword: ", $> == 0 ? $e->get_value("userPassword") : "*",
+          "\n";
+
+        print wrap( "\t", "\t\t", "Other Adresses: $ml\n" ) if $ml;
+        print wrap( "\t", "\t\t", "Mail Groups: $mg\n" )    if $mg;
+        print wrap( "\t", "\t\t", "Forwardings: $forw\n" )  if $forw;
+        print wrap( "\t", "\t\t", "ACL Groups: $ag\n" )     if $ag;
 
     }
 }
@@ -428,19 +483,44 @@
     return keys %x;
 }
 
-{   my @pw;
-sub _mkpw($) {
-    my $in = $_[0];
+{
+    my @pw;
+
+    sub _mkpw($) {
+        my $in = $_[0];
+
+        return $in unless $in and $in eq "{pwgen}";
 
-    return $in unless $in and $in eq "{pwgen}";
+        if ( !@pw ) {
+            chomp( @pw = `pwgen 8 10 2>/dev/null` );
+            die "pwgen: $!" if $?;
+        }
+        return shift @pw;
+
+    }
+}
+
+sub _mbox($) {
 
-    if (!@pw) {
-	chomp(@pw = `pwgen 8 10 2>/dev/null|| mkpasswd`);
-	die "pwgen/mkpasswd: $!" if $?;
-    }
-    return shift @pw;
-    
-} }
+    my ($user) = @_;
+
+    my ( $localpart, $domain, $escapes );
+
+    # assuming usernames of the form localpart@domain
+    $user =~ /(.+)@(.+)$/;
+    ( $localpart, $domain ) = ( $1, $2 );
+
+    die "Invalid username '$user'"
+      unless $escapes->{'%u'} = $localpart
+          and $escapes->{'%1'} = substr $localpart, 0, 1
+          and $escapes->{'%d'} = $domain;
+    my $mbox = $Cf->imap_mail_location;
+    $mbox =~ s/$_/$escapes->{$_}/ for keys %{$escapes};
+
+    return $mbox;
+
+}
 
 1;
+
 # vim:sts=4 sw=4 aw ai sm nohlsearch: