PciIds/Users.pm

   1 package PciIds::Users;
   2 use strict;
   3 use warnings;
   4 use base 'Exporter';
   5 use PciIds::Db;
   6 use DBI;
   7 use PciIds::Config;
   8 use Digest::MD5 qw(md5_base64 md5_hex);#TODO Some better algorithm?
   9 use HTML::Entities;
  10 use PciIds::Startup;
  11 use PciIds::Log;
  12 use Apache2::Connection;
  13
  14 my( %privnames, %privnums );
  15
  16 our @EXPORT = qw(&addUser &emailConfirm &checkConfirmHash &saltedPasswd &genAuthToken &checkAuthToken &hasRight &getRightDefs &genResetHash &changePasswd &pushProfile &emailCheck);
  17
  18 sub emailCheck( $$ ) {
  19         my( $email, $tables ) = @_;
  20         my $newmail;
  21         return 'Does not look like an email address' unless ( ( $newmail ) = ( $email =~ /^([^,? "'`;<>]+@[^@,?\/ "'`;<>]+)$/ ) );#make sure the mail is not only reasonable looking, but safe to work with too
  22         return 'Email too long' if length $newmail > 255;
  23         return 'An account for this email address already exists' if( ( defined $tables ) && $tables->hasEmail( $newmail ) );
  24         return ( undef, $newmail );
  25 }
  26
  27 sub saltedPasswd( $$ ) {
  28         my( $email, $passwd ) = @_;
  29         my $salt = $config{'passwdsalt'};
  30         return md5_base64( "$email:$passwd:$salt" );
  31 }
  32
  33 sub genResetHash( $$$$ ) {
  34         my( $id, $email, $login, $passwd ) = @_;
  35         my $salt = $config{'regmailsalt'};
  36         return md5_hex( "$id:$email:$login:$passwd:$salt" );
  37 }
  38
  39 sub emailConfirm( $ ) {
  40         my( $email ) = @_;
  41         my $salt = $config{'regmailsalt'};
  42         return md5_hex( $email.$salt );
  43 }
  44
  45 sub checkConfirmHash( $$ ) {
  46         my( $email, $hash ) = @_;
  47         return 0 unless( ( defined $email ) && ( defined $hash ) );
  48         my( $expected ) = emailConfirm( $email );
  49         return ( $expected eq $hash );
  50 }
  51
  52 sub addUser( $$$$ ) {
  53         my( $tables, $name, $email, $passwd ) = @_;
  54         my $salted = saltedPasswd( $email, $passwd );
  55         tlog( "Creating user $email" . ( ( defined $name ) ? " - $name" : '' ) );
  56         my $id = $tables->addUser( $name, $email, $salted );
  57         tlog( "User ($email) id: $id" );
  58         return $id;
  59 }
  60
  61 sub changePasswd( $$$$ ) {
  62         my( $tables, $id, $passwd, $email ) = @_;
  63         my $salted = saltedPasswd( $email, $passwd );
  64         $tables->changePasswd( $id, $salted );
  65 }
  66
  67 sub genAuthToken( $$$$$ ) {
  68         my( $tables, $id, $req, $rights, $name ) = @_;
  69         unless( defined $rights ) {#Just logged in
  70                 my $from = $req->connection()->remote_ip();
  71                 $tables->setLastLog( $id, $from );
  72                 $rights = $tables->rights( $id );
  73         }
  74         my $haveRights = scalar @{$rights};
  75         my $time = time;
  76         my $ip = $req->connection()->remote_ip();
  77         return "$id:$haveRights:$time:".md5_hex( "$id:$time:$ip:".$config{'authsalt'} ).":$name";
  78 }
  79
  80 sub checkAuthToken( $$$ ) {
  81         my( $tables, $req, $token ) = @_;
  82         my( $id, $haveRights, $time, $hex, $name ) = defined( $token ) ? split( /:/, $token ) : ();
  83         return ( 0, 0, 0, [], "Not logged in", undef ) unless( defined $hex );
  84         my $ip = $req->connection()->remote_ip();
  85         my $expected = md5_hex( "$id:$time:$ip:".$config{'authsalt'} );
  86         my $actTime = time;
  87         my $tokOk = ( $expected eq $hex );
  88         my $authed = ( $tokOk && ( $time + $config{'authtime'} > $actTime ) );
  89         my $regen = $authed && ( $time + $config{'regenauthtime'} < $actTime );
  90         my $rights = [];
  91         if( $haveRights ) {
  92                 foreach( @{$tables->rights( $id )} ) {
  93                         my %r;
  94                         ( $r{'id'} ) = @{$_};
  95                         $r{'name'} = $privnames{$r{'id'}};
  96                         push @{$rights}, \%r;
  97                 }
  98         }
  99         return ( $authed, $id, $regen, $rights, $authed ? undef : ( $tokOk ? "Login timed out" : "Not logged in" ), $name );
 100 }
 101
 102 sub hasRight( $$ ) {
 103         my( $rights, $name ) = @_;
 104         foreach( @{$rights} ) {
 105                 return 1 if( $_->{'name'} eq $name );
 106         }
 107         return 0;
 108 }
 109
 110 sub getRightDefs() {
 111         return ( \%privnums, \%privnames );
 112 }
 113
 114 sub pushProfile( $$$$ ) {
 115         my( $tables, $id, $oldData, $data ) = @_;
 116         my( $email, $passwd ) = ( $data->{'email'}, $data->{'current_password'} );
 117         if( ( defined $passwd ) && ( $passwd ne '' ) ) {
 118                 my $salted = saltedPasswd( $email, $passwd );
 119                 $tables->setEmail( $id, $email, $salted );
 120         }
 121         $data->{'login'} = undef if ( defined $data->{'login'} ) && ( $data->{'login'} eq '' );
 122         $data->{'xmpp'} = undef if ( defined $data->{'xmpp'} ) && ( $data->{'xmpp'} eq '' );
 123         $tables->pushProfile( $id, $data->{'login'}, $data->{'xmpp'}, $data->{'email_time'}, $data->{'xmpp_time'} );
 124         changePasswd( $tables, $id, $data->{'password'}, $email ) if ( defined $data->{'password'} ) && ( $data->{'password'} ne '' );
 125 }
 126
 127 checkConf( [ 'passwdsalt', 'regmailsalt', 'authsalt' ] );
 128 defConf( { 'authtime' => 2100, 'regenauthtime' => 300 } );
 129
 130 open PRIVS, $directory."/rights" or die "Could not open privilege definitions\n";
 131 foreach( <PRIVS> ) {
 132         my( $num, $name ) = /^(\d+)\s+(.*)$/ or die "Invalid syntax in privileges\n";
 133         $privnames{$num} = $name;
 134         $privnums{$name} = $num;
 135 }
 136 close PRIVS;
 137
 138 1;