aboutsummaryrefslogtreecommitdiffstats
path: root/lib/Fripost
diff options
context:
space:
mode:
Diffstat (limited to 'lib/Fripost')
-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
-rwxr-xr-xlib/Fripost/Prompt.pm106
-rwxr-xr-xlib/Fripost/Tests.pm80
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__