diff options
Diffstat (limited to 'lib/Fripost')
| -rw-r--r-- | lib/Fripost/Commands/add_alias.pm | 129 | ||||
| -rw-r--r-- | lib/Fripost/Commands/add_domain.pm | 88 | ||||
| -rw-r--r-- | lib/Fripost/Commands/add_user.pm | 63 | ||||
| -rw-r--r-- | lib/Fripost/Commands/user_passwd.pm | 30 | ||||
| -rwxr-xr-x | lib/Fripost/Prompt.pm | 106 | ||||
| -rwxr-xr-x | lib/Fripost/Tests.pm | 80 |
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__ |