--- 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: