ius/mailAdmin: comparison acl.pm

equal deleted inserted replaced

-:ef65e9adf0f6
+:722cdb1321c7
 # $Id$
 # $URL$
 use strict;
 use warnings;
+require 5.10.0;
 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::Entry;
 use Mail::IMAPTalk;
 use Text::Wrap;
 use password;
+use Term::ReadKey;
 my $Cf;
 my ( $ldap, $ubase, $abase );
-my ( $imap, $acl_password );
+my ( $imap, $acl_password, $nspat );
 END { $imap and $imap = undef; }
 sub _list();
 sub _mkpw($);
 sub list_by_user($@);
-sub list_by_folder($$$);
+sub list_by_folder($);
 sub uniq(@);
 sub verbose(@);
+sub prompt($$);
+sub imap_list($$);
+sub imap_rlist($$$);
+sub acl_folders($);
 sub OU_ACCOUNTS();
 sub OU_ALIASES();
 sub AT_PRIMARYADDRESS();
 sub OC_RECIPIENT();
 $acl_password =
 $Cf->acl_password
 || $ENV{IMAP_PASS}
 || password::ask( "IMAP (" . $Cf->acl_admin . ") password: " );
-if    ( $Cf->list )   { _list() }
-elsif ( $Cf->modify ) { _modify() }
-else { die "Need action (--modify|--list)\n" }
-}
-sub _modify() {
-die 'Not yet implemented';
-# Auch hier gehen wir davon aus, daß die dn direkt aus dem User-Namen folgt:
-# dn: uid=USER,...
-my (@user) = @ARGV or die "Need user(s)\n";
-$Cf->user or die "Need user(s)\n";
-$Cf->acl or die "Need acl\n";
-my @dns;
-my $r = $ldap->search(
-base   => $ubase,
-filter => "(|" . join( "", map { "(uid=$_)" } @ARGV ) . ")"
-);
-die $r->error if $r->code;
-die "No entries found.\n" if $r->count == 0;
-while ( my $e = $r->shift_entry ) {
-my $r;
-my $user = $e->get_value("uid");
-my $dn   = $e->dn;
-my $modified = 0;
-verbose "$user:";
-verbose "\n\t$dn...";
-# Fix: iusMailOptions wurde erst später eingeführt, bei Bedarf also hinzufügen
-#if (!grep /^iusMailOptions$/, @{$e->get("objectClass")}) {
-#$e->add(objectClass => "iusMailOptions");
-#}
-if ( my $cn = $Cf->fullname ) {
-# Aus dem Fullnamen leiten wir cn und sn ab.
-my $sn = ( reverse split " ", $cn )[0];
-if ( $cn =~ s/^\+// ) {
-$e->replace(
-cn => [ uniq $e->get("cn"), $cn ],
-sn => [ uniq $e->get("sn"), $sn ]
-);
-} elsif ( $cn =~ s/^-// ) {
-$e->delete( cn => [$cn], sn => [$sn] );
-} else {
-$e->replace( cn => $cn, sn => $sn );
-}
-$modified++;
-}
-if ( defined $Cf->other ) {
-my @o = split /,/, $Cf->other;
-grep { /^[+-]/ } @o or $e->delete(AT_ADDRESS);
-foreach my $a ( split /,/, $Cf->other ) {
-if ( $a =~ s/^-// ) {
-$e->delete( (AT_ADDRESS) => [$a] );
-} else {
-$a =~ s/^\+//;
-# Darf noch nicht woanders sein
-$r = $ldap->search( base => $ubase, filter => "(mail=$a)" );
-die $r->error if $r->code;
-die "$a ist schon vergeben\n" if $r->count;
-$e->add( (AT_ADDRESS) => [$a] );
-}
-}
-$modified++;
-}
-if ( defined $Cf->group ) {
-my @g = split /,/, $Cf->group;
-grep { /^[+-]/ } @g
-or $e->delete(AT_GROUP)
-if $e->get_value(AT_GROUP);
-foreach my $g (@g) {
-if ( $g =~ s/^-// ) {
-$e->delete( (AT_GROUP) => [$g] );
-} else {
-$g =~ s/^\+//;
-$e->add( (AT_GROUP) => [$g] );
-}
-}
-$modified++;
-}
-if ( defined $Cf->forward ) {
-my @f = split /,/, $Cf->forward;
-grep { /^[+-]/ } @f
-or $e->delete(AT_FORWARDINGADDRESS)
-if $e->get_value(AT_FORWARDINGADDRESS);
-foreach my $f (@f) {
-if ( $f =~ s/^-// ) {
-$e->delete( (AT_FORWARDINGADDRESS) => [$f] );
-} else {
-$f =~ s/^\+//;
-$e->add( (AT_FORWARDINGADDRESS) => [$f] );
-}
-}
-$modified++;
-}
-if ( my $a = $Cf->primary ) {
-$r = $ldap->search(
-base => $ubase,
-# filter => "(|(mailPrimaryAddress=$a)(mail=$a))");
-filter => "(mail=$a)"
-);
-die $r->error if $r->code;
-die "$a ist schon vergeben\n" if $r->count;
-$e->replace( (AT_PRIMARYADDRESS) => $Cf->primary );
-$modified++;
-}
-if ( my $pw = _mkpw( $Cf->password ) ) {
-$e->replace( userPassword => $pw );
-$modified++;
-}
-#if ($Cf->internal ne ":") {
-#$e->replace(iusRestrictedMail => $Cf->internal ? "TRUE" : "FALSE");
-#$modified++;
-#}
-$e->dump if $Cf->debug;
-if ($modified) {
-$r = $e->update($ldap);
-die $r->error . $r->code if $r->code;
-}
-verbose "ok\n";
-print "\n";
-}
-}
-sub _list() {
-#@ARGV = ("*") unless @ARGV;
-die "option acl_admin required\n" unless $Cf->acl_admin;
 $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( $Cf->acl_admin, $acl_password ) or die $@;
 die "IMAP Server does not advertise acl support" unless $imap->capability->{acl};
+# requires an imap connection
+my $ns = $imap->namespace() or die "No public namespaces available: $@";
+$nspat = [];
+for (@{$ns->[2]}) {
+(my $n = $_->[0]) =~ s/$_->[1]$//;
+push @{$nspat}, [qr/\Q$n\E($_->[1]|$)/, $_->[1]];
+}
+if    ( $Cf->list )   { _list() }
+elsif ( $Cf->modify ) { _modify() }
+elsif ( $Cf->delete ) { $Cf->acl('delete') ; _modify() }
+else { die "Need action (--modify|--list)\n" }
+}
+sub _modify() {
+# Auch hier gehen wir davon aus, daß die dn direkt aus dem User-Namen folgt:
+# dn: uid=USER,...
+my @users;
+@ARGV or die "Need user(s)\n";
+$Cf->folder ~~ [] and die "Need folders(s)\n";
+$Cf->acl or die "Need acl\n";
+$Cf->recursive and $Cf->create and die "Use either --recursive or --create but not both\n";
+my $r = $ldap->search(
+base   => $ubase,
+filter => "(|" . join( "", map { "(uid=$_)" } @ARGV ) . ")"
+);
+die $r->error if $r->code;
+unless ($r->count) {
+prompt('No matching user found in ldap. Continue? (y/N)', "n\n") =~ /y/i or exit 0;
+@users = @ARGV;
+}
+while (my $e = ($r->shift_entry or shift @users)) {
+my ($user, $dn);
+if (ref $e eq 'Net::LDAP::Entry') {
+$user = $e->get_value("uid");
+$dn   = $e->dn;
+} else {
+$user = $e;
+$dn   = '[dn not available]';
+}
+my $modified = 0;
+verbose "$user:\n";
+verbose "\t$dn...\n";
+for my $folder (@{$Cf->folder}) {
+$imap->create($folder) or die "Can't create folder '$folder': $@" if $Cf->create;
+for my $f (@{acl_folders($folder)}) {
+if ($Cf->acl eq 'delete') {
+$imap->deleteacl($f, $user) or die "Can't delete acl: $@";
+verbose "\t$f: none\n";
+} else {
+$imap->setacl($f, $user, $Cf->acl) or die "Can't set acl: $@";
+verbose "\t$f: " . $Cf->acl . "\n";
+}
+}
+}
+# Fix: iusMailOptions wurde erst später eingeführt, bei Bedarf also hinzufügen
+#if (!grep /^iusMailOptions$/, @{$e->get("objectClass")}) {
+#$e->add(objectClass => "iusMailOptions");
+#}
+#if ($Cf->internal ne ":") {
+#$e->replace(iusRestrictedMail => $Cf->internal ? "TRUE" : "FALSE");
+#$modified++;
+#}
+verbose "ok\n";
+print "\n";
+}
+}
+sub _list() {
+#@ARGV = ("*") unless @ARGV;
+die "option acl_admin required\n" unless $Cf->acl_admin;
 if (@ARGV) {
 #        my $uid = $ARGV[0];
 #        # searching by more than use user may be too expensive
 #        die "Searching by more than one user not supported" unless @ARGV == 1 or $uid =~ /\*/;
 #list_by_user($_) for @ARGV;
+warn "--folder option ignored when listing by user" unless $Cf->folder ~~ [];
 list_by_user($imap, @ARGV);
-} elsif ($Cf->folder) {
+} elsif (not $Cf->folder ~~ []) {
-list_by_folder($imap, $_, $Cf->recursive) for @{$Cf->folder};
+list_by_folder($_) for @{$Cf->folder};
 } else {
 die "Need either user or --folder. If you really want to search all users then supply the pattern '*'.";
 my $r = $ldap->search(
 filter => $filter,
 base   => $ubase,
 );
 die $r->error if $r->code;
-verbose("No matching users found\n") unless $r->count;
+my @users;
+unless ($r->count) {
-while (my $e = $r->shift_entry) {
+verbose("No matching users found in ldap.\n");
+@users = @_;
-my $uid  = $e->get_value("uid");
+}
-my $cn   = join( ", ", $e->get_value("cn") );
-my $mr   = $e->get_value(AT_PRIMARYADDRESS) || "";                  # ??
+while (my $e = ($r->shift_entry or shift @users)) {
+my ($uid, $cn, $mr);
+if (ref $e eq 'Net::LDAP::Entry') {
+$uid  = $e->get_value("uid");
+$cn   = join( ", ", $e->get_value("cn") );
+$mr   = $e->get_value(AT_PRIMARYADDRESS) || "";                  # ??
+} else {
+$uid = $e;
+$cn  = '[cn not available]';
+$mr  = '[address not available]';
+}
 print "$uid: $cn <$mr>\n";
 #if (($e->get_value("iusRestrictedMail")||"") eq "TRUE") {
 #print " INTERNAL";
 my $hasacl;
 my $ns = $imap->namespace() or die "No public namespaces available: $@";
 # uns interessieren nur 'public' namespaces
 for my $n (@{$ns->[2]}) {
-my $folders = $imap->list( '', "$n->[0]*" ) or die $@;
+my $folders = imap_rlist( '', $n->[0], $n->[1] );
-ref $folders or die "Got empty folder list. Does '$n->[0]' actually exist? Is it readable?";
 for my $f ( @{$folders} ) {
-# single folder sieht wie folgt aus: [[flag1, flag2, ...], separator, foldername]
 #next if '\\Noselect' ~~ $f->[0];
-my $perms = $imap->getacl( $f->[2] ) or die $@;
+my $perms = $imap->getacl( $f ) or die $@;
 my ($u, $p);
-while ($u = shift @{$perms} and $p = shift @{$perms} and $u eq $uid) {
+while ($u = shift @{$perms} and $p = shift @{$perms}) {
+next unless $u eq $uid;
 $hasacl = 1;
-print "\t$f->[2]: $u [$p]\n";
+print "\t$f: $u [$p]\n";
 }
 }
 }
 }
 }
-sub list_by_folder($$$) {
+sub list_by_folder($) {
-my ($imap, $folder, $recursive) = @_;
+my ($folder) = @_;
-$folder .= '/' unless $folder =~ m,/$,;
+for my $f ( @{acl_folders($folder)} ) {
-my $folders = $recursive
-? ($imap->list('', "$folder*") or die $@)
-: [[ undef, undef, $folder ]];
-ref $folders or die "Got empty folder list. Does '$folder' actually exist? Is it readable?";
-for my $f ( @{$folders} ) {
 my $hasacl;
-print "$f->[2]\n";
+print "$f\n";
-# single folder sieht wie folgt aus: [[flag1, flag2, ...], separator, foldername]
+my $perms = $imap->getacl( $f ) or die $@;
-#next if '\\Noselect' ~~ $f->[0];
-my $perms = $imap->getacl( $f->[2] ) or die $@;
 my ($u, $p);
-while ($u = shift @{$perms}
+while ($u = shift @{$perms} and $p = shift @{$perms}) {
-and $p = shift @{$perms}) {
-next if $u eq $Cf->acl_admin or $u eq $Cf->imap_admin;
+#        use Data::Dumper;
+#        warn Dumper([ $Cf->acl_admin, $Cf->imap_admin, '#' . $Cf->acl_admin, '#' . $Cf->imap_admin ]);
+# '#user' will be listed when we have a global acl for 'user'
+next if $u ~~ [ $Cf->acl_admin, $Cf->imap_admin, '#' . $Cf->acl_admin, '#' . $Cf->imap_admin ];
 $hasacl = 1;
 print "\t$u [$p]\n";
 }
 print "\tno acl found\n" unless $hasacl;
 return shift @pw;
 }
 }
+sub imap_list($$) {
+my ($ref, $folder) = @_;
+my $list = $imap->list($ref, $folder) or die "Can't list('$ref', '$folder'): $@";
+ref $list or die "Got empty folder list. Does '$folder' actually exist? Is it readable?";
+# single folder sieht wie folgt aus: [[flag1, flag2, ...], separator, foldername]
+return [ map $_->[2], @{$list} ];
+}
+sub imap_rlist($$$) {
+my ($ref, $folder, $sep) = @_;
+$folder =~ s/$sep+$//;
+my $list = imap_list($ref, $folder);
+push @{$list}, @{imap_list($ref, "$folder$sep*")} if $Cf->recursive;
+return $list;
+}
+sub acl_folders($) {
+my ($f) = @_;
+my $folders;
+for my $np (@{$nspat}) {
+# don't modify $f!
+(my $ft = $f) =~ s/$np->[1]$//;
+return imap_rlist('', $f, $np->[1]) if ($ft =~ /$np->[0]/);
+}
+die "Foldername '$f' must begin with the name of a shared namespace\n";
+}
+sub prompt($$) {
+my ($prompt, $default) = @_;
+print $prompt, substr($default, 0, 1), "\b";
+ReadMode 4; my $r = ReadKey(0); ReadMode 0;
+if ($r eq "\n") { $r = $default }
+else { $r .= substr($default, 1) }
+print $r;
+return $r;
+}
 1;
 # vim:sts=4 sw=4 aw ai sm nohlsearch:

branch	foerste
changeset 56	722cdb1321c7
parent 54	1f74755c407e
child 58	dd04534fe595