# HG changeset patch # User Matthias Förste foerste@schlittermann.de # Date 1323567091 -3600 # Node ID 722cdb1321c79cc257421d163ff0d60d1cd02d4a # Parent ef65e9adf0f6102a0b4ffb7d00bbec979410909d modify/delete should work now diff -r ef65e9adf0f6 -r 722cdb1321c7 acl.pm --- a/acl.pm Sat Dec 10 21:50:13 2011 +0100 +++ b/acl.pm Sun Dec 11 02:31:31 2011 +0100 @@ -6,6 +6,7 @@ use strict; use warnings; +require 5.10.0; use File::Path qw(remove_tree); use Net::LDAP; use Net::LDAP::Constant @@ -14,19 +15,24 @@ 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(); @@ -68,153 +74,96 @@ || $ENV{IMAP_PASS} || password::ask( "IMAP (" . $Cf->acl_admin . ") password: " ); + $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() { - 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"; + my @users; + @ARGV or die "Need user(s)\n"; + $Cf->folder ~~ [] and die "Need folders(s)\n"; $Cf->acl or die "Need acl\n"; - my @dns; + $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; - die "No entries found.\n" if $r->count == 0; + 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)) { - while ( my $e = $r->shift_entry ) { - my $r; + my ($user, $dn); - my $user = $e->get_value("uid"); - my $dn = $e->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:"; + 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)}) { - verbose "\n\t$dn..."; + 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 ( 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; + verbose "ok\n"; + print "\n"; - if ($modified) { - $r = $e->update($ldap); - die $r->error . $r->code if $r->code; - } - - verbose "ok\n"; - - print "\n"; } } @@ -225,26 +174,19 @@ 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}; - 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 { @@ -264,13 +206,24 @@ base => $ubase, ); die $r->error if $r->code; - verbose("No matching users found\n") unless $r->count; + my @users; + unless ($r->count) { + verbose("No matching users found in ldap.\n"); + @users = @_; + } - while (my $e = $r->shift_entry) { + while (my $e = ($r->shift_entry or shift @users)) { - my $uid = $e->get_value("uid"); - my $cn = join( ", ", $e->get_value("cn") ); - my $mr = $e->get_value(AT_PRIMARYADDRESS) || ""; # ?? + 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"; @@ -306,18 +259,16 @@ # uns interessieren nur 'public' namespaces for my $n (@{$ns->[2]}) { - my $folders = $imap->list( '', "$n->[0]*" ) or die $@; - ref $folders or die "Got empty folder list. Does '$n->[0]' actually exist? Is it readable?"; - + my $folders = imap_rlist( '', $n->[0], $n->[1] ); 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"; } } @@ -331,29 +282,24 @@ } -sub list_by_folder($$$) { - - my ($imap, $folder, $recursive) = @_; +sub list_by_folder($) { - $folder .= '/' unless $folder =~ m,/$,; - my $folders = $recursive - ? ($imap->list('', "$folder*") or die $@) - : [[ undef, undef, $folder ]]; + my ($folder) = @_; - ref $folders or die "Got empty folder list. Does '$folder' actually exist? Is it readable?"; - - for my $f ( @{$folders} ) { + for my $f ( @{acl_folders($folder)} ) { my $hasacl; - print "$f->[2]\n"; + print "$f\n"; + + my $perms = $imap->getacl( $f ) or die $@; + my ($u, $p); + while ($u = shift @{$perms} and $p = shift @{$perms}) { - # single folder sieht wie folgt aus: [[flag1, flag2, ...], separator, foldername] - #next if '\\Noselect' ~~ $f->[0]; - my $perms = $imap->getacl( $f->[2] ) or die $@; - my ($u, $p); - while ($u = 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"; } @@ -392,6 +338,52 @@ } } +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: