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