PciIds/Users.pm

   1 #       PciIds web database
   2 #       Copyright (C) 2008 Michal Vaner (vorner@ucw.cz)
   3 #
   4 #       This program is free software; you can redistribute it and/or modify
   5 #       it under the terms of the GNU General Public License as published by
   6 #       he Free Software Foundation; either version 2 of the License, or
   7 #       (at your option) any later version.
   8 #
   9 #       This program is distributed in the hope that it will be useful,
  10 #       but WITHOUT ANY WARRANTY; without even the implied warranty of
  11 #       MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  12 #
  13 #       GNU General Public License for more details.
  14 #
  15 #       You should have received a copy of the GNU General Public License
  16 #       along with this program; if not, write to the Free Software
  17 #       Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301  USA
  18
  19 package PciIds::Users;
  20 use strict;
  21 use warnings;
  22 use base 'Exporter';
  23 use PciIds::Db;
  24 use DBI;
  25 use PciIds::Config;
  26 use Digest::MD5 qw(md5_base64 md5_hex);#TODO Some better algorithm?
  27 use HTML::Entities;
  28 use PciIds::Startup;
  29 use PciIds::Log;
  30 use Apache2::Connection;
  31
  32 my( %privnames, %privnums );
  33
  34 our @EXPORT = qw(&addUser &emailConfirm &checkConfirmHash &saltedPasswd &genAuthToken &checkAuthToken &hasRight &getRightDefs &genResetHash &changePasswd &pushProfile &emailCheck);
  35
  36 sub emailCheck( $$ ) {
  37         my( $email, $tables ) = @_;
  38         my $newmail;
  39         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
  40         return 'Email too long' if length $newmail > 255;
  41         return 'An account for this email address already exists' if( ( defined $tables ) && $tables->hasEmail( $newmail ) );
  42         return ( undef, $newmail );
  43 }
  44
  45 sub saltedPasswd( $$ ) {
  46         my( $email, $passwd ) = @_;
  47         my $salt = $config{'passwdsalt'};
  48         return md5_base64( "$email:$passwd:$salt" );
  49 }
  50
  51 sub genResetHash( $$$$ ) {
  52         my( $id, $email, $login, $passwd ) = @_;
  53         my $salt = $config{'regmailsalt'};
  54         return md5_hex( "$id:$email:$login:$passwd:$salt" );
  55 }
  56
  57 sub emailConfirm( $ ) {
  58         my( $email ) = @_;
  59         my $salt = $config{'regmailsalt'};
  60         return md5_hex( $email.$salt );
  61 }
  62
  63 sub checkConfirmHash( $$ ) {
  64         my( $email, $hash ) = @_;
  65         return 0 unless( ( defined $email ) && ( defined $hash ) );
  66         my( $expected ) = emailConfirm( $email );
  67         return ( $expected eq $hash );
  68 }
  69
  70 sub addUser( $$$$ ) {
  71         my( $tables, $name, $email, $passwd ) = @_;
  72         my $salted = saltedPasswd( $email, $passwd );
  73         tlog( "Creating user $email" . ( ( defined $name ) ? " - $name" : '' ) );
  74         my $id = $tables->addUser( $name, $email, $salted );
  75         tlog( "User ($email) id: $id" );
  76         return $id;
  77 }
  78
  79 sub changePasswd( $$$$ ) {
  80         my( $tables, $id, $passwd, $email ) = @_;
  81         my $salted = saltedPasswd( $email, $passwd );
  82         $tables->changePasswd( $id, $salted );
  83 }
  84
  85 sub genAuthToken( $$$$$ ) {
  86         my( $tables, $id, $req, $rights, $name ) = @_;
  87         unless( defined $rights ) {#Just logged in
  88                 my $from = $req->connection()->remote_ip();
  89                 $tables->setLastLog( $id, $from );
  90                 $rights = $tables->rights( $id );
  91         }
  92         my $haveRights = scalar @{$rights};
  93         my $time = time;
  94         my $ip = $req->connection()->remote_ip();
  95         return "$id:$haveRights:$time:".md5_hex( "$id:$time:$ip:".$config{'authsalt'} ).":$name";
  96 }
  97
  98 sub checkAuthToken( $$$ ) {
  99         my( $tables, $req, $token ) = @_;
 100         my( $id, $haveRights, $time, $hex, $name ) = defined( $token ) ? split( /:/, $token ) : ();
 101         return ( 0, 0, 0, [], "Not logged in", undef ) unless( defined $hex );
 102         my $ip = $req->connection()->remote_ip();
 103         my $expected = md5_hex( "$id:$time:$ip:".$config{'authsalt'} );
 104         my $actTime = time;
 105         my $tokOk = ( $expected eq $hex );
 106         my $authed = ( $tokOk && ( $time + $config{'authtime'} > $actTime ) );
 107         my $regen = $authed && ( $time + $config{'regenauthtime'} < $actTime );
 108         my $rights = [];
 109         if( $haveRights ) {
 110                 foreach( @{$tables->rights( $id )} ) {
 111                         my %r;
 112                         ( $r{'id'} ) = @{$_};
 113                         $r{'name'} = $privnames{$r{'id'}};
 114                         push @{$rights}, \%r;
 115                 }
 116         }
 117         return ( $authed, $id, $regen, $rights, $authed ? undef : ( $tokOk ? "Login timed out" : "Not logged in" ), $name );
 118 }
 119
 120 sub hasRight( $$ ) {
 121         my( $rights, $name ) = @_;
 122         foreach( @{$rights} ) {
 123                 return 1 if( $_->{'name'} eq $name );
 124         }
 125         return 0;
 126 }
 127
 128 sub getRightDefs() {
 129         return ( \%privnums, \%privnames );
 130 }
 131
 132 sub pushProfile( $$$$ ) {
 133         my( $tables, $id, $oldData, $data ) = @_;
 134         my( $email, $passwd ) = ( $data->{'email'}, $data->{'current_password'} );
 135         if( ( defined $passwd ) && ( $passwd ne '' ) ) {
 136                 my $salted = saltedPasswd( $email, $passwd );
 137                 $tables->setEmail( $id, $email, $salted );
 138         }
 139         $data->{'login'} = undef if ( defined $data->{'login'} ) && ( $data->{'login'} eq '' );
 140         $data->{'xmpp'} = undef if ( defined $data->{'xmpp'} ) && ( $data->{'xmpp'} eq '' );
 141         $tables->pushProfile( $id, $data->{'login'}, $data->{'xmpp'}, $data->{'email_time'}, $data->{'xmpp_time'} );
 142         changePasswd( $tables, $id, $data->{'password'}, $email ) if ( defined $data->{'password'} ) && ( $data->{'password'} ne '' );
 143 }
 144
 145 checkConf( [ 'passwdsalt', 'regmailsalt', 'authsalt' ] );
 146 defConf( { 'authtime' => 2100, 'regenauthtime' => 300 } );
 147
 148 open PRIVS, $directory."/rights" or die "Could not open privilege definitions\n";
 149 foreach( <PRIVS> ) {
 150         my( $num, $name ) = /^(\d+)\s+(.*)$/ or die "Invalid syntax in privileges\n";
 151         $privnames{$num} = $name;
 152         $privnums{$name} = $num;
 153 }
 154 close PRIVS;
 155
 156 1;