diff -r 59c7146ec6f0 -r 66bf85163780 account.pm --- 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: