A more modular prompt.

6 files changed, 234 insertions, 262 deletions

diff --git a/lib/Fripost/Commands/add_alias.pm b/lib/Fripost/Commands/add_alias.pm
index 8581a9f..60fe378 100644
--- a/lib/Fripost/Commands/add_alias.pm
+++ b/lib/Fripost/Commands/add_alias.pm
@@ -19,7 +19,6 @@ use IO::Prompter;
 use Fripost::Prompt;
 use Fripost::Schema;
 use Fripost::Email;
-use Fripost::Tests;
 
 our $VERSION = '0.01';
 
@@ -27,42 +26,48 @@ sub main {
     my $ldap = shift;
     my $conf = shift;
 
-    # Get information
-    my $goto = fix_username(shift);
-    $goto //= prompt_email("Alias goto address: ", 'is_user');
+    my $goto = shift;
     my @addr = @_;
-    @addr || push @addr, (split /, */, prompt "Alias from address(es): ");
 
-    my $graph = build_alias_graph ($ldap->alias->search()->entries);
-    my @path = search_path ($graph, $goto, $addr[0]);
-    die "Error: Cannot create cycle " . join (' -> ', @path) . ' -> ' . $goto . "\n"
-        if @path;
+    prompt_if_undefined ( "Alias goto address: ", \$goto,
+        [ rewrite => sub { fix_username $_ }
+        , 'Invalid e-mail' => sub { Email::Valid->address($_) }
+        ]
+    );
+
+    # Since we don't have that many users and aliases for the time
+    # being, it's probably better to load the whole graph of aliases in
+    # memory, not to make too many queries to the LDAP server.
+    my $graph = &build_alias_graph( $ldap->alias->search()->entries );
+
+    prompt_if_undefined ( "Alias from address(es): ", \@addr,
+        [ rewrite => sub { fix_username $_ }
+        , 'Invalid e-mail' => sub { Email::Valid->address('fake'.$_) }
+        , 'Unknown domain' => sub { $ldap->domain->search({
+                                        domain => (split /\@/, $_, 2)[1]
+                                    })->count }
+        , 'User exists'    => sub { $ldap->user->search({
+                                       username => $_
+                                    })->count == 0 }
+        , 'Alias exists'   => sub { $conf->{force} or
+                                    $ldap->alias->search({
+                                       address => $_
+                                    })->count == 0 }
+        , "Is already an alias for `$goto'" =>
+                sub { $ldap->alias->search({
+                          address => $_, goto => $goto
+                      })->count == 0 }
+        , "Reachable from `$goto'" =>
+                sub { !&search_path ($graph, $goto, $_, ($conf->{debug} or
+                                                         $conf->{verbose})) }
+        ]
+    );
+    unless (@addr) {
+        say "All right, not much to do.";
+        exit 0;
+    }
 
-    # Show goto adress
     say "Goto adress: $goto";
-
-    # Show from adresses
-    @addr = grep {
-        if (Email::Valid->address('fake'.$_)) {
-            # Warn if the domain is unknown.
-            my $domain = (split /\@/, $_, 2)[1];
-            if ($ldap->domain->search({ domain => $domain })->count) {
-                1;
-            }
-            else {
-                warn "WARN: Skipping unknown domain `" .$domain. "'.\n";
-                undef;
-            }
-        }
-        else {
-            warn "WARN: Skipping invalid address `" .$_. "'.\n";
-            undef;
-        }
-    } @addr;
-    if (@addr == 0) {
-        warn "No valid destination adresses. Aborting...\n";
-        exit 1;
-    }
     say "From adress(es): " . (join ", ", @addr);
     confirm_or_abort();
 
@@ -70,22 +75,6 @@ sub main {
 
     ## Insert alias
     for my $addr (@addr) {
-    
-        my ($u,$d) = split /\@/, $addr, 2;
-    
-        # Ensure that the alias doesn't already exist.
-        my $rs = $ldap->alias->search({ address => $addr });
-        if ($rs->count and not (defined $conf->{force})) {
-            print STDERR "Error: Alias $addr already exists. ";
-            print STDERR "(Targetting to ";
-            print STDERR (join ', ', map { $_->{goto} } $rs->entries);
-            say STDERR ".)";
-            exit 1;
-        }
-    
-        die "Error: Username $addr exists.\n"
-            if ($ldap->user->search({ username => $addr })->count);
-    
         if ($conf->{pretend}) {
             say STDERR "Did not create alias since we are pretending."
                 if $conf->{verbose} or $conf->{debug};
@@ -102,7 +91,7 @@ sub main {
             if $conf->{verbose} or $conf->{debug};
     }
     else {
-        if (confirm_or_abort("Send confirmation? ")) {
+        if (confirm "Send confirmation? ") {
             $msg->send();
             say "Sent confirmation (". (security_status $msg) .").";
         }
@@ -110,6 +99,46 @@ sub main {
 }
 
 
+# Build the graph of aliases. It is a hash where the keys are the 'from'
+# part of the aliases, and the values are array references of the 'goto'
+# part.
+# For 'search_path' it is better to do it that way, as for a given
+# 'from' the list of 'goto' is likely to be of length one only. (Hence
+# the stack won't blow up.)
+sub build_alias_graph {
+    my $graph;
+    foreach (@_) {
+        my $to = $_->{goto};
+        foreach my $from (@{$_->{address}}) {
+            push @{$graph->{$from}}, $to;
+        }
+    }
+    return $graph;
+}
+
+
+# Search a path in the given graph.
+sub search_path {
+    my ($graph, $from, $to, $verbose) = @_;
+
+    my @stack;
+    push @stack, [$from];
+
+    while (@stack) {
+        my $path = pop @stack;
+        my $last = @{$path}[$#$path];
+        if ($last eq $to) {
+            say STDERR 'Path found: ', join (' -> ', @$path) if $verbose;
+            return @$path;
+        }
+
+        foreach (@{$graph->{$last}}) {
+            push @stack, [@$path,$_];
+        }
+    }
+}
+
+
 =head1 AUTHOR
 
 Stefan Kangas C<< <skangas at skangas.se> >>
diff --git a/lib/Fripost/Commands/add_domain.pm b/lib/Fripost/Commands/add_domain.pm
index 4d53e35..fc78396 100644
--- a/lib/Fripost/Commands/add_domain.pm
+++ b/lib/Fripost/Commands/add_domain.pm
@@ -18,7 +18,6 @@ use Fripost::Password;
 use Fripost::Prompt;
 use Fripost::Schema;
 use Email::Valid;
-use IO::Prompter;
 
 our $VERSION = '0.01';
 
@@ -28,53 +27,36 @@ sub main {
 
     # Define the domain that is to be added.
     my %domain;
-    $domain{domain}   = $_[0];
-    $domain{domain} //= prompt "Domain name: ";
+    $domain{domain}   = shift;
+    $domain{owner}    = shift;
     $domain{isActive} = 'TRUE';
 
-    # Ensure that the domain is valid.
-    die "Error: Invalid domain `$domain{domain}'.\n"
-        unless Email::Valid->address('fake@'.$domain{domain});
-
-    $domain{owner}   = $_[1];
-    $domain{owner} //= prompt_email("Belongs to user: ", 'is_user');
-
-    if ($domain{owner} eq '') {
-        $domain{owner} = undef
-    }
-    else {
-        die "Error: $domain{owner} is not a valid e-mail.\n"
-            unless Email::Valid->address($domain{owner});
-    }
-
-    # Check that the owner exists.
-    die "Error: Unknown user `" .$domain{owner}. "'.\n"
-        unless (not defined $domain{owner})
-            or $ldap->user->search({ username => $domain{owner} })->count;
-
-    # Check that the owner doesn't already own this very domain, or that the
-    # domain isn't an existing "global" domain.
-    if ($ldap->domain->search(\%domain)->count) {
-        print STDERR "Error: Domain `" .$domain{domain}. "' already exists";
-        print STDERR " for user `" .$domain{owner}. "'" if defined $domain{owner};
-        say STDERR ".";
-        exit 1;
-    }
-
-    # If the domain exists (but is eg, owned by someone else), produce a
-    # warning.
-    my $res = $ldap->domain->search({ domain => $domain{domain} });
-    if ($res->count) {
-        print STDERR "WARN: Domain `" .$domain{domain}. "' already exists.";
-        my @owners;
-        map { push @owners, @{$_->{owner}} if defined $_->{owner} } $res->entries;
-        if (@owners) {
-            print STDERR " (Owned by ";
-            print STDERR (join ', ', map { '`' .$_. "'"} @owners);
-            print STDERR ".)";
-        }
-        print STDERR "\n";
-    }
+    prompt_if_undefined ( "New domain name: ", \$domain{domain},
+        [ 'Invalid domain' => sub { Email::Valid->address('fake@'.$_) }
+        , 'Domain exists'  => sub { defined $conf->{force} or
+                                    $ldap->domain->search({
+                                        domain => $_
+                                    })->count == 0 }
+        ]
+    );
+
+    prompt_if_undefined ( "Belongs to user: ", \$domain{owner},
+        [ rewrite => sub { fix_username $_ }
+        , 'Invalid e-mail' => sub { Email::Valid->address($_) }
+        , 'Unknown domain' => sub { $ldap->domain->search({
+                                        domain => (split /\@/, $_, 2)[1]
+                                    })->count }
+        , 'Unknown username' => sub { $ldap->user->search({
+                                        username => $_
+                                      })->count }
+        , "Already owns `$domain{domain}'" =>
+               sub { $ldap->domain->search({
+                           domain => $domain{domain}, owner => $_
+                     })->count == 0 }
+        ]
+    )
+        unless defined $domain{owner} and $domain{owner} eq '';
+    undef $domain{owner} if $domain{owner} eq '';
 
     if ($conf->{pretend}) {
         say STDERR "Did not add the domain since we are pretending."
@@ -84,9 +66,8 @@ sub main {
         # Add the domain.
         $ldap->domain->add(\%domain);
         if (defined $domain{owner}) {
-            print "New domain `" .$domain{domain}. "' added";
-            print " for user `" .$domain{owner}. "'" if defined $domain{owner};
-            say ".";
+            say "New domain `" .$domain{domain}. "' added for user `"
+               .$domain{owner}. "'.";
         }
         else {
             say "New non self-managed domain `" .$domain{domain}. "' added.";
@@ -108,11 +89,10 @@ sub create_alias {
 
     my $res = $ldap->alias->search(\%alias);
     if ($res->count) {
-        print STDERR "WARN: Alias $alias{address} already exists.";
-        print STDERR "(Targetting to ";
-        print STDERR (join ', ', map { $_->{goto} } $res->entries);
-        say STDERR ".)";
-        return unless grep { $_->{goto} eq $alias{goto} } $res->entries;
+        say STDERR "WARN: Alias $alias{address} already exists."
+                  ." (Targetting to " . (join ', ', map { $_->{goto} } $res->entries)
+                  .".)";
+        return if grep { $_->{goto} eq $alias{goto} } $res->entries;
     }
 
     $alias{isActive} = 'TRUE';
diff --git a/lib/Fripost/Commands/add_user.pm b/lib/Fripost/Commands/add_user.pm
index 4e1cf10..41cabc7 100644
--- a/lib/Fripost/Commands/add_user.pm
+++ b/lib/Fripost/Commands/add_user.pm
@@ -18,57 +18,33 @@ use Fripost::Password;
 use Fripost::Prompt;
 use Fripost::Schema;
 use Fripost::Email;
+use Email::Valid;
 
 our $VERSION = '0.01';
 
 our @EXPORT = qw/main/;
 our @ISA = qw(Exporter);
 
-sub assert {
-    my $ldap = shift;
-    my $username = shift;
-    my ($login, $domain) = split /\@/, $username, 2;
-
-    # Error if the domain is unknown.
-    die "Error: Unknown domain `" .$domain. "'.\n"
-        unless $ldap->domain->search({ domain => $domain })->count;
-    
-    # Ensure that the username doesn't already exist.
-    die "Error: User `" .$username. "' already exists.\n"
-        if $ldap->user->search({ username => $username })->count;
-    
-    # Ensure that the username doesn't correspond to an existing alias.
-    my $res = $ldap->alias->search({ address => $username });
-    if ($res->count) {
-        print STDERR "Error: Alias $username already exists. ";
-        print STDERR "(Targetting to ";
-        print STDERR (join ', ', map { $_->{goto} } $res->entries);
-        say STDERR ".)";
-        exit 1;
-    }
-}
-
-
 sub main {
     my $ldap = shift;
     my $conf = shift;
-    
-    # Define the new user
-    my $username;
-    {
-        if (defined $_[0]) {
-            $username = fix_username ($_[0]);
-            Email::Valid->address($username)
-                or die "Error: $username is not a valid e-mail.\n";
-        }
-        else {
-            $username = prompt_email( "New username: ", 'is_user' );
-            # TODO: add the assert in the hash.
-        }
-    }
-
-    &assert ($ldap, $username);
 
+    my $username = shift;
+    prompt_if_undefined ( "New username: ", \$username,
+        [ rewrite => sub { fix_username $_ }
+        , 'Invalid e-mail' => sub { Email::Valid->address($_) }
+        , 'Unknown domain' => sub { $ldap->domain->search({
+                                        domain => (split /\@/, $_, 2)[1]
+                                    })->count }
+        , 'User exists'    => sub { $ldap->user->search({
+                                       username => $_
+                                    })->count == 0 }
+        , 'Alias exists'   => sub { $ldap->alias->search({
+                                       address => $_
+                                    })->count == 0 }
+        ]
+    );
+    
 
     my $user;
     my $clearPassword;
@@ -99,7 +75,10 @@ sub main {
     my $info;
     unless (defined $conf->{password}) {
         if (confirm "Send email with login information? ") {
-            my $to = prompt_email("Where should the email be sent? ");
+            my $to;
+            prompt_if_undefined ( "Where should the email be sent? ", $to,
+                [ 'Invalid e-mail' => sub { Email::Valid->address($_) } ]
+            );
             $info = new_user_info_message ( $conf, $user->{username},
                                                    $clearPassword,
                                                    $to );
diff --git a/lib/Fripost/Commands/user_passwd.pm b/lib/Fripost/Commands/user_passwd.pm
index 805b7e1..64f35d9 100644
--- a/lib/Fripost/Commands/user_passwd.pm
+++ b/lib/Fripost/Commands/user_passwd.pm
@@ -25,24 +25,18 @@ sub main {
     my $ldap = shift;
     my $conf = shift;
 
-    my $username;
-    if (defined $_[0]) {
-        $username = fix_username ($_[0]);
-        Email::Valid->address($username)
-            or die "Error: `" .$username. "' is not a valid e-mail.\n";
-    }
-    else {
-        $username = prompt_email("Username: ", 'is_user');
-    }
-
-
-    # Ensure that the user exists.
-    my $domain = (split /\@/, $username, 2)[1];
-    die "Error: Unknown domain `" .$domain. "'.\n"
-        unless $ldap->domain->search({ domain => $domain })->count;
-    die "Error: Unknown user `" .$username. "'.\n"
-        unless $ldap->user->search({ username => $username })->count;
-
+    my $username = shift;
+    prompt_if_undefined ( "Username: ", \$username,
+        [ rewrite => sub { fix_username $_ }
+        , 'Invalid e-mail' => sub { Email::Valid->address($_) }
+        , 'Unknown domain' => sub { $ldap->domain->search({
+                                        domain => (split /\@/, $_, 2)[1]
+                                    })->count }
+        , 'Unknown user'   => sub { $ldap->user->search({
+                                       username => $_
+                                    })->count }
+        ]
+    );
 
     my $password   = $conf->{password};
     $password    //= hash( prompt_password() );
diff --git a/lib/Fripost/Prompt.pm b/lib/Fripost/Prompt.pm
index 0edc22f..fbd39e6 100755
--- a/lib/Fripost/Prompt.pm
+++ b/lib/Fripost/Prompt.pm
@@ -1,7 +1,9 @@
 package Fripost::Prompt;
 
 use 5.010_000;
+use warnings;
 use strict;
+use utf8;
 
 =head1 NAME
 
@@ -17,21 +19,22 @@ use Exporter;
 use IO::Prompter;
 use Fripost::Password qw/mkpasswd/;
 
-our @EXPORT = qw(confirm confirm_or_abort fix_username prompt_email prompt_password);
+our @EXPORT = qw(confirm confirm_or_abort fix_username
+                 prompt_password prompt_if_undefined);
 our @ISA = qw(Exporter);
 
 sub confirm {
     my ($msg) = @_;
-    $msg //= "Is this OK? [no will abort] ";
-    return prompt -in => \*STDIN, -out => \*STDOUT, $msg, -yn;
+    $msg //= "Is this OK? ";
+    return prompt -in => \*STDIN, -out => \*STDOUT, -yn, $msg;
 }
 
 sub confirm_or_abort {
     my ($msg) = @_;
     $msg //= "Is this OK? [no will abort] ";
-    my $confirmed = prompt -in => \*STDIN, -out => \*STDOUT, $msg, -yn;
+    my $confirmed = prompt -in => \*STDIN, -out => \*STDOUT, -yn, $msg;
     unless ($confirmed) {
-        say "User aborted";
+        say "Aborted";
         exit 1;
     }
 }
@@ -45,24 +48,87 @@ sub fix_username {
     return $nam;
 }
 
-sub prompt_email {
-    my ($msg, $is_username) = @_;
-    $msg //= "Enter email: ";
-    my $email;
-    do {
-        $email = prompt -in => \*STDIN, -out => \*STDOUT, $msg;
 
-        if ($is_username) {
-            $email = fix_username($email);
+# Prompt (with the given prompt message) only if $value is an undefined
+# scalar, or an empty array reference.
+# Constraints may be added on the value, as a array reference where the
+# even indexes correspond to constraint names, and the odd ones are the
+# code that is to be executed. Constraints are checked in the order they
+# are defined (that is why $must is an array reference, not a hash
+# reference). If the *first* constraint name is 'rewrite', it is used to
+# rewrite each value prior to the constraint check.
+#
+# If 'value' is an empty array reference, the prompted value is
+# interpreted as a comma/space separated list of values.
+#
+sub prompt_if_undefined {
+    my ($msg, $value, $must) = @_;
+    my $many = ref $value eq 'ARRAY';
+
+    my $rewrite;
+    if (defined $must and $#$must >= 1 and $must->[0] eq 'rewrite') {
+        shift $must;
+        $rewrite = shift $must;
+    }
+    else {
+        $rewrite //= sub { $_ };
+    }
+
+    if ((not $many and defined $$value) or ($many and @$value)) {
+        if ($many) {
+            for (my $i = 0; $i <= $#$value; $i++) {
+                $value->[$i] = eval { local $_ = $value->[$i];
+                                      $rewrite->($value->[$i]) };
+                &check_all ($value->[$i], $must, 1);
+            }
+        }
+        else {
+            $$value = eval { $_ = $$value; $rewrite->($$value) };
+            &check_all ($$value, $must, 1);
         }
+    }
+    else {
+        my $v;
+        do {
+            $v = prompt -in => \*STDIN, -out => \*STDOUT, $msg; 
+            my $vs = $many ? [ map {&$rewrite} (split / *, *| +/, $v) ]
+                             : eval { local $_ = $v; $rewrite->($v) };
+            $v = $vs;
+            foreach ($many ? @$vs : ($vs)) {
+                undef $v unless &check_all ($_, $must);
+            }
+        }
+        until (defined $v);
 
-        unless (Email::Valid->address($email)) {
-            undef $email;
-            say "Error: This is not a valid e-mail address. Try again."
+        if ($many) {
+            map { push @$value, $_ } @$v;
+        }
+        else {
+            $$value = $v;
         }
     }
-    until (defined $email);
-    return $email;
+}
+
+# Check every constraint in $must for the given $value. 
+# If a constraint is not verified (returns a null value), die if $croak
+# is true, and return 0 otherwise.
+# Return 1 if all constraints are verified.
+sub check_all {
+    my ($value, $must, $croak) = @_;
+    return 1 unless defined $must;
+
+    my @constraints = @$must;
+    while (@constraints) {
+        my $msg = shift @constraints;
+        my $constraint = shift @constraints;
+        unless (eval { local $_ = $value; $value ~~ $constraint}) {
+            print STDERR "Error: `" . $value . "': " . $msg . ".";
+            die "\n" if $croak;
+            say STDERR ' Try again.';
+            return 0;
+        }
+    }
+    return 1;
 }
 
 sub prompt_password {
@@ -100,10 +166,14 @@ sub prompt_password {
 
 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
diff --git a/lib/Fripost/Tests.pm b/lib/Fripost/Tests.pm
deleted file mode 100755
index cfdfa47..0000000
--- a/lib/Fripost/Tests.pm
+++ /dev/null
@@ -1,80 +0,0 @@
-package Fripost::Tests;
-
-use 5.010_000;
-use strict;
-use warnings;
-use utf8;
-
-=head1 NAME
-
-Tests.pm
-
-=cut
-
-our @EXPORT = qw/build_alias_graph search_path/;
-our @ISA = qw(Exporter);
-
-use FindBin qw($Bin);
-use lib "$Bin/lib";
-
-use Fripost::Schema;
-
-sub build_alias_graph {
-    my $graph;
-    foreach (@_) {
-        my $to = $_->{goto};
-        foreach my $from (@{$_->{address}}) {
-            push @{$graph->{$from}}, $to;
-        }
-    }
-
-    return $graph;
-}
-
-
-sub search_path {
-    my ($graph, $from, $to) = @_;
-
-    my @stack;
-    push @stack, [$from];
-
-    while (@stack) {
-        my $path = pop @stack;
-        my $last = @{$path}[$#$path];
-        return @$path if $last eq $to;
-
-        foreach (@{$graph->{$last}}) {
-            push @stack, [@$path,$_];
-        }
-    }
-}
-
-
-
-
-=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.
-
-This program is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
-
-=cut
-
-1; # End of Tests.pm
-
-__END__