path: root/fripost-adduser

#!/usr/bin/perl

use 5.010_000;
use strict;
use warnings;
use utf8;

=head1 NAME

fripost-adduser - Add a new mailbox to the system

=head1 SYNOPSIS

B<fripost-adduser> [B<--verbose>] [B<--debug>] [B<--pretend>] [I<username>]
[B<--password=>I<password>]

=head1 DESCRIPTION

B<fripost-adduser> adds a new virtual mailbox to the system, unless
B<--pretend> is set.
If I<username> or I<password> are not given, the user is prompted for
them.
If I<username> is not fully qualified, C<fripost.org> is appended.
If I<username> is already an existing username or alias,
B<fripost-adduser> raises an error.

=head1 OPTIONS

=over 8

=item B<--pretend>

Only simulates the insertion. (But still query the LDAP server to ensure
that I<username> is not already in the database.)

=item B<--password=>I<password>

By default, the user is prompted for his/her new password, which is
hashed, salted and then added to the LDAP entry.
By using B<--password>, I<password> is inserted RAW in the database.
This can be useful if the user does not want to give the clear copy but
only a hash, for example.
Using this option disables the sending of credentials.

=item B<--server_host=>I<host>

The LDAP URI to connect to.
The default value is read from the configuration file, see B<CONFIGURATION>.

=item B<--bind_dn=>I<binddn>

The Distinguished Name (DN) to bind to the LDAP directory.
(If not set, B<fripost-adduser> binds anonymously.)
The default value is read from the configuration file, see B<CONFIGURATION>.

=item B<--bind_pw=>I<password>

The password to to bind with.
The default value is read from the configuration file, see B<CONFIGURATION>.

=item B<--base_dn=>I<basedn>

The root DN for everything done by B<fripost-adduser>.
The default value is read from the configuration file, see B<CONFIGURATION>.

=item B<-v>, B<--verbose>

Verbose mode.

=item B<--debug>

Debug mode.

=back

=head1 CONFIGURATION

The configuration is read from the file C<$HOME/.fripost.yml>.
Valid keys include:

=over 4

=item I<server_host>

The LDAP URI to connect to. Defaults to C<ldap://127.0.0.1:389>.

=item I<admin_email>

The I<From:> e-mail address to use. Defaults to C<admin@fripost.org>.

=item I<bind_dn>

The Distinguished Name (DN) to bind to the LDAP directory.
(If not set, B<fripost-adduser> binds anonymously.)

=item I<bind_pw>

The password to to bind with.

=item I<base_dn>

The root DN for everything done by B<fripost-adduser>.

=back

=cut

use FindBin qw($Bin);
use lib "$Bin/lib";

use Env qw /HOME/;
use File::Spec::Functions;

use Data::Dumper;
use Encode qw(encode);
use File::Slurp qw(slurp);
use Fripost::Password;
use Fripost::Prompt;
use Fripost::Schema;
use Getopt::Long qw /:config noauto_abbrev no_ignore_case
                             gnu_compat bundling permute nogetopt_compat
                             auto_version auto_help/;
use Pod::Usage;
use IO::Prompt;
use MIME::Lite;
use MIME::QuotedPrint;
use Template;
use YAML::Syck;


## Get command line options
our $conf = LoadFile( catfile ($HOME, '.fripost.yml') );

GetOptions(
    'server_host=s' => \$conf->{server_host},
    'base_dn=s'     => \$conf->{base_dn},
    'bind_dn=s'     => \$conf->{bind_dn},
    'bind_pw=s'     => \$conf->{bind_pw},
    'pretend'       => \$conf->{pretend},
    'debug'         => \$conf->{debug},
    'v|verbose'     => \$conf->{verbose},
    'password=s'    => \$conf->{password},
    'man'           => sub { pod2usage(-exitstatus => 0,
                                       -verbose => 2) }
) or pod2usage(2);

sub dsay { say STDERR @_ if $conf->{debug}; }
sub vsay { say STDERR @_ if $conf->{verbose} || $conf->{debug}; }


# Connect to the LDAP server
my $ldap = Fripost::Schema->new( $conf );


# Define the new user
my $user;
my ($domain, $login);
{
    my $username;
    if (defined $ARGV[0]) {
        $username = fix_username ($ARGV[0]);
        Email::Valid->address($username)
            or die "Error: $username is not a valid e-mail.\n";
    }
    else {
        $username = prompt_email("New username: ", 'is_user');
    }
    ($login, $domain) = split /\@/, $username, 2;
    my $maildir      = "$domain/$login/Maildir/"; # Trailing slash important
    my $isActive     = 'TRUE';
    my ($userPassword, $clearPassword);
    if ( defined $conf->{password} ) {
        $userPassword  = $conf->{password};
    }
    else {
        $clearPassword = prompt_password();
        $userPassword  = hash( undef, undef, $clearPassword );
    }

    $user = {
        username      => $username,
        maildir       => $maildir,
        isActive      => $isActive,
        userPassword  => $userPassword,
    };
    $user->{clearPassword} = $clearPassword unless defined $conf->{password};

    say "User name: $user->{username}";
    say "Password:  (hidden)";

    confirm_or_abort();
}


{
    # Ensure that the username doesn't already exist.
    die "Error: User `" .$user->{username}. "' already exists.\n"
        if $ldap->user->search({ username => $user->{username} })->count;

    # Ensure that the username doesn't correspond to an existing alias.
    my $res = $ldap->alias->search({ address => $user->{username} });
    if ($res->count) {
        print STDERR "Error: Alias $user->{username} already exists. ";
        print STDERR "(Targetting to ";
        print STDERR (join ', ', map { $_->{goto} } ($res->entries));
        say STDERR ".)";
        exit 1;
    }

    # Warn if the domain is unknown.
    warn "WARN: Unknown domain `" .$domain. "'.\n"
        unless $ldap->domain->search({ domain => $domain })->count;
}


## Insert the new user
if ($conf->{pretend}) {
    vsay "Did not create user since we are pretending.";
}
else {
    my %user = %$user;
    delete $user{clearPassword};
    $ldap->user->add(\%user);
    say "New account $user{username} added.";
}

$ldap->unbind();



### Prepare sending emails

my $tt = Template->new({
    INCLUDE_PATH => "$Bin/templ",
    INTERPOLATE  => 1,
}) || die "$Template::ERROR\n";

my $admin_email = $conf->{admin_email};
$admin_email  //= 'admin@fripost.org';
my $msg = MIME::Lite->new(

    From    => encode('MIME-Q', 'Friposts administratörer') . ' <' .$admin_email. '>',
    Subject => encode('MIME-Q', 'Välkommen till Fripost!'),
    Encoding => 'quoted-printable',
);

$msg->attr('content-type.charset' => 'utf-8');

### Send welcome email to new user
{
    my ($vars, $data);
    $vars = {};

    $tt->process('new_user_mail.tt', $vars, \$data)
        || die $tt->error(), '\n';
    $msg->data($data);

    $msg->replace(To => $user->{username});

    unless ($conf->{pretend}) {
        $msg->send() unless $conf->{pretend};
        say "Sent welcome message.";
    }
    dsay "-----------------------------------";
    dsay "| Welcome mail                    |";
    dsay "-----------------------------------";
    dsay decode_qp($msg->as_string);
    dsay "-----------------------------------";
}

### Subscribe user to announce-list
if (confirm("Subscribe user to announce mailing list? ")) {
    $msg->replace(From => $user->{username});
    $msg->replace(To => 'announce-subscribe@lists.fripost.org');
    $msg->replace(Subject => '');
    $msg->replace(Data => '');
    $msg->send();
}

### Send login credentials to new user
if (exists $user->{clearPassword}) {
    my ($vars, $data);
    $vars = {
        user => $user->{username},
        pass => $user->{clearPassword},
    };

    $tt->process('user_info.tt', $vars, \$data)
        || die $tt->error(), '\n';
    $msg->data($data);

    dsay "-----------------------------------";
    dsay "| Login credentials mail          |";
    dsay "-----------------------------------";
    dsay decode_qp($msg->as_string);
    dsay "-----------------------------------";

    confirm_or_abort("Send email with login information? ");
    my $to = prompt_email("Where should the email be sent? ");
    $msg->replace(To => $to);

    if (!$conf->{pretend}) {
        $msg->send;
        say "Credentials sent.";
    }
    else {
        say "Pretending, will not send credentials.";
    }
}

=head1 AUTHOR

Stefan Kangas C<< <skangas at skangas.se> >>

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

=head1 COPYRIGHT

Copyright 2010,2011 Stefan Kangas.

Copyright 2012 Guilhem Moulin.

=head1 LICENSE

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

=cut