1 package acl;

     2 

     3 # © Heiko Schlittermann

     4 # $Id$

     5 # $URL$

     6 

     7 use strict;

     8 use warnings;

     9 use File::Path qw(remove_tree);

    10 use Net::LDAP;

    11 use Net::LDAP::Constant

    12   qw(LDAP_ALREADY_EXISTS LDAP_NO_SUCH_OBJECT LDAP_TYPE_OR_VALUE_EXISTS);

    13 use Net::LDAP::Entry;

    14 use Mail::IMAPTalk;

    15 use Text::Wrap;

    16 use password;

    17 

    18 my $Cf;

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

    20 my ( $imap, $acl_password );

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

    22 

    23 sub _list();

    24 sub _mkpw($);

    25 

    26 sub list_by_user($@);

    27 sub list_by_folder($$$);

    28 sub uniq(@);

    29 sub verbose(@);

    30 

    31 sub OU_ACCOUNTS();

    32 sub OU_ALIASES();

    33 sub AT_PRIMARYADDRESS();

    34 sub OC_RECIPIENT();

    35 sub AT_ADDRESS();

    36 sub AT_GROUP();

    37 sub AT_FORWARDINGADDRESS();

    38 sub AT_QUOTA();

    39 

    40 sub import(@) {

    41     $Cf = shift;

    42 

    43     require constant;

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

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

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

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

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

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

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

    51 

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

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

    54 }

    55 

    56 sub run($) {

    57 

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

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

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

    61              password => $Cf->ldap_password

    62           || $ENV{LDAP_PASS}

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

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

    65 

    66     $acl_password =

    67          $Cf->acl_password

    68       || $ENV{IMAP_PASS}

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

    70 

    71     if    ( $Cf->list )   { _list() }

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

    73     else { die "Need action (--modify|--list)\n" }

    74 

    75 }

    76 

    77 sub _modify() {

    78 

    79     die 'Not yet implemented';

    80 

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

    82     # dn: uid=USER,...

    83     my (@user) = @ARGV or die "Need user(s)\n";

    84     $Cf->user or die "Need user(s)\n";

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

    86     my @dns;

    87 

    88     my $r = $ldap->search(

    89         base   => $ubase,

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

    91     );

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

    93     die "No entries found.\n" if $r->count == 0;

    94 

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

    96         my $r;

    97 

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

    99         my $dn   = $e->dn;

   100 

   101         my $modified = 0;

   102         verbose "$user:";

   103 

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

   105 

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

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

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

   109         #}

   110 

   111         if ( my $cn = $Cf->fullname ) {

   112 

   113             # Aus dem Fullnamen leiten wir cn und sn ab.

   114             my $sn = ( reverse split " ", $cn )[0];

   115 

   116             if ( $cn =~ s/^\+// ) {

   117                 $e->replace(

   118                     cn => [ uniq $e->get("cn"), $cn ],

   119                     sn => [ uniq $e->get("sn"), $sn ]

   120                 );

   121             } elsif ( $cn =~ s/^-// ) {

   122                 $e->delete( cn => [$cn], sn => [$sn] );

   123             } else {

   124                 $e->replace( cn => $cn, sn => $sn );

   125             }

   126             $modified++;

   127         }

   128 

   129         if ( defined $Cf->other ) {

   130             my @o = split /,/, $Cf->other;

   131             grep { /^[+-]/ } @o or $e->delete(AT_ADDRESS);

   132 

   133             foreach my $a ( split /,/, $Cf->other ) {

   134                 if ( $a =~ s/^-// ) {

   135                     $e->delete( (AT_ADDRESS) => [$a] );

   136                 } else {

   137                     $a =~ s/^\+//;

   138 

   139                     # Darf noch nicht woanders sein

   140                     $r = $ldap->search( base => $ubase, filter => "(mail=$a)" );

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

   142                     die "$a ist schon vergeben\n" if $r->count;

   143 

   144                     $e->add( (AT_ADDRESS) => [$a] );

   145                 }

   146             }

   147             $modified++;

   148         }

   149 

   150         if ( defined $Cf->group ) {

   151             my @g = split /,/, $Cf->group;

   152             grep { /^[+-]/ } @g

   153               or $e->delete(AT_GROUP)

   154               if $e->get_value(AT_GROUP);

   155 

   156             foreach my $g (@g) {

   157                 if ( $g =~ s/^-// ) {

   158                     $e->delete( (AT_GROUP) => [$g] );

   159                 } else {

   160                     $g =~ s/^\+//;

   161                     $e->add( (AT_GROUP) => [$g] );

   162                 }

   163             }

   164             $modified++;

   165         }

   166 

   167         if ( defined $Cf->forward ) {

   168             my @f = split /,/, $Cf->forward;

   169             grep { /^[+-]/ } @f

   170               or $e->delete(AT_FORWARDINGADDRESS)

   171               if $e->get_value(AT_FORWARDINGADDRESS);

   172 

   173             foreach my $f (@f) {

   174                 if ( $f =~ s/^-// ) {

   175                     $e->delete( (AT_FORWARDINGADDRESS) => [$f] );

   176                 } else {

   177                     $f =~ s/^\+//;

   178                     $e->add( (AT_FORWARDINGADDRESS) => [$f] );

   179                 }

   180             }

   181             $modified++;

   182         }

   183 

   184         if ( my $a = $Cf->primary ) {

   185             $r = $ldap->search(

   186                 base => $ubase,

   187 

   188                 # filter => "(|(mailPrimaryAddress=$a)(mail=$a))");

   189                 filter => "(mail=$a)"

   190             );

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

   192             die "$a ist schon vergeben\n" if $r->count;

   193 

   194             $e->replace( (AT_PRIMARYADDRESS) => $Cf->primary );

   195             $modified++;

   196         }

   197 

   198         if ( my $pw = _mkpw( $Cf->password ) ) {

   199             $e->replace( userPassword => $pw );

   200             $modified++;

   201         }

   202 

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

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

   205         #$modified++;

   206         #}

   207 

   208         $e->dump if $Cf->debug;

   209 

   210         if ($modified) {

   211             $r = $e->update($ldap);

   212             die $r->error . $r->code if $r->code;

   213         }

   214 

   215         verbose "ok\n";

   216 

   217         print "\n";

   218     }

   219 

   220 }

   221 

   222 sub _list() {

   223 

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

   225 

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

   227 

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

   229         Server => $Cf->imap_server,

   230         Port   => $Cf->imap_port

   231     )

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

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

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

   235     die "IMAP Server does not advertise acl support" unless $imap->capability->{acl};

   236 

   237     if (@ARGV) {

   238 

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

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

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

   242         #list_by_user($_) for @ARGV;

   243         list_by_user($imap, @ARGV);

   244 

   245     } elsif ($Cf->folder) {

   246 

   247         list_by_folder($imap, $_, $Cf->recursive) for @{$Cf->folder};

   248 

   249     } else {

   250 

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

   252 

   253     }

   254 

   255 }

   256 

   257 sub list_by_user($@) {

   258 

   259     my $imap = shift;

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

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

   262     my $r = $ldap->search(

   263         filter => $filter,

   264         base   => $ubase,

   265     );

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

   267     verbose("No matching users found\n") unless $r->count;

   268 

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

   270 

   271         my $uid  = $e->get_value("uid");

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

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

   274 

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

   276 

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

   278         #print " INTERNAL";

   279         #}

   280 

   281         die "IMAP Server does not advertise acl support" unless $imap->capability->{acl};

   282         # namespace() result looks like this

   283         # [

   284         #   [   # list of private namespace(s)

   285         #       [

   286         #           prefix,

   287         #           name

   288         #       ],

   289         #       ...

   290         #   ],

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

   292         #       [

   293         #           prefix,

   294         #           name

   295         #       ],

   296         #       ...

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

   298         #       [

   299         #           prefix,

   300         #           name

   301         #       ],

   302         #       ...

   303         #   ]

   304         my $hasacl;

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

   306         # uns interessieren nur 'public' namespaces

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

   308 

   309             my $folders = $imap->list( '', "$n->[0]*" ) or die $@;

   310             ref $folders or die "Got empty folder list. Does '$n->[0]' actually exist? Is it readable?";

   311 

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

   313 

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

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

   316                 my $perms = $imap->getacl( $f->[2] ) or die $@;

   317                 my ($u, $p);

   318                 while ($u = shift @{$perms} and $p = shift @{$perms} and $u eq $uid) { 

   319                     $hasacl = 1;

   320                     print "\t$f->[2]: $u [$p]\n";

   321                 }

   322 

   323             }

   324 

   325         }

   326 

   327         print "\tno acl found on listable folders in shared namespaces\n" unless $hasacl;

   328         print "\n";

   329 

   330     }

   331 

   332 }

   333 

   334 sub list_by_folder($$$) {

   335 

   336     my ($imap, $folder, $recursive) = @_;

   337 

   338     $folder .= '/' unless $folder =~ m,/$,;

   339     my $folders = $recursive

   340         ? ($imap->list('', "$folder*") or die $@)

   341         : [[ undef, undef, $folder ]];

   342 

   343     ref $folders or die "Got empty folder list. Does '$folder' actually exist? Is it readable?";

   344 

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

   346 

   347         my $hasacl;

   348         print "$f->[2]\n";

   349 

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

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

   352         my $perms = $imap->getacl( $f->[2] ) or die $@;

   353         my ($u, $p);

   354         while ($u = shift @{$perms}

   355                 and $p = shift @{$perms}) {

   356             next if $u eq $Cf->acl_admin or $u eq $Cf->imap_admin;

   357             $hasacl = 1;

   358             print "\t$u [$p]\n";

   359         }

   360 

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

   362         print "\n";

   363 

   364     }

   365 

   366 }

   367 

   368 sub verbose(@) {

   369     printf STDERR @_;

   370 }

   371 

   372 sub uniq(@) {

   373     my %x;

   374     @x{@_} = ();

   375     return keys %x;

   376 }

   377 

   378 {

   379     my @pw;

   380 

   381     sub _mkpw($) {

   382         my $in = $_[0];

   383 

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

   385 

   386         if ( !@pw ) {

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

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

   389         }

   390         return shift @pw;

   391 

   392     }

   393 }

   394 

   395 1;

   396 

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