path: root/lib/Fripost/Schema.pm

package Fripost::Schema;

use 5.010_000;
use warnings;
use strict;

use Fripost::Schema::Search;
use Fripost::Schema::Type;

use base qw/Net::LDAP/;
our $VERSION = '0.01';


#######################################################################
# Public methods


# Change the context of the object.
sub user { $_[0]->Fripost::Schema::Type::_set_type(MAILBOX); }
sub domain { $_[0]->Fripost::Schema::Type::_set_type(DOMAIN); }
sub alias { $_[0]->Fripost::Schema::Type::_set_type(ALIAS); }


# Create the oject, and initialize a connection to the LDAP
# host.
sub new {
    my $class = shift;
    my $h = shift;

    my $self = {_options => $h};
    bless $self, $class;
    
    my $ldap = Net::LDAP->new ( $h->{server_host} )
        or die "Error: Cannot initialize connection to LDAP server.\n"; 

    my $mesg;
    if ( (defined $h->{bind_dn}) and $h->{bind_dn} ne '' ) {
        $self->_dsay( "Binding to DN `" .$h->{bind_dn}. "'." );
        $mesg = $ldap->bind( $h->{bind_dn}, password => $h->{bind_pw} );
    }
    else {
        # Anonymous bind
        $self->_dsay( "Anonymous bind." );
        $mesg = $ldap->bind();
    }
    die "Error: " .$mesg->error. "\n" if $mesg->code;
    
    $self->{_ldap} = $ldap;
    return $self;
}


# Search. Returns a `Fripost::Schema::Search'.
sub search {
    my $self = shift;
    my $res;
    if ( $self->{_type} == MAILBOX ) {
        $res = $self->_searchUser(@_)
    }
    elsif ( $self->{_type} == DOMAIN ) {
        $res = $self->_searchDomain(@_)
    }
    elsif ( $self->{_type} == ALIAS ) {
        $res = $self->_searchAlias(@_)
    }
    else {
        die "Something weird happened. Please report."
    }
    my $result = {_res => $res, _type => $self->{_type}};
    bless $result, 'Fripost::Schema::Search';
    return $result;
}


# Add.
sub add {
    my $self = shift;
    if ( $self->{_type} == MAILBOX ) {
        $self->_addUser(@_)
    }
    elsif ( $self->{_type} == DOMAIN ) {
        $self->_addDomain(@_)
    }
    elsif ( $self->{_type} == ALIAS ) {
        $self->_addAlias(@_)
    }
    else {
        die "Something weird happened. Please report."
    }
}


# Disconnect to the LDAP server.
sub unbind {
    $_[0]->{_ldap}->unbind();
}


#######################################################################
# Search

# Search a user, and return the corresponding entries if found. If no
# user is given, returns all users.
sub _searchUser {
    my $self = shift;
    
    my $base = join ',', ('ou=mailboxes',$self->{_options}->{base_dn});
    my $filter = "(ObjectClass=virtualMailbox)";

    $filter = "(&" .$filter. "(uid=" .$_[0]. ")" .")"
        if defined $_[0];

    my $res = $self->{_ldap}->search(
                  base   => $base,
                  scope  => 'one',
                  attrs  => [ 'uid', 'gn' , 'sn', 'maildir', 'isActive' ],
                  filter => $filter
            );
    die "Error: " .$res->error. "\n" if $res->code;

    return $res;
}


# Search a domain, and return the corresponding entries if found. If no
# domain is given, returns all domains. If the given domain has a
# defined owner, scope the search for this very owner only. If the
# owner is undefined, but still exists, scope the search to the "global"
# domains only.
sub _searchDomain {
    my $self = shift;

    my $base = $self->{_options}->{base_dn};
    if (exists $_[0]->{owner}) {
        if (defined $_[0]->{owner}) {
            $base = join ',', ('uid='.$_[0]->{owner},'ou=mailboxes',$base);
        }
        else {
            $base = join ',', ('ou=domains',$base);
        }
    }
    
    my $filter = '(ObjectClass=virtualDomain)';
    $filter = "(&" .$filter. "(dc=" .$_[0]->{domain}. ")" .")"
        if defined $_[0]->{domain};

    my $res = $self->{_ldap}->search(
                  base   => $base,
                  scope  => 'subtree',
                  attrs  => [ 'dc', 'isActive' ],
                  filter => $filter
            );
    die "Error: " .$res->error. "\n" if $res->code;

    return $res;
}


# Search an alias, and return the corresponding entries if found. If no
# alias is given, returns all aliases. If the given alias has a
# defined owner, scope the search for this very owner only. If the
# owner is undefined, but still exists, scope the search to the "global"
# domains only.
sub _searchAlias {
    my $self = shift;

    my $base = $self->{_options}->{base_dn};
    if (exists $_[0]->{owner}) {
        if (defined $_[0]->{owner}) {
            $base = join ',', ('uid='.$_[0]->{owner},'ou=mailboxes',$base);
        }
        else {
            $base = join ',', ('ou=domains',$base);
        }
    }
    $base = 'dc=' .$_[0]->{domain}. ',' .$base
        if (exists $_[0]->{owner}) and (defined $_[0]->{domain});

    my @filters = '(ObjectClass=virtualAliases)';
    push @filters, '(mailLocalAddress=' .$_[0]->{address}. ')'
        if defined $_[0]->{address};
    push @filters, '(mailTarget=' .$_[0]->{goto}. ')'
        if defined $_[0]->{goto};

    my $filter;
    if ($#filters == 0 ) {
        $filter = $filters[0];
    }
    elsif ($#filters > 0) {
        $filter = '(&' . (join '', @filters) . ')';
    }

    my $res = $self->{_ldap}->search(
                  base   => $base,
                  scope  => 'subtree',
                  attrs  => [ 'mailLocalAddress', 'mailTarget', 'isActive' ],
                  filter => $filter
            );
    die "Error: " .$res->error. "\n" if $res->code;

    return $res;
}



#######################################################################
# Add

# Add a user
sub _addUser {
    my $self = shift;
    my $user = shift;

    my $base = join ',', ('ou=mailboxes',$self->{_options}->{base_dn});

    my $res = $self->{_ldap}->add( 'uid=' .$user->{username}. ',' .$base,
                attrs => [ uid          => $user->{username},
                           objectClass  => [ 'top', 'virtualMailbox' ],
                           userPassword => $user->{userPassword},
                           maildir      => $user->{maildir},
                           isActive     => $user->{isActive}
                         ]
              );
    die "Error: " .$res->error. "\n" if $res->code;
    return $res;
}


# Add a domain.
sub _addDomain {
    my $self = shift;
    my $domain = shift;

    my $base = $self->{_options}->{base_dn};
    if (defined $domain->{owner}) {
        $base = join ',', ('uid=' .$domain->{owner},'ou=mailboxes',$base)
    }
    else {
        $base = join ',', ('ou=domains',$base);
    }

    my $res = $self->{_ldap}->add( 'dc=' .$domain->{domain}. ',' .$base,
                attrs => [ dc           => $domain->{domain},
                           objectClass  => [ 'top', 'virtualDomain' ],
                           isActive     => $domain->{isActive}
                         ]
              );
    die "Error: " .$res->error. "\n" if $res->code;
    return $res;
}


# Add an alias
sub _addAlias {
    my $self = shift;
    my $alias = shift;

    # TODO: detect cycles
    die "Error: Cannot create alias `" .$alias->{address}.
        "' targetting to itself.\n"
        if $alias->{address} eq $alias->{goto};
    
    my $base = $self->{_options}->{base_dn};
    if (defined $alias->{owner}) {
        $base = join ',', ('uid=' .$alias->{owner},'ou=mailboxes',$base)
    }
    else {
        $base = join ',', ('ou=domains',$base);
    }
    $base =     'mailTarget='.$alias->{goto}.
            ','.'dc='. (split /\@/, $alias->{address}, 2)[1].
            ','.$base;

    my @attrs = ( mailLocalAddress => $alias->{address}
                , isActive         => $alias->{isActive} );
    my $res;
    if ($self->_searchAlias($alias)->count) {
        $res = $self->{_ldap}->modify( $base, attrs => [ @attrs ] );
    }
    else {
        $res = $self->{_ldap}->add( $base,
                 attrs => [ mailTarget       => $alias->{goto}
                          , objectClass      => [ 'top',
                                                  'inetLocalMailRecipient',
                                                  'virtualAliases' ],
                            @attrs
                          ]
               );
    }
    die "Error: " .$res->error. "\n" if $res->code;
    return $res;
}



#######################################################################
# Miscellaneous

# Debug print.
sub _dsay {
    my $self = shift;
    return unless (exists $self->{_options}->{debug})
              and $self->{_options}->{debug};
    print STDERR "Debug: ";
    say STDERR @_;
}


1;

=head1 NAME

Fripost::Schema - 

=head1 AUTHOR

Guilhem Moulin C<< <guilhem at fripost.org> >>

=head1 COPYRIGHT

Copyright 2012 Guilhem Moulin, all rights reserved.

=head1 LICENSE

This program is free software; you can redistribute it and/or modify it
under the same terms as perl itself.

=cut

1; # End of Schema.pm

__END__