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