proper self-service login supporting plaintext, crypt and MD5 passwords

5 files changed, 50 insertions, 26 deletions

diff --git a/FS/FS/ClientAPI/MyAccount.pm b/FS/FS/ClientAPI/MyAccount.pm
index 445f0ec..a865a22 100644
--- a/FS/FS/ClientAPI/MyAccount.pm
+++ b/FS/FS/ClientAPI/MyAccount.pm
@@ -44,24 +44,19 @@ my $cache = new Cache::SharedMemoryCache( {
    'namespace' => 'FS::ClientAPI::MyAccount',
 } );
 
-#false laziness w/FS::ClientAPI::passwd::passwd (needs to handle encrypted pw)
+#false laziness w/FS::ClientAPI::passwd::passwd
 sub login {
   my $p = shift;
 
   my $svc_domain = qsearchs('svc_domain', { 'domain' => $p->{'domain'} } )
-    or return { error => "Domain not found" };
-
-  my $svc_acct =
-    ( length($p->{'password'}) < 13
-      && qsearchs( 'svc_acct', { 'username'  => $p->{'username'},
-                                 'domsvc'    => $svc_domain->svcnum,
-                                 '_password' => $p->{'password'}     } )
-    )
-    || qsearchs( 'svc_acct', { 'username'  => $p->{'username'},
-                               'domsvc'    => $svc_domain->svcnum,
-                               '_password' => $p->{'password'}     } );
-
-  unless ( $svc_acct ) { return { error => 'Incorrect password.' } }
+    or return { error => 'Domain '. $p->{'domain'}. ' not found' };
+
+  my $svc_acct = qsearchs( 'svc_acct', { 'username'  => $p->{'username'},
+                                         'domsvc'    => $svc_domain->svcnum, }
+                         );
+  return { error => 'User not found.' } unless $svc_acct;
+  return { error => 'Incorrect password.' }
+    unless $svc_acct->check_password($p->{'password'});
 
   my $session = {
     'svcnum' => $svc_acct->svcnum,
diff --git a/FS/FS/ClientAPI/passwd.pm b/FS/FS/ClientAPI/passwd.pm
index 016ebff..96110ef 100644
--- a/FS/FS/ClientAPI/passwd.pm
+++ b/FS/FS/ClientAPI/passwd.pm
@@ -24,18 +24,14 @@ sub passwd {
   my $new_gecos = $packet->{'new_gecos'};
   my $new_shell = $packet->{'new_shell'};
 
-#false laziness w/FS::ClientAPI::MyAccount::login (needs to handle encrypted pw)
-  my $svc_acct =
-    ( length($old_password) < 13
-      && qsearchs( 'svc_acct', { 'username'  => $packet->{'username'},
-                                 'domsvc'    => $svc_domain->svcnum,
-                                 '_password' => $old_password } )
-    )
-    || qsearchs( 'svc_acct', { 'username'  => $packet->{'username'},
-                               'domsvc'    => $svc_domain->svcnum,
-                               '_password' => $old_password } );
-
-  unless ( $svc_acct ) { return { error => 'Incorrect password.' } }
+  #false laziness w/FS::ClientAPI::MyAccount::login
+
+  my $svc_acct = qsearchs( 'svc_acct', { 'username'  => $packet->{'username'},
+                                         'domsvc'    => $svc_domain->svcnum, }
+                         );
+  return { error => 'User not found.' } unless $svc_acct;
+  return { error => 'Incorrect password.' }
+    unless $svc_acct->check_password($old_password);
 
   my %hash = $svc_acct->hash;
   my $new_svc_acct = new FS::svc_acct ( \%hash );
diff --git a/FS/FS/svc_acct.pm b/FS/FS/svc_acct.pm
index d84240f..991cedd 100644
--- a/FS/FS/svc_acct.pm
+++ b/FS/FS/svc_acct.pm
@@ -14,6 +14,7 @@ use vars qw( @ISA $DEBUG $me $conf
              @saltset @pw_set );
 use Carp;
 use Fcntl qw(:flock);
+use Crypt::PasswdMD5;
 use FS::UID qw( datasrc );
 use FS::Conf;
 use FS::Record qw( qsearch qsearchs fields dbh dbdef );
@@ -1116,6 +1117,36 @@ sub clone_kludge_unsuspend {
   new FS::svc_acct \%hash;
 }
 
+=item check_password 
+
+Checks the supplied password against the (possibly encrypted) password in the
+database.  Returns true for a sucessful authentication, false for no match.
+
+Currently supported encryptions are: classic DES crypt() and MD5
+
+=cut
+
+sub check_password {
+  my($self, $check_password) = @_;
+  #eventually should check a "password-encoding" field
+  if ( length($self->_password) < 13 ) { #plaintext
+    $check_password eq $self->_password;
+  } elsif ( length($self->_password) == 13 ) { #traditional DES crypt
+    crypt($check_password, $self->_password) eq $self->_password;
+  } elsif ( $self->_password =~ /^\$1\$/ ) { #MD5 crypt
+    unix_md5_crypt($check_password, $self->_password) eq $self->_password;
+  } elsif ( $self->_password =~ /^\$2a?\$/ ) { #Blowfish
+    warn "Can't check password: Blowfish encryption not yet supported, svcnum".
+         $self->svcnum. "\n";
+    0;
+  } else {
+    warn "Can't check password: Unrecognized encryption for svcnum ".
+         $self->svcnum. "\n";
+    0;
+  }
+
+}
+
 =back
 
 =head1 SUBROUTINES
diff --git a/httemplate/docs/install.html b/httemplate/docs/install.html
index ed306f2..0217c90 100644
--- a/httemplate/docs/install.html
+++ b/httemplate/docs/install.html
@@ -56,6 +56,7 @@ Before installing, you need:
 <!-- MyAccounts, maybe only for dev     <li><a href="http://search.cpan.org/search?dist=Cache-Cache">Cache::Cache</a> -->
       <li><a href="http://search.cpan.org/search?dist=NetAddr-IP">NetAddr-IP</a>
       <li><a href="http://search.cpan.org/search?dist=Chart">Chart</a>
+      <li><a href="http://search.cpan.org/search?dist=Crypt-PasswdMD5">Crypt::PasswdMD5</a>
       <li><a href="http://search.cpan.org/search?dist=ApacheDBI">Apache::DBI</a> <i>(optional but recommended for better webinterface performance)</i>
     </ul>
 </ul>
diff --git a/httemplate/docs/upgrade-1.4.2.html b/httemplate/docs/upgrade-1.4.2.html
index 3c9ac9c..b8c5fcf 100644
--- a/httemplate/docs/upgrade-1.4.2.html
+++ b/httemplate/docs/upgrade-1.4.2.html
@@ -13,6 +13,7 @@
   <li>Install <a href="http://search.cpan.org/search?dist=DBD-Pg">DBD::Pg</a> 1.32.
   <li>Install <a href="http://search.cpan.org/search?dist=Cache-Cache">Cache::Cache</a>.
   <li>Install <a href="http://search.cpan.org/search?dist=Net-SSH">Net::SSH</a> 0.08.
+  <li>Install <a href="http://search.cpan.org/search?dist=Crypt-PasswdMD5">Crypt::PasswdMD5</a>
   <li>CGI.pm minimum version 2.47 is required.  You will probably need to install a current CGI.pm from CPAN if you are using Perl 5.005 or earlier.
   <li>If using Apache::ASP, add <code>PerlSetVar RequestBinaryRead Off</code> to your Apache configuration and make sure you are using Apache::ASP minimum version 2.55.
   <li>Run <code>make aspdocs</code> or <code>make masondocs</code>.