tCMS/bin/tcms-useradd

#!/usr/bin/env perl

package tcms::useradd;

use 5.040;
use re '/aasx';
use warnings FATAL => 'all';

use FindBin::libs;
use Getopt::Long;
use Pod::Usage;
use IO::Prompter();
use List::Util qw{first};

use Trog::Auth;
use Trog::Log;
use Trog::Data;
use Trog::Config;

=head1 SYNOPSIS

Add or edit a tCMS user.  In the event of a user edit, every option save for user is optional,
and the ones you leave out keep whatever value they already had.

Creating a user who does not exist yet needs --password, --display_name and --contact_email,
as there is no existing profile post to inherit them from.

Use this to reset user passwords or fix broken users.

=head2 USAGE

tcms-useradd --user foo --password bar --display_name baz --contact_email foo@bar.baz --acl fred --acl wilma

=head2 OPTIONS

=over 4

=item --user

Specify the user to add, or edit if the user already exists.

=item --password

Set a password for the user.  Omit the option entirely if you want to keep the
password an existing user already has.

Passing --password with no value prompts for one instead, with echo off, which
keeps it out of your shell history and off your screen:

    tcms-useradd --user foo --password           # prompts, twice, to confirm

It can also be piped in, in which case it is read once and not confirmed:

    echo hunter2 | tcms-useradd --user foo --password

Note that setting a password kills any session the user currently holds, so
they will have to log back in.

=item --display_name

Set the display name for the user.

=item --contact_email

Set the contact email for the user.

=item --acl

Set an acl for this user.  May be passed multiple times.
Defaults to 'admin' acl.

=item --help, --man

Display this output.

=back

=cut

# Read a password off the terminal without echoing it, so it stays out of the
# shell history and off the screen.  Falls back to a plain read when we aren't
# on a TTY, which is what makes `echo hunter2 | tcms-useradd ...` work.  Returns
# undef only at the end of the input, and q{} for an empty line.
my sub read_password ($prompt) {
    my $password = IO::Prompter::prompt( $prompt, -echo => q{}, -in => *STDIN, -out => *STDERR );
    return $password ? "$password" : undef;
}

# What a brand new user's profile post looks like before we merge anything over
# the top of it.  Mirrors what setup() builds for the very first user.
my sub default_user_post {    ## no critic (ProhibitSingleUseLexicalSubs) -- 14 lines, which would overcomplicate main()
    return {
        data       => 'Default user',
        preview    => '/img/avatar/humm.gif',
        wallpaper  => '/img/sys/testpattern.jpg',
        tags       => ['about'],
        visibility => 'public',
        acls       => ['admin'],
        callback   => 'Trog::Routes::HTML::users',
        method     => 'GET',
        form       => 'profile.tx',
        aliases    => [],
    };
}

sub main (@args) {
    my %options;
    Getopt::Long::GetOptionsFromArray(
        \@args,
        'user=s'          => \$options{user},
        'display_name=s'  => \$options{display_name},
        'help|?'          => \$options{help},
        'password:s'      => \$options{password},
        'contact_email=s' => \$options{contact_email},
        'acl=s@'          => \$options{acl},
    );
    pod2usage( -exitval => 0, -verbose => 1 ) if $options{help};

    unless ( $options{user} ) {
        print {*STDERR} "--user is required.\n";    ## no critic (ProhibitPrintSTDERR) -- for whoever ran this
        return 2;
    }

    # --password with no value means "ask me", as opposed to leaving the option
    # out entirely, which means "leave the password alone".
    if ( defined $options{password} && !$options{password} ) {
        $options{password} = read_password("New password for '$options{user}': ");

        unless ( $options{password} ) {
            print {*STDERR} "No password provided.\n";    ## no critic (ProhibitPrintSTDERR) -- for whoever ran this
            return 2;
        }

        # A person at a terminal always enters a line, even an empty one, so
        # they always confirm.  Piped input with one line has no second line,
        # and there is nothing to confirm against.
        my $again = read_password("Confirm: ");
        if ( defined $again && $options{password} ne $again ) {
            print {*STDERR} "Passwords did not match.\n";    ## no critic (ProhibitPrintSTDERR) -- for whoever ran this
            return 2;
        }
    }

    $options{acl} //= [];
    $options{acl} = [ $options{acl} ] if $options{acl} && ref $options{acl} ne 'ARRAY';
    $options{acl} = ['admin'] unless @{ $options{acl} };

    # Log to the file the server writes, as the user this run adds or edits.
    Trog::Log::log_init( 'logs/tcms.log', 'info' );
    $Trog::Log::user = $options{user} // 'nobody';

    # Find the user's existing post, if they have one.
    my $conf = Trog::Config::get();
    my $data = Trog::Data->new($conf);

    my @userposts = $data->get( tags => ['about'], acls => [qw{admin}] );
    my $user_obj  = first { ( $_->{user} || '' ) eq $options{user} } @userposts;

    # A user we've never seen before has no post to edit, so start from the
    # defaults rather than dereferencing undef.
    my $is_new = !$user_obj;
    $user_obj //= default_user_post();

    if ($is_new) {
        unless ( $options{password} && $options{display_name} && $options{contact_email} ) {
            print {*STDERR} "User '$options{user}' does not exist yet.\nCreating one needs --password, --display_name and --contact_email.\n";    ## no critic (ProhibitPrintSTDERR) -- for whoever ran this
            return 2;
        }
    }

    # Only the options actually passed should win.  Merging %options wholesale
    # writes an undef over every field the caller didn't mention, which is how
    # resetting a password used to blank out the display name and contact email.
    my %provided = map { $_ => $options{$_} } grep { defined $options{$_} } qw{user display_name contact_email};

    my %merged = (
        %$user_obj,
        %provided,
    );

    # The display name is the title of the post, and the URL it lives at.
    $merged{title}      = $merged{display_name}          if $merged{display_name};
    $merged{local_href} = "/users/$merged{display_name}" if $merged{display_name};

    Trog::Auth::killsession( $options{user} );

    local $@;
    eval { Trog::Auth::useradd( $options{user}, $merged{display_name}, $options{password}, $options{acl}, $merged{contact_email} ); 1 } or do {
        print {*STDERR} "Could not add user '$options{user}': $@";    ## no critic (ProhibitPrintSTDERR) -- for whoever ran this
        return 1;
    };

    eval { $data->add( \%merged ); 1 } or do {
        my @errors = ref $@ eq 'ARRAY' ? @{$@} : ($@);
        print {*STDERR} "Saved the credentials for '$options{user}', but their profile post was rejected:\n" . join( "\n", @errors ) . "\n";    ## no critic (ProhibitPrintSTDERR) -- for whoever ran this
        return 1;
    };

    print "@{[ $is_new ? 'Added' : 'Updated' ]} user '$options{user}'.\n";
    return 0;
}

exit main(@ARGV) unless caller;

1;