aboutsummaryrefslogtreecommitdiffstats
path: root/lib/Fripost/Commands
diff options
context:
space:
mode:
authorGuilhem Moulin <guilhem.moulin@fripost.org>2012-06-10 15:38:56 +0200
committerGuilhem Moulin <guilhem.moulin@fripost.org>2012-06-10 15:39:26 +0200
commit9508574dcb8c37ff1cb8211e2fe845b2703d9141 (patch)
tree644f3447611c04aea5356373224043d8ad560ed1 /lib/Fripost/Commands
parent05d7924b1c44e85a379b3ff5cca7b512383df769 (diff)
A more modular prompt.
Diffstat (limited to 'lib/Fripost/Commands')
-rw-r--r--lib/Fripost/Commands/add_alias.pm129
-rw-r--r--lib/Fripost/Commands/add_domain.pm88
-rw-r--r--lib/Fripost/Commands/add_user.pm63
-rw-r--r--lib/Fripost/Commands/user_passwd.pm30
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() );