1 package acl;

     2 

     3 # © Heiko Schlittermann

     4 # $Id$

     5 # $URL$

     6 

     7 use strict;

     8 use warnings;

     9 require 5.10.0;

    10 use File::Path qw(remove_tree);

    11 use Net::LDAP;

    12 use Net::LDAP::Constant

    13   qw(LDAP_ALREADY_EXISTS LDAP_NO_SUCH_OBJECT LDAP_TYPE_OR_VALUE_EXISTS);

    14 use Net::LDAP::Entry;

    15 use Mail::IMAPTalk;

    16 use Text::Wrap;

    17 use password;

    18 use Term::ReadKey;

    19 

    20 my $Cf;

    21 my ( $ldap, $ubase,        $abase );

    22 my ( $imap, $acl_password, $nspat );

    23 END { $imap and $imap = undef; }

    24 

    25 sub _list();

    26 sub _mkpw($);

    27 

    28 sub list_by_user($@);

    29 sub list_by_folder($);

    30 sub list_groups(@);

    31 sub uniq(@);

    32 sub verbose(@);

    33 sub prompt($$);

    34 sub imap_list($$);

    35 sub imap_rlist($$$);

    36 sub acl_folders($);

    37 

    38 sub OU_ACCOUNTS();

    39 sub OU_ALIASES();

    40 sub AT_PRIMARYADDRESS();

    41 sub OC_RECIPIENT();

    42 sub AT_ADDRESS();

    43 sub AT_GROUP();

    44 sub AT_FORWARDINGADDRESS();

    45 sub AT_QUOTA();

    46 sub AT_ACLGROUPS();

    47 

    48 sub import(@) {

    49     $Cf = shift;

    50 

    51     require constant;

    52     import constant OU_ACCOUNTS          => $Cf->ldap_ou_accounts;

    53     import constant OU_ALIASES           => $Cf->ldap_ou_aliases;

    54     import constant OC_RECIPIENT         => $Cf->ldap_oc_recipient;

    55     import constant AT_PRIMARYADDRESS    => $Cf->ldap_at_primaryaddress;

    56     import constant AT_ADDRESS           => $Cf->ldap_at_address;

    57     import constant AT_GROUP             => $Cf->ldap_at_group;

    58     import constant AT_FORWARDINGADDRESS => $Cf->ldap_at_forwardingaddress;

    59     import constant AT_ACLGROUPS         => $Cf->ldap_at_aclgroups;

    60 

    61     $ubase = OU_ACCOUNTS . "," . $Cf->ldap_base;

    62     $abase = OU_ALIASES . "," . $Cf->ldap_base;

    63 }

    64 

    65 sub run($) {

    66 

    67     # Eigentlich brauchen wir für alles imap und ldap

    68     $ldap = new Net::LDAP $Cf->ldap_server or die;

    69     my $r = $ldap->bind( $Cf->ldap_bind_dn,

    70              password => $Cf->ldap_password

    71           || $ENV{LDAP_PASS}

    72           || password::ask( "LDAP (" . $Cf->ldap_bind_dn . ") password: " ) );

    73     die $r->error, "\n" if $r->code;

    74 

    75     $acl_password =

    76          $Cf->acl_password

    77       || $ENV{IMAP_PASS}

    78       || password::ask( "IMAP (" . $Cf->acl_admin . ") password: " );

    79 

    80     $imap = Mail::IMAPTalk->new(

    81         Server => $Cf->imap_server,

    82         Port   => $Cf->imap_port

    83       )

    84       or die "Can't connect to IMAP Server '", $Cf->imap_server,

    85       "', Port '", $Cf->imap_port, "': ", $@;

    86     $imap->login( $Cf->acl_admin, $acl_password ) or die $@;

    87     die "IMAP Server does not advertise acl support"

    88       unless $imap->capability->{acl};

    89 

    90     $imap->set_tracing(1) if $ENV{TRACE};

    91 

    92     # requires an imap connection

    93     my $ns = $imap->namespace() or die "No public namespaces available: $@";

    94     $nspat = [];

    95     for ( @{ $ns->[2] } ) {

    96         ( my $n = $_->[0] ) =~ s/$_->[1]$//;

    97         push @{$nspat}, [ qr/\Q$n\E($_->[1]|$)/, $_->[1] ];

    98     }

    99 

   100     if    ( $Cf->add )    { _modify() }

   101     elsif ( $Cf->delete ) { $Cf->acl('delete'); _modify() }

   102     elsif ( $Cf->list )   { _list() }

   103     elsif ( $Cf->modify ) { _modify() }

   104     else { die "Need action (--add|--delete|--list|--modify)\n" }

   105 

   106 }

   107 

   108 sub _modify() {

   109 

   110     # Auch hier gehen wir davon aus, daß die dn direkt aus dem User-Namen folgt:

   111     # dn: uid=USER,...

   112     my @users;

   113     @ARGV or die "Need user(s)\n";

   114     $Cf->folder ~~ [] and die "Need folders(s)\n";

   115     $Cf->acl or die "Need acl\n";

   116     $Cf->recursive

   117       and $Cf->create

   118       and die "Use either --recursive or --create but not both\n";

   119 

   120     my $r = $ldap->search(

   121         base   => $ubase,

   122         filter => "(|" . join( "", map { "(uid=$_)" } @ARGV ) . ")"

   123     );

   124     die $r->error if $r->code;

   125     unless ( $r->count ) {

   126         prompt( 'No matching user found in ldap. Continue? (y/N)', "n\n" ) =~

   127           /y/i

   128           or exit 0;

   129         @users = @ARGV;

   130     }

   131 

   132     while ( my $e = ( $r->shift_entry or shift @users ) ) {

   133 

   134         my ( $user, $dn );

   135 

   136         if ( ref $e eq 'Net::LDAP::Entry' ) {

   137             $user = $e->get_value("uid");

   138             $dn   = $e->dn;

   139         } else {

   140             $user = $e;

   141             $dn   = '[dn not available]';

   142         }

   143 

   144         my $modified = 0;

   145         verbose "$user:\n";

   146         verbose "\t$dn...\n";

   147 

   148         for my $folder ( @{ $Cf->folder } ) {

   149 

   150             $imap->create($folder)

   151               or die "Can't create folder '$folder': $@"

   152               if $Cf->create;

   153 

   154             my @folders = @{ acl_folders($folder) } or die "Got empty folderlist - does '$folder' exist? (use --create if you want me to create it)";

   155             for my $f ( @folders ) {

   156 

   157                 if ( $Cf->acl eq 'delete' ) {

   158                     $imap->deleteacl( $f, $user ) or die "Can't delete acl: $@";

   159                     verbose "\t$f: none\n";

   160                 } else {

   161                     $imap->setacl( $f, $user, $Cf->acl )

   162                       or die "Can't set acl: $@";

   163                     verbose "\t$f: " . $Cf->acl . "\n";

   164                 }

   165 

   166             }

   167 

   168         }

   169 

   170         # Fix: iusMailOptions wurde erst später eingeführt, bei Bedarf also hinzufügen

   171         #if (!grep /^iusMailOptions$/, @{$e->get("objectClass")}) {

   172         #$e->add(objectClass => "iusMailOptions");

   173         #}

   174 

   175         #if ($Cf->internal ne ":") {

   176         #$e->replace(iusRestrictedMail => $Cf->internal ? "TRUE" : "FALSE");

   177         #$modified++;

   178         #}

   179 

   180         verbose "ok\n";

   181         print "\n";

   182 

   183     }

   184 

   185 }

   186 

   187 sub _list() {

   188 

   189     #@ARGV = ("*") unless @ARGV;

   190 

   191     die "option acl_admin required\n" unless $Cf->acl_admin;

   192 

   193     if ( $Cf->aclgroups ) {

   194 

   195         warn "--folder option ignored when listing groups"

   196           unless $Cf->folder ~~ [];

   197         list_groups(@ARGV);

   198 

   199     } elsif (@ARGV) {

   200 

   201         #        my $uid = $ARGV[0];

   202         #        # searching by more than use user may be too expensive

   203         #        die "Searching by more than one user not supported" unless @ARGV == 1 or $uid =~ /\*/;

   204         #list_by_user($_) for @ARGV;

   205 

   206         warn "--folder option ignored when listing by user"

   207           unless $Cf->folder ~~ [];

   208         list_by_user( $imap, @ARGV );

   209 

   210     } elsif ( not $Cf->folder ~~ [] ) {

   211 

   212         list_by_folder($_) for @{ $Cf->folder };

   213 

   214     } else {

   215 

   216         die

   217           "Need either user or --folder. If you really want to search all users then supply the pattern '*'.";

   218 

   219     }

   220 

   221 }

   222 

   223 sub list_groups(@) {

   224 

   225     @_ = ('*') unless @_;

   226     my @ag = split ',', $Cf->imap_aclgroups;

   227     my $ag_all = 1 if '*' ~~ @ag;

   228     my $ag_att = AT_ACLGROUPS;

   229     my $filter =

   230       "(&($ag_att=*)" . "(|" . join( "", map { "(uid=$_)" } @_ ) . "))";

   231     my $r = $ldap->search(

   232         attrs  => [ 'uid', AT_ACLGROUPS ],

   233         filter => $filter,

   234         base   => $ubase,

   235     );

   236     die $r->error if $r->code;

   237 

   238     unless ( $r->count ) {

   239         print("No aclgroups found in ldap\n");

   240         exit 0;

   241     }

   242 

   243     my $users;

   244     while ( my $e = ( $r->shift_entry ) ) {

   245         my $uid = $e->get_value('uid');

   246         my @ag_cur = split ',', $e->get_value($ag_att);

   247         for (@ag_cur) {

   248             $users->{$_} =

   249               defined $users->{$_}

   250               ? [ @{ $users->{$_} }, $uid ]

   251               : [$uid]

   252               if $ag_all or $_ ~~ @ag;

   253         }

   254     }

   255 

   256     print "$_:\n\t", join( "\n\t", @{ $users->{$_} } ), "\n\n"

   257       for keys %{$users};

   258 

   259 }

   260 

   261 sub list_by_user($@) {

   262 

   263     my $imap = shift;

   264     my $filter = "(|" . join( "", map { "(uid=$_)" } @_ ) . ")";

   265 

   266     #my $filter = "(uid=$uid)";

   267     my $r = $ldap->search(

   268         filter => $filter,

   269         base   => $ubase,

   270     );

   271     die $r->error if $r->code;

   272     my @users;

   273     unless ( $r->count ) {

   274         verbose("No matching users found in ldap.\n");

   275         @users = @_;

   276     }

   277 

   278     while ( my $e = ( $r->shift_entry or shift @users ) ) {

   279 

   280         my ( $uid, $cn, $mr );

   281         if ( ref $e eq 'Net::LDAP::Entry' ) {

   282             $uid = $e->get_value("uid");

   283             $cn  = join( ", ", $e->get_value("cn") );

   284             $mr  = $e->get_value(AT_PRIMARYADDRESS) || "";    # ??

   285         } else {

   286             $uid = $e;

   287             $cn  = '[cn not available]';

   288             $mr  = '[address not available]';

   289         }

   290 

   291         print "$uid: $cn <$mr>\n";

   292 

   293         #if (($e->get_value("iusRestrictedMail")||"") eq "TRUE") {

   294         #print " INTERNAL";

   295         #}

   296 

   297         die "IMAP Server does not advertise acl support"

   298           unless $imap->capability->{acl};

   299 

   300         # namespace() result looks like this

   301         # [

   302         #   [   # list of private namespace(s)

   303         #       [

   304         #           prefix,

   305         #           name

   306         #       ],

   307         #       ...

   308         #   ],

   309         #   [   # list of namespace(s) for mailboxes shared by other users

   310         #       [

   311         #           prefix,

   312         #           name

   313         #       ],

   314         #       ...

   315         #   [   # list of namespace(s) for 'public' shared mailboxes

   316         #       [

   317         #           prefix,

   318         #           name

   319         #       ],

   320         #       ...

   321         #   ]

   322         my $hasacl;

   323         my $ns = $imap->namespace() or die "No public namespaces available: $@";

   324 

   325         # uns interessieren nur 'public' namespaces

   326         for my $n ( @{ $ns->[2] } ) {

   327 

   328             my $folders = imap_rlist( '', $n->[0], $n->[1] );

   329             for my $f ( @{$folders} ) {

   330 

   331                 #next if '\\Noselect' ~~ $f->[0];

   332                 my $perms = $imap->getacl($f) or die "Can't getacl '$f': $@";

   333                 my ( $u, $p );

   334                 while ( $u = shift @{$perms} and $p = shift @{$perms} ) {

   335                     next unless $u eq $uid;

   336                     $hasacl = 1;

   337                     print "\t$f: $u [$p]\n";

   338                 }

   339 

   340             }

   341 

   342         }

   343 

   344         print "\tno acl found on listable folders in shared namespaces\n"

   345           unless $hasacl;

   346         print "\n";

   347 

   348     }

   349 

   350 }

   351 

   352 sub list_by_folder($) {

   353 

   354     my ($folder) = @_;

   355 

   356     for my $f ( @{ acl_folders($folder) } ) {

   357 

   358         my $hasacl;

   359         print "$f\n";

   360 

   361         my $perms = $imap->getacl($f) or die $@;

   362         my ( $u, $p );

   363         while ( $u = shift @{$perms} and $p = shift @{$perms} ) {

   364 

   365             # '#user' will be listed when we have a global acl for 'user'

   366             my $gl = $u =~ /^\$?#/  ? ' [global]' : '';

   367             my $gr = $u =~ /^#?\$/ ? ' [group]'  : '';

   368             $hasacl = 1;

   369             print "\t$u [$p]$gr$gl\n";

   370         }

   371 

   372         print "\tno acl found\n" unless $hasacl;

   373         print "\n";

   374 

   375     }

   376 

   377 }

   378 

   379 sub verbose(@) {

   380     printf STDERR @_;

   381 }

   382 

   383 sub uniq(@) {

   384     my %x;

   385     @x{@_} = ();

   386     return keys %x;

   387 }

   388 

   389 {

   390     my @pw;

   391 

   392     sub _mkpw($) {

   393         my $in = $_[0];

   394 

   395         return $in unless $in and $in eq "{pwgen}";

   396 

   397         if ( !@pw ) {

   398             chomp( @pw = `pwgen 8 10 2>/dev/null` );

   399             die "pwgen: $!" if $?;

   400         }

   401         return shift @pw;

   402 

   403     }

   404 }

   405 

   406 sub imap_list($$) {

   407 

   408     my ( $ref, $folder ) = @_;

   409 

   410     my $list = $imap->list( $ref, $folder )

   411       or die "Can't list('$ref', '$folder'): $@";

   412 

   413     # single folder sieht wie folgt aus: [[flag1, flag2, ...], separator, foldername]

   414     ref $list and return [ map $_->[2], @{$list} ];

   415 

   416     # assuming empty result list otherwise

   417     return [];

   418 

   419 }

   420 

   421 sub imap_rlist($$$) {

   422 

   423     my ( $ref, $folder, $sep ) = @_;

   424     $folder =~ s/$sep+$//;

   425 

   426     my $list = imap_list( $ref, $folder );

   427     push @{$list}, @{ imap_list( $ref, "$folder$sep*" ) } if $Cf->recursive;

   428     return $list;

   429 }

   430 

   431 sub acl_folders($) {

   432 

   433     my ($f) = @_;

   434     my $folders;

   435 

   436     for my $np ( @{$nspat} ) {

   437 

   438         # don't modify $f!

   439         ( my $ft = $f ) =~ s/$np->[1]$//;

   440         return imap_rlist( '', $f, $np->[1] ) if ( $ft =~ /$np->[0]/ );

   441     }

   442 

   443     die "Foldername '$f' must begin with the name of a shared namespace\n";

   444 

   445 }

   446 

   447 sub prompt($$) {

   448     my ( $prompt, $default ) = @_;

   449     print $prompt, substr( $default, 0, 1 ), "\b";

   450     ReadMode 4;

   451     my $r = ReadKey(0);

   452     ReadMode 0;

   453     if ( $r eq "\n" ) { $r = $default }

   454     else              { $r .= substr( $default, 1 ) }

   455     print $r;

   456     return $r;

   457 }

   458 

   459 1;

   460 

   461 # vim:sts=4 sw=4 aw ai sm nohlsearch: