A more modular prompt.

4 files changed, 146 insertions, 164 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() );