--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/acl.pm Fri Feb 21 11:56:39 2014 +0100
@@ -0,0 +1,461 @@
+package acl;
+
+# © Heiko Schlittermann
+# $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, $nspat );
+END { $imap and $imap = undef; }
+
+sub _list();
+sub _mkpw($);
+
+sub list_by_user($@);
+sub list_by_folder($);
+sub list_groups(@);
+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();
+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 AT_FORWARDINGADDRESS => $Cf->ldap_at_forwardingaddress;
+ 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: " ) );
+ die $r->error, "\n" if $r->code;
+
+ $acl_password =
+ $Cf->acl_password
+ || $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};
+
+ $imap->set_tracing(1) if $ENV{TRACE};
+
+ # 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->add ) { _modify() }
+ elsif ( $Cf->delete ) { $Cf->acl('delete'); _modify() }
+ elsif ( $Cf->list ) { _list() }
+ elsif ( $Cf->modify ) { _modify() }
+ else { die "Need action (--add|--delete|--list|--modify)\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;
+
+ my @folders = @{ acl_folders($folder) } or die "Got empty folderlist - does '$folder' exist? (use --create if you want me to create it)";
+ for my $f ( @folders ) {
+
+ 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 ( $Cf->aclgroups ) {
+
+ warn "--folder option ignored when listing groups"
+ unless $Cf->folder ~~ [];
+ list_groups(@ARGV);
+
+ } elsif (@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 ( not $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 '*'.";
+
+ }
+
+}
+
+sub list_groups(@) {
+
+ @_ = ('*') unless @_;
+ my @ag = split ',', $Cf->imap_aclgroups;
+ my $ag_all = 1 if '*' ~~ @ag;
+ my $ag_att = AT_ACLGROUPS;
+ my $filter =
+ "(&($ag_att=*)" . "(|" . join( "", map { "(uid=$_)" } @_ ) . "))";
+ my $r = $ldap->search(
+ attrs => [ 'uid', AT_ACLGROUPS ],
+ filter => $filter,
+ base => $ubase,
+ );
+ die $r->error if $r->code;
+
+ unless ( $r->count ) {
+ print("No aclgroups found in ldap\n");
+ exit 0;
+ }
+
+ my $users;
+ while ( my $e = ( $r->shift_entry ) ) {
+ my $uid = $e->get_value('uid');
+ my @ag_cur = split ',', $e->get_value($ag_att);
+ for (@ag_cur) {
+ $users->{$_} =
+ defined $users->{$_}
+ ? [ @{ $users->{$_} }, $uid ]
+ : [$uid]
+ if $ag_all or $_ ~~ @ag;
+ }
+ }
+
+ print "$_:\n\t", join( "\n\t", @{ $users->{$_} } ), "\n\n"
+ for keys %{$users};
+
+}
+
+sub list_by_user($@) {
+
+ my $imap = shift;
+ my $filter = "(|" . join( "", map { "(uid=$_)" } @_ ) . ")";
+
+ #my $filter = "(uid=$uid)";
+ my $r = $ldap->search(
+ filter => $filter,
+ base => $ubase,
+ );
+ die $r->error if $r->code;
+ my @users;
+ unless ( $r->count ) {
+ verbose("No matching users found in ldap.\n");
+ @users = @_;
+ }
+
+ 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";
+ #}
+
+ die "IMAP Server does not advertise acl support"
+ unless $imap->capability->{acl};
+
+ # namespace() result looks like this
+ # [
+ # [ # list of private namespace(s)
+ # [
+ # prefix,
+ # name
+ # ],
+ # ...
+ # ],
+ # [ # list of namespace(s) for mailboxes shared by other users
+ # [
+ # prefix,
+ # name
+ # ],
+ # ...
+ # [ # list of namespace(s) for 'public' shared mailboxes
+ # [
+ # prefix,
+ # name
+ # ],
+ # ...
+ # ]
+ 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_rlist( '', $n->[0], $n->[1] );
+ for my $f ( @{$folders} ) {
+
+ #next if '\\Noselect' ~~ $f->[0];
+ my $perms = $imap->getacl($f) or die "Can't getacl '$f': $@";
+ my ( $u, $p );
+ while ( $u = shift @{$perms} and $p = shift @{$perms} ) {
+ next unless $u eq $uid;
+ $hasacl = 1;
+ print "\t$f: $u [$p]\n";
+ }
+
+ }
+
+ }
+
+ print "\tno acl found on listable folders in shared namespaces\n"
+ unless $hasacl;
+ print "\n";
+
+ }
+
+}
+
+sub list_by_folder($) {
+
+ my ($folder) = @_;
+
+ for my $f ( @{ acl_folders($folder) } ) {
+
+ my $hasacl;
+ print "$f\n";
+
+ my $perms = $imap->getacl($f) or die $@;
+ my ( $u, $p );
+ while ( $u = shift @{$perms} and $p = shift @{$perms} ) {
+
+ # '#user' will be listed when we have a global acl for 'user'
+ my $gl = $u =~ /^\$?#/ ? ' [global]' : '';
+ my $gr = $u =~ /^#?\$/ ? ' [group]' : '';
+ $hasacl = 1;
+ print "\t$u [$p]$gr$gl\n";
+ }
+
+ print "\tno acl found\n" unless $hasacl;
+ print "\n";
+
+ }
+
+}
+
+sub verbose(@) {
+ printf STDERR @_;
+}
+
+sub uniq(@) {
+ my %x;
+ @x{@_} = ();
+ return keys %x;
+}
+
+{
+ my @pw;
+
+ sub _mkpw($) {
+ my $in = $_[0];
+
+ 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 imap_list($$) {
+
+ my ( $ref, $folder ) = @_;
+
+ my $list = $imap->list( $ref, $folder )
+ or die "Can't list('$ref', '$folder'): $@";
+
+ # single folder sieht wie folgt aus: [[flag1, flag2, ...], separator, foldername]
+ ref $list and return [ map $_->[2], @{$list} ];
+
+ # assuming empty result list otherwise
+ return [];
+
+}
+
+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: