SL/Auth.pm

   1 package SL::Auth;
   2
   3 use DBI;
   4
   5 use Digest::MD5 qw(md5_hex);
   6 use IO::File;
   7 use Time::HiRes qw(gettimeofday);
   8 use List::MoreUtils qw(uniq);
   9 use YAML;
  10
  11 use SL::Auth::Constants qw(:all);
  12 use SL::Auth::DB;
  13 use SL::Auth::LDAP;
  14 use SL::Auth::Password;
  15
  16 use SL::SessionFile;
  17 use SL::User;
  18 use SL::DBConnect;
  19 use SL::DBUpgrade2;
  20 use SL::DBUtils;
  21
  22 use strict;
  23
  24 sub new {
  25   $main::lxdebug->enter_sub();
  26
  27   my $type = shift;
  28   my $self = {};
  29
  30   bless $self, $type;
  31
  32   $self->{SESSION} = { };
  33
  34   $self->_read_auth_config();
  35
  36   $main::lxdebug->leave_sub();
  37
  38   return $self;
  39 }
  40
  41 sub reset {
  42   my ($self, %params) = @_;
  43
  44   $self->{SESSION}          = { };
  45   $self->{FULL_RIGHTS}      = { };
  46   $self->{RIGHTS}           = { };
  47   $self->{unique_counter}   = 0;
  48 }
  49
  50 sub get_user_dbh {
  51   my ($self, $login, %params) = @_;
  52   my $may_fail = delete $params{may_fail};
  53
  54   my %user = $self->read_user($login);
  55   my $dbh  = SL::DBConnect->connect(
  56     $user{dbconnect},
  57     $user{dbuser},
  58     $user{dbpasswd},
  59     {
  60       pg_enable_utf8 => $::locale->is_utf8,
  61       AutoCommit     => 0
  62     }
  63   );
  64
  65   if (!$may_fail && !$dbh) {
  66     $::form->error($::locale->text('The connection to the authentication database failed:') . "\n" . $DBI::errstr);
  67   }
  68
  69   if ($user{dboptions} && $dbh) {
  70     $dbh->do($user{dboptions}) or $::form->dberror($user{dboptions});
  71   }
  72
  73   return $dbh;
  74 }
  75
  76 sub DESTROY {
  77   my $self = shift;
  78
  79   $self->{dbh}->disconnect() if ($self->{dbh});
  80 }
  81
  82 # form isn't loaded yet, so auth needs it's own error.
  83 sub mini_error {
  84   $::lxdebug->show_backtrace();
  85
  86   my ($self, @msg) = @_;
  87   if ($ENV{HTTP_USER_AGENT}) {
  88     print Form->create_http_response(content_type => 'text/html');
  89     print "<pre>", join ('<br>', @msg), "</pre>";
  90   } else {
  91     print STDERR "Error: @msg\n";
  92   }
  93   ::end_of_request();
  94 }
  95
  96 sub _read_auth_config {
  97   $main::lxdebug->enter_sub();
  98
  99   my $self = shift;
 100
 101   map { $self->{$_} = $::lx_office_conf{authentication}->{$_} } keys %{ $::lx_office_conf{authentication} };
 102   $self->{DB_config}   = $::lx_office_conf{'authentication/database'};
 103   $self->{LDAP_config} = $::lx_office_conf{'authentication/ldap'};
 104
 105   if ($self->{module} eq 'DB') {
 106     $self->{authenticator} = SL::Auth::DB->new($self);
 107
 108   } elsif ($self->{module} eq 'LDAP') {
 109     $self->{authenticator} = SL::Auth::LDAP->new($self);
 110   }
 111
 112   if (!$self->{authenticator}) {
 113     my $locale = Locale->new('en');
 114     $self->mini_error($locale->text('No or an unknown authenticantion module specified in "config/lx_office.conf".'));
 115   }
 116
 117   my $cfg = $self->{DB_config};
 118
 119   if (!$cfg) {
 120     my $locale = Locale->new('en');
 121     $self->mini_error($locale->text('config/lx_office.conf: Key "DB_config" is missing.'));
 122   }
 123
 124   if (!$cfg->{host} || !$cfg->{db} || !$cfg->{user}) {
 125     my $locale = Locale->new('en');
 126     $self->mini_error($locale->text('config/lx_office.conf: Missing parameters in "authentication/database". Required parameters are "host", "db" and "user".'));
 127   }
 128
 129   $self->{authenticator}->verify_config();
 130
 131   $self->{session_timeout} *= 1;
 132   $self->{session_timeout}  = 8 * 60 if (!$self->{session_timeout});
 133
 134   $main::lxdebug->leave_sub();
 135 }
 136
 137 sub authenticate_root {
 138   $main::lxdebug->enter_sub();
 139
 140   my ($self, $password) = @_;
 141
 142   $password             = SL::Auth::Password->hash_if_unhashed(login => 'root', password => $password);
 143   my $admin_password    = SL::Auth::Password->hash_if_unhashed(login => 'root', password => $self->{admin_password});
 144
 145   $main::lxdebug->leave_sub();
 146
 147   return OK if $password eq $admin_password;
 148   sleep 5;
 149   return ERR_PASSWORD;
 150 }
 151
 152 sub authenticate {
 153   $main::lxdebug->enter_sub();
 154
 155   my ($self, $login, $password) = @_;
 156
 157   $main::lxdebug->leave_sub();
 158
 159   my $result = $login ? $self->{authenticator}->authenticate($login, $password) : ERR_USER;
 160   return OK if $result eq OK;
 161   sleep 5;
 162   return $result;
 163 }
 164
 165 sub store_credentials_in_session {
 166   my ($self, %params) = @_;
 167
 168   $params{password} = SL::Auth::Password->hash_if_unhashed(login => $params{login}, password => $params{password})
 169     unless $self->{authenticator}->requires_cleartext_password;
 170
 171   $self->set_session_value(login => $params{login}, password => $params{password});
 172 }
 173
 174 sub store_root_credentials_in_session {
 175   my ($self, $rpw) = @_;
 176
 177   $self->set_session_value(rpw => SL::Auth::Password->hash_if_unhashed(login => 'root', password => $rpw));
 178 }
 179
 180 sub dbconnect {
 181   $main::lxdebug->enter_sub(2);
 182
 183   my $self     = shift;
 184   my $may_fail = shift;
 185
 186   if ($self->{dbh}) {
 187     $main::lxdebug->leave_sub(2);
 188     return $self->{dbh};
 189   }
 190
 191   my $cfg = $self->{DB_config};
 192   my $dsn = 'dbi:Pg:dbname=' . $cfg->{db} . ';host=' . $cfg->{host};
 193
 194   if ($cfg->{port}) {
 195     $dsn .= ';port=' . $cfg->{port};
 196   }
 197
 198   $main::lxdebug->message(LXDebug->DEBUG1, "Auth::dbconnect DSN: $dsn");
 199
 200   $self->{dbh} = SL::DBConnect->connect($dsn, $cfg->{user}, $cfg->{password}, { pg_enable_utf8 => $::locale->is_utf8, AutoCommit => 1 });
 201
 202   if (!$may_fail && !$self->{dbh}) {
 203     $main::form->error($main::locale->text('The connection to the authentication database failed:') . "\n" . $DBI::errstr);
 204   }
 205
 206   $main::lxdebug->leave_sub(2);
 207
 208   return $self->{dbh};
 209 }
 210
 211 sub dbdisconnect {
 212   $main::lxdebug->enter_sub();
 213
 214   my $self = shift;
 215
 216   if ($self->{dbh}) {
 217     $self->{dbh}->disconnect();
 218     delete $self->{dbh};
 219   }
 220
 221   $main::lxdebug->leave_sub();
 222 }
 223
 224 sub check_tables {
 225   $main::lxdebug->enter_sub();
 226
 227   my $self    = shift;
 228
 229   my $dbh     = $self->dbconnect();
 230   my $query   = qq|SELECT COUNT(*) FROM pg_tables WHERE (schemaname = 'auth') AND (tablename = 'user')|;
 231
 232   my ($count) = $dbh->selectrow_array($query);
 233
 234   $main::lxdebug->leave_sub();
 235
 236   return $count > 0;
 237 }
 238
 239 sub check_database {
 240   $main::lxdebug->enter_sub();
 241
 242   my $self = shift;
 243
 244   my $dbh  = $self->dbconnect(1);
 245
 246   $main::lxdebug->leave_sub();
 247
 248   return $dbh ? 1 : 0;
 249 }
 250
 251 sub create_database {
 252   $main::lxdebug->enter_sub();
 253
 254   my $self   = shift;
 255   my %params = @_;
 256
 257   my $cfg    = $self->{DB_config};
 258
 259   if (!$params{superuser}) {
 260     $params{superuser}          = $cfg->{user};
 261     $params{superuser_password} = $cfg->{password};
 262   }
 263
 264   $params{template} ||= 'template0';
 265   $params{template}   =~ s|[^a-zA-Z0-9_\-]||g;
 266
 267   my $dsn = 'dbi:Pg:dbname=template1;host=' . $cfg->{host};
 268
 269   if ($cfg->{port}) {
 270     $dsn .= ';port=' . $cfg->{port};
 271   }
 272
 273   $main::lxdebug->message(LXDebug->DEBUG1(), "Auth::create_database DSN: $dsn");
 274
 275   my $charset    = $::lx_office_conf{system}->{dbcharset};
 276   $charset     ||= Common::DEFAULT_CHARSET;
 277   my $encoding   = $Common::charset_to_db_encoding{$charset};
 278   $encoding    ||= 'UNICODE';
 279
 280   my $dbh        = SL::DBConnect->connect($dsn, $params{superuser}, $params{superuser_password}, { pg_enable_utf8 => scalar($charset =~ m/^utf-?8$/i) });
 281
 282   if (!$dbh) {
 283     $main::form->error($main::locale->text('The connection to the template database failed:') . "\n" . $DBI::errstr);
 284   }
 285
 286   my $query = qq|CREATE DATABASE "$cfg->{db}" OWNER "$cfg->{user}" TEMPLATE "$params{template}" ENCODING '$encoding'|;
 287
 288   $main::lxdebug->message(LXDebug->DEBUG1(), "Auth::create_database query: $query");
 289
 290   $dbh->do($query);
 291
 292   if ($dbh->err) {
 293     my $error = $dbh->errstr();
 294
 295     $query                 = qq|SELECT pg_encoding_to_char(encoding) FROM pg_database WHERE datname = 'template0'|;
 296     my ($cluster_encoding) = $dbh->selectrow_array($query);
 297
 298     if ($cluster_encoding && ($cluster_encoding =~ m/^(?:UTF-?8|UNICODE)$/i) && ($encoding !~ m/^(?:UTF-?8|UNICODE)$/i)) {
 299       $error = $main::locale->text('Your PostgreSQL installationen uses UTF-8 as its encoding. Therefore you have to configure Lx-Office to use UTF-8 as well.');
 300     }
 301
 302     $dbh->disconnect();
 303
 304     $main::form->error($main::locale->text('The creation of the authentication database failed:') . "\n" . $error);
 305   }
 306
 307   $dbh->disconnect();
 308
 309   $main::lxdebug->leave_sub();
 310 }
 311
 312 sub create_tables {
 313   $main::lxdebug->enter_sub();
 314
 315   my $self = shift;
 316   my $dbh  = $self->dbconnect();
 317
 318   my $charset    = $::lx_office_conf{system}->{dbcharset};
 319   $charset     ||= Common::DEFAULT_CHARSET;
 320
 321   $dbh->rollback();
 322   SL::DBUpgrade2->new(form => $::form)->process_query($dbh, 'sql/auth_db.sql', undef, $charset);
 323
 324   $main::lxdebug->leave_sub();
 325 }
 326
 327 sub save_user {
 328   $main::lxdebug->enter_sub();
 329
 330   my $self   = shift;
 331   my $login  = shift;
 332   my %params = @_;
 333
 334   my $form   = $main::form;
 335
 336   my $dbh    = $self->dbconnect();
 337
 338   my ($sth, $query, $user_id);
 339
 340   $dbh->begin_work;
 341
 342   $query     = qq|SELECT id FROM auth."user" WHERE login = ?|;
 343   ($user_id) = selectrow_query($form, $dbh, $query, $login);
 344
 345   if (!$user_id) {
 346     $query     = qq|SELECT nextval('auth.user_id_seq')|;
 347     ($user_id) = selectrow_query($form, $dbh, $query);
 348
 349     $query     = qq|INSERT INTO auth."user" (id, login) VALUES (?, ?)|;
 350     do_query($form, $dbh, $query, $user_id, $login);
 351   }
 352
 353   $query = qq|DELETE FROM auth.user_config WHERE (user_id = ?)|;
 354   do_query($form, $dbh, $query, $user_id);
 355
 356   $query = qq|INSERT INTO auth.user_config (user_id, cfg_key, cfg_value) VALUES (?, ?, ?)|;
 357   $sth   = prepare_query($form, $dbh, $query);
 358
 359   while (my ($cfg_key, $cfg_value) = each %params) {
 360     next if ($cfg_key eq 'password');
 361
 362     do_statement($form, $sth, $query, $user_id, $cfg_key, $cfg_value);
 363   }
 364
 365   $dbh->commit();
 366
 367   $main::lxdebug->leave_sub();
 368 }
 369
 370 sub can_change_password {
 371   my $self = shift;
 372
 373   return $self->{authenticator}->can_change_password();
 374 }
 375
 376 sub change_password {
 377   $main::lxdebug->enter_sub();
 378
 379   my $self   = shift;
 380   my $result = $self->{authenticator}->change_password(@_);
 381
 382   $main::lxdebug->leave_sub();
 383
 384   return $result;
 385 }
 386
 387 sub read_all_users {
 388   $main::lxdebug->enter_sub();
 389
 390   my $self  = shift;
 391
 392   my $dbh   = $self->dbconnect();
 393   my $query = qq|SELECT u.id, u.login, cfg.cfg_key, cfg.cfg_value
 394                  FROM auth.user_config cfg
 395                  LEFT JOIN auth."user" u ON (cfg.user_id = u.id)|;
 396   my $sth   = prepare_execute_query($main::form, $dbh, $query);
 397
 398   my %users;
 399
 400   while (my $ref = $sth->fetchrow_hashref()) {
 401     $users{$ref->{login}}                    ||= { 'login' => $ref->{login}, 'id' => $ref->{id} };
 402     $users{$ref->{login}}->{$ref->{cfg_key}}   = $ref->{cfg_value} if (($ref->{cfg_key} ne 'login') && ($ref->{cfg_key} ne 'id'));
 403   }
 404
 405   $sth->finish();
 406
 407   $main::lxdebug->leave_sub();
 408
 409   return %users;
 410 }
 411
 412 sub read_user {
 413   $main::lxdebug->enter_sub();
 414
 415   my $self  = shift;
 416   my $login = shift;
 417
 418   my $dbh   = $self->dbconnect();
 419   my $query = qq|SELECT u.id, u.login, cfg.cfg_key, cfg.cfg_value
 420                  FROM auth.user_config cfg
 421                  LEFT JOIN auth."user" u ON (cfg.user_id = u.id)
 422                  WHERE (u.login = ?)|;
 423   my $sth   = prepare_execute_query($main::form, $dbh, $query, $login);
 424
 425   my %user_data;
 426
 427   while (my $ref = $sth->fetchrow_hashref()) {
 428     $user_data{$ref->{cfg_key}} = $ref->{cfg_value};
 429     @user_data{qw(id login)}    = @{$ref}{qw(id login)};
 430   }
 431
 432   $sth->finish();
 433
 434   $main::lxdebug->leave_sub();
 435
 436   return %user_data;
 437 }
 438
 439 sub get_user_id {
 440   $main::lxdebug->enter_sub();
 441
 442   my $self  = shift;
 443   my $login = shift;
 444
 445   my $dbh   = $self->dbconnect();
 446   my ($id)  = selectrow_query($main::form, $dbh, qq|SELECT id FROM auth."user" WHERE login = ?|, $login);
 447
 448   $main::lxdebug->leave_sub();
 449
 450   return $id;
 451 }
 452
 453 sub delete_user {
 454   $::lxdebug->enter_sub;
 455
 456   my $self  = shift;
 457   my $login = shift;
 458
 459   my $u_dbh = $self->get_user_dbh($login, may_fail => 1);
 460   my $dbh   = $self->dbconnect;
 461
 462   $dbh->begin_work;
 463
 464   my $query = qq|SELECT id FROM auth."user" WHERE login = ?|;
 465
 466   my ($id)  = selectrow_query($::form, $dbh, $query, $login);
 467
 468   $dbh->rollback and return $::lxdebug->leave_sub if (!$id);
 469
 470   do_query($::form, $dbh, qq|DELETE FROM auth.user_group WHERE user_id = ?|, $id);
 471   do_query($::form, $dbh, qq|DELETE FROM auth.user_config WHERE user_id = ?|, $id);
 472   do_query($::form, $u_dbh, qq|UPDATE employee SET deleted = 't' WHERE login = ?|, $login) if $u_dbh;
 473
 474   $dbh->commit;
 475   $u_dbh->commit if $u_dbh;
 476
 477   $::lxdebug->leave_sub;
 478 }
 479
 480 # --------------------------------------
 481
 482 my $session_id;
 483
 484 sub restore_session {
 485   $main::lxdebug->enter_sub();
 486
 487   my $self = shift;
 488
 489   my $cgi            =  $main::cgi;
 490   $cgi             ||=  CGI->new('');
 491
 492   $session_id        =  $cgi->cookie($self->get_session_cookie_name());
 493   $session_id        =~ s|[^0-9a-f]||g;
 494
 495   $self->{SESSION}   = { };
 496
 497   if (!$session_id) {
 498     $main::lxdebug->leave_sub();
 499     return SESSION_NONE;
 500   }
 501
 502   my ($dbh, $query, $sth, $cookie, $ref, $form);
 503
 504   $form   = $main::form;
 505
 506   $dbh    = $self->dbconnect();
 507   $query  = qq|SELECT *, (mtime < (now() - '$self->{session_timeout}m'::interval)) AS is_expired FROM auth.session WHERE id = ?|;
 508
 509   $cookie = selectfirst_hashref_query($form, $dbh, $query, $session_id);
 510
 511   if (!$cookie || $cookie->{is_expired} || ($cookie->{ip_address} ne $ENV{REMOTE_ADDR})) {
 512     $self->destroy_session();
 513     $main::lxdebug->leave_sub();
 514     return $cookie ? SESSION_EXPIRED : SESSION_NONE;
 515   }
 516
 517   $query = qq|SELECT sess_key, sess_value FROM auth.session_content WHERE session_id = ?|;
 518   $sth   = prepare_execute_query($form, $dbh, $query, $session_id);
 519
 520   while (my $ref = $sth->fetchrow_hashref()) {
 521     $self->{SESSION}->{$ref->{sess_key}} = $ref->{sess_value};
 522     next if defined $form->{$ref->{sess_key}};
 523
 524     my $params                = $self->_load_value($ref->{sess_value});
 525     $form->{$ref->{sess_key}} = $params->{data} if $params->{auto_restore} || $params->{simple};
 526   }
 527
 528   $sth->finish();
 529
 530   $main::lxdebug->leave_sub();
 531
 532   return SESSION_OK;
 533 }
 534
 535 sub _load_value {
 536   my ($self, $value) = @_;
 537
 538   return { simple => 1, data => $value } if $value !~ m/^---/;
 539
 540   my %params = ( simple => 1 );
 541   eval {
 542     my $data = YAML::Load($value);
 543
 544     if (ref $data eq 'HASH') {
 545       map { $params{$_} = $data->{$_} } keys %{ $data };
 546       $params{simple} = 0;
 547
 548     } else {
 549       $params{data}   = $data;
 550     }
 551
 552     1;
 553   } or $params{data} = $value;
 554
 555   return \%params;
 556 }
 557
 558 sub destroy_session {
 559   $main::lxdebug->enter_sub();
 560
 561   my $self = shift;
 562
 563   if ($session_id) {
 564     my $dbh = $self->dbconnect();
 565
 566     $dbh->begin_work;
 567
 568     do_query($main::form, $dbh, qq|DELETE FROM auth.session_content WHERE session_id = ?|, $session_id);
 569     do_query($main::form, $dbh, qq|DELETE FROM auth.session WHERE id = ?|, $session_id);
 570
 571     $dbh->commit();
 572
 573     SL::SessionFile->destroy_session($session_id);
 574
 575     $session_id      = undef;
 576     $self->{SESSION} = { };
 577   }
 578
 579   $main::lxdebug->leave_sub();
 580 }
 581
 582 sub expire_sessions {
 583   $main::lxdebug->enter_sub();
 584
 585   my $self  = shift;
 586
 587   $main::lxdebug->leave_sub and return if !$self->session_tables_present;
 588
 589   my $dbh   = $self->dbconnect();
 590
 591   my $query = qq|SELECT id
 592                  FROM auth.session
 593                  WHERE (mtime < (now() - '$self->{session_timeout}m'::interval))|;
 594
 595   my @ids   = selectall_array_query($::form, $dbh, $query);
 596
 597   if (@ids) {
 598     $dbh->begin_work;
 599
 600     SL::SessionFile->destroy_session($_) for @ids;
 601
 602     $query = qq|DELETE FROM auth.session_content
 603                 WHERE session_id IN (| . join(', ', ('?') x scalar(@ids)) . qq|)|;
 604     do_query($main::form, $dbh, $query, @ids);
 605
 606     $query = qq|DELETE FROM auth.session
 607                 WHERE id IN (| . join(', ', ('?') x scalar(@ids)) . qq|)|;
 608     do_query($main::form, $dbh, $query, @ids);
 609
 610     $dbh->commit();
 611   }
 612
 613   $main::lxdebug->leave_sub();
 614 }
 615
 616 sub _create_session_id {
 617   $main::lxdebug->enter_sub();
 618
 619   my @data;
 620   map { push @data, int(rand() * 255); } (1..32);
 621
 622   my $id = md5_hex(pack 'C*', @data);
 623
 624   $main::lxdebug->leave_sub();
 625
 626   return $id;
 627 }
 628
 629 sub create_or_refresh_session {
 630   $session_id ||= shift->_create_session_id;
 631 }
 632
 633 sub save_session {
 634   $::lxdebug->enter_sub;
 635   my $self         = shift;
 636   my $provided_dbh = shift;
 637
 638   my $dbh          = $provided_dbh || $self->dbconnect(1);
 639
 640   $::lxdebug->leave_sub && return unless $dbh && $session_id;
 641
 642   $dbh->begin_work unless $provided_dbh;
 643
 644   do_query($::form, $dbh, qq|LOCK auth.session_content|);
 645   do_query($::form, $dbh, qq|DELETE FROM auth.session_content WHERE session_id = ?|, $session_id);
 646
 647   my $query = qq|SELECT id FROM auth.session WHERE id = ?|;
 648
 649   my ($id)  = selectrow_query($::form, $dbh, $query, $session_id);
 650
 651   if ($id) {
 652     do_query($::form, $dbh, qq|UPDATE auth.session SET mtime = now() WHERE id = ?|, $session_id);
 653   } else {
 654     do_query($::form, $dbh, qq|INSERT INTO auth.session (id, ip_address, mtime) VALUES (?, ?, now())|, $session_id, $ENV{REMOTE_ADDR});
 655   }
 656
 657   if (%{ $self->{SESSION} }) {
 658     my $query = qq|INSERT INTO auth.session_content (session_id, sess_key, sess_value) VALUES (?, ?, ?)|;
 659     my $sth   = prepare_query($::form, $dbh, $query);
 660
 661     foreach my $key (sort keys %{ $self->{SESSION} }) {
 662       do_statement($::form, $sth, $query, $session_id, $key, $self->{SESSION}->{$key});
 663     }
 664
 665     $sth->finish();
 666   }
 667
 668   $dbh->commit() unless $provided_dbh;
 669   $::lxdebug->leave_sub;
 670 }
 671
 672 sub set_session_value {
 673   $main::lxdebug->enter_sub();
 674
 675   my $self   = shift;
 676   my %params = @_;
 677
 678   $self->{SESSION} ||= { };
 679
 680   while (my ($key, $value) = each %params) {
 681     $self->{SESSION}->{ $key } = YAML::Dump(ref($value) eq 'HASH' ? { data => $value } : $value);
 682   }
 683
 684   $main::lxdebug->leave_sub();
 685
 686   return $self;
 687 }
 688
 689 sub delete_session_value {
 690   $main::lxdebug->enter_sub();
 691
 692   my $self = shift;
 693
 694   $self->{SESSION} ||= { };
 695   delete @{ $self->{SESSION} }{ @_ };
 696
 697   $main::lxdebug->leave_sub();
 698
 699   return $self;
 700 }
 701
 702 sub get_session_value {
 703   $main::lxdebug->enter_sub();
 704
 705   my $self   = shift;
 706   my $params = $self->{SESSION} ? $self->_load_value($self->{SESSION}->{ $_[0] }) : {};
 707
 708   $main::lxdebug->leave_sub();
 709
 710   return $params->{data};
 711 }
 712
 713 sub create_unique_sesion_value {
 714   my ($self, $value, %params) = @_;
 715
 716   $self->{SESSION} ||= { };
 717
 718   my @now                   = gettimeofday();
 719   my $key                   = "$$-" . ($now[0] * 1000000 + $now[1]) . "-";
 720   $self->{unique_counter} ||= 0;
 721
 722   $self->{unique_counter}++ while exists $self->{SESSION}->{$key . $self->{unique_counter}};
 723   $self->{unique_counter}++;
 724
 725   $value  = { expiration => $params{expiration} ? ($now[0] + $params{expiration}) * 1000000 + $now[1] : undef,
 726               data       => $value,
 727             };
 728
 729   $self->{SESSION}->{$key . $self->{unique_counter}} = YAML::Dump($value);
 730
 731   return $key . $self->{unique_counter};
 732 }
 733
 734 sub save_form_in_session {
 735   my ($self, %params) = @_;
 736
 737   my $form        = delete($params{form}) || $::form;
 738   my $non_scalars = delete $params{non_scalars};
 739   my $data        = {};
 740
 741   my %skip_keys   = map { ( $_ => 1 ) } (qw(login password stylesheet version titlebar), @{ $params{skip_keys} || [] });
 742
 743   foreach my $key (grep { !$skip_keys{$_} } keys %{ $form }) {
 744     $data->{$key} = $form->{$key} if !ref($form->{$key}) || $non_scalars;
 745   }
 746
 747   return $self->create_unique_sesion_value($data, %params);
 748 }
 749
 750 sub restore_form_from_session {
 751   my ($self, $key, %params) = @_;
 752
 753   my $data = $self->get_session_value($key);
 754   return $self unless $data;
 755
 756   my $form    = delete($params{form}) || $::form;
 757   my $clobber = exists $params{clobber} ? $params{clobber} : 1;
 758
 759   map { $form->{$_} = $data->{$_} if $clobber || !exists $form->{$_} } keys %{ $data };
 760
 761   return $self;
 762 }
 763
 764 sub expire_session_keys {
 765   my ($self) = @_;
 766
 767   $self->{SESSION} ||= { };
 768
 769   my @now = gettimeofday();
 770   my $now = $now[0] * 1000000 + $now[1];
 771
 772   $self->delete_session_value(map  { $_->[0]                                                 }
 773                               grep { $_->[1]->{expiration} && ($now > $_->[1]->{expiration}) }
 774                               map  { [ $_, $self->_load_value($self->{SESSION}->{$_}) ]      }
 775                               keys %{ $self->{SESSION} });
 776
 777   return $self;
 778 }
 779
 780 sub _has_expiration {
 781   my ($value) = @_;
 782   return (ref $value eq 'HASH') && exists($value->{expiration}) && $value->{data};
 783 }
 784
 785 sub set_cookie_environment_variable {
 786   my $self = shift;
 787   $ENV{HTTP_COOKIE} = $self->get_session_cookie_name() . "=${session_id}";
 788 }
 789
 790 sub get_session_cookie_name {
 791   my $self = shift;
 792
 793   return $self->{cookie_name} || 'lx_office_erp_session_id';
 794 }
 795
 796 sub get_session_id {
 797   return $session_id;
 798 }
 799
 800 sub session_tables_present {
 801   $main::lxdebug->enter_sub();
 802
 803   my $self = shift;
 804
 805   # Only re-check for the presence of auth tables if either the check
 806   # hasn't been done before of if they weren't present.
 807   if ($self->{session_tables_present}) {
 808     $main::lxdebug->leave_sub();
 809     return $self->{session_tables_present};
 810   }
 811
 812   my $dbh  = $self->dbconnect(1);
 813
 814   if (!$dbh) {
 815     $main::lxdebug->leave_sub();
 816     return 0;
 817   }
 818
 819   my $query =
 820     qq|SELECT COUNT(*)
 821        FROM pg_tables
 822        WHERE (schemaname = 'auth')
 823          AND (tablename IN ('session', 'session_content'))|;
 824
 825   my ($count) = selectrow_query($main::form, $dbh, $query);
 826
 827   $self->{session_tables_present} = 2 == $count;
 828
 829   $main::lxdebug->leave_sub();
 830
 831   return $self->{session_tables_present};
 832 }
 833
 834 # --------------------------------------
 835
 836 sub all_rights_full {
 837   my $locale = $main::locale;
 838
 839   my @all_rights = (
 840     ["--crm",                          $locale->text("CRM optional software")],
 841     ["crm_search",                     $locale->text("CRM search")],
 842     ["crm_new",                        $locale->text("CRM create customers, vendors and contacts")],
 843     ["crm_service",                    $locale->text("CRM services")],
 844     ["crm_admin",                      $locale->text("CRM admin")],
 845     ["crm_adminuser",                  $locale->text("CRM user")],
 846     ["crm_adminstatus",                $locale->text("CRM status")],
 847     ["crm_email",                      $locale->text("CRM send email")],
 848     ["crm_termin",                     $locale->text("CRM termin")],
 849     ["crm_opportunity",                $locale->text("CRM opportunity")],
 850     ["crm_knowhow",                    $locale->text("CRM know how")],
 851     ["crm_follow",                     $locale->text("CRM follow up")],
 852     ["crm_notices",                    $locale->text("CRM notices")],
 853     ["crm_other",                      $locale->text("CRM other")],
 854     ["--master_data",                  $locale->text("Master Data")],
 855     ["customer_vendor_edit",           $locale->text("Create and edit customers and vendors")],
 856     ["part_service_assembly_edit",     $locale->text("Create and edit parts, services, assemblies")],
 857     ["project_edit",                   $locale->text("Create and edit projects")],
 858     ["--ar",                           $locale->text("AR")],
 859     ["sales_quotation_edit",           $locale->text("Create and edit sales quotations")],
 860     ["sales_order_edit",               $locale->text("Create and edit sales orders")],
 861     ["sales_delivery_order_edit",      $locale->text("Create and edit sales delivery orders")],
 862     ["invoice_edit",                   $locale->text("Create and edit invoices and credit notes")],
 863     ["dunning_edit",                   $locale->text("Create and edit dunnings")],
 864     ["sales_all_edit",                 $locale->text("View/edit all employees sales documents")],
 865     ["--ap",                           $locale->text("AP")],
 866     ["request_quotation_edit",         $locale->text("Create and edit RFQs")],
 867     ["purchase_order_edit",            $locale->text("Create and edit purchase orders")],
 868     ["purchase_delivery_order_edit",   $locale->text("Create and edit purchase delivery orders")],
 869     ["vendor_invoice_edit",            $locale->text("Create and edit vendor invoices")],
 870     ["--warehouse_management",         $locale->text("Warehouse management")],
 871     ["warehouse_contents",             $locale->text("View warehouse content")],
 872     ["warehouse_management",           $locale->text("Warehouse management")],
 873     ["--general_ledger_cash",          $locale->text("General ledger and cash")],
 874     ["general_ledger",                 $locale->text("Transactions, AR transactions, AP transactions")],
 875     ["datev_export",                   $locale->text("DATEV Export")],
 876     ["cash",                           $locale->text("Receipt, payment, reconciliation")],
 877     ["--reports",                      $locale->text('Reports')],
 878     ["report",                         $locale->text('All reports')],
 879     ["advance_turnover_tax_return",    $locale->text('Advance turnover tax return')],
 880     ["--batch_printing",               $locale->text("Batch Printing")],
 881     ["batch_printing",                 $locale->text("Batch Printing")],
 882     ["--others",                       $locale->text("Others")],
 883     ["email_bcc",                      $locale->text("May set the BCC field when sending emails")],
 884     ["config",                         $locale->text("Change Lx-Office installation settings (all menu entries beneath 'System')")],
 885     );
 886
 887   return @all_rights;
 888 }
 889
 890 sub all_rights {
 891   return grep !/^--/, map { $_->[0] } all_rights_full();
 892 }
 893
 894 sub read_groups {
 895   $main::lxdebug->enter_sub();
 896
 897   my $self = shift;
 898
 899   my $form   = $main::form;
 900   my $groups = {};
 901   my $dbh    = $self->dbconnect();
 902
 903   my $query  = 'SELECT * FROM auth."group"';
 904   my $sth    = prepare_execute_query($form, $dbh, $query);
 905
 906   my ($row, $group);
 907
 908   while ($row = $sth->fetchrow_hashref()) {
 909     $groups->{$row->{id}} = $row;
 910   }
 911   $sth->finish();
 912
 913   $query = 'SELECT * FROM auth.user_group WHERE group_id = ?';
 914   $sth   = prepare_query($form, $dbh, $query);
 915
 916   foreach $group (values %{$groups}) {
 917     my @members;
 918
 919     do_statement($form, $sth, $query, $group->{id});
 920
 921     while ($row = $sth->fetchrow_hashref()) {
 922       push @members, $row->{user_id};
 923     }
 924     $group->{members} = [ uniq @members ];
 925   }
 926   $sth->finish();
 927
 928   $query = 'SELECT * FROM auth.group_rights WHERE group_id = ?';
 929   $sth   = prepare_query($form, $dbh, $query);
 930
 931   foreach $group (values %{$groups}) {
 932     $group->{rights} = {};
 933
 934     do_statement($form, $sth, $query, $group->{id});
 935
 936     while ($row = $sth->fetchrow_hashref()) {
 937       $group->{rights}->{$row->{right}} |= $row->{granted};
 938     }
 939
 940     map { $group->{rights}->{$_} = 0 if (!defined $group->{rights}->{$_}); } all_rights();
 941   }
 942   $sth->finish();
 943
 944   $main::lxdebug->leave_sub();
 945
 946   return $groups;
 947 }
 948
 949 sub save_group {
 950   $main::lxdebug->enter_sub();
 951
 952   my $self  = shift;
 953   my $group = shift;
 954
 955   my $form  = $main::form;
 956   my $dbh   = $self->dbconnect();
 957
 958   $dbh->begin_work;
 959
 960   my ($query, $sth, $row, $rights);
 961
 962   if (!$group->{id}) {
 963     ($group->{id}) = selectrow_query($form, $dbh, qq|SELECT nextval('auth.group_id_seq')|);
 964
 965     $query = qq|INSERT INTO auth."group" (id, name, description) VALUES (?, '', '')|;
 966     do_query($form, $dbh, $query, $group->{id});
 967   }
 968
 969   do_query($form, $dbh, qq|UPDATE auth."group" SET name = ?, description = ? WHERE id = ?|, map { $group->{$_} } qw(name description id));
 970
 971   do_query($form, $dbh, qq|DELETE FROM auth.user_group WHERE group_id = ?|, $group->{id});
 972
 973   $query  = qq|INSERT INTO auth.user_group (user_id, group_id) VALUES (?, ?)|;
 974   $sth    = prepare_query($form, $dbh, $query);
 975
 976   foreach my $user_id (uniq @{ $group->{members} }) {
 977     do_statement($form, $sth, $query, $user_id, $group->{id});
 978   }
 979   $sth->finish();
 980
 981   do_query($form, $dbh, qq|DELETE FROM auth.group_rights WHERE group_id = ?|, $group->{id});
 982
 983   $query = qq|INSERT INTO auth.group_rights (group_id, "right", granted) VALUES (?, ?, ?)|;
 984   $sth   = prepare_query($form, $dbh, $query);
 985
 986   foreach my $right (keys %{ $group->{rights} }) {
 987     do_statement($form, $sth, $query, $group->{id}, $right, $group->{rights}->{$right} ? 't' : 'f');
 988   }
 989   $sth->finish();
 990
 991   $dbh->commit();
 992
 993   $main::lxdebug->leave_sub();
 994 }
 995
 996 sub delete_group {
 997   $main::lxdebug->enter_sub();
 998
 999   my $self = shift;
1000   my $id   = shift;
1001
1002   my $form = $main::form;
1003
1004   my $dbh  = $self->dbconnect();
1005   $dbh->begin_work;
1006
1007   do_query($form, $dbh, qq|DELETE FROM auth.user_group WHERE group_id = ?|, $id);
1008   do_query($form, $dbh, qq|DELETE FROM auth.group_rights WHERE group_id = ?|, $id);
1009   do_query($form, $dbh, qq|DELETE FROM auth."group" WHERE id = ?|, $id);
1010
1011   $dbh->commit();
1012
1013   $main::lxdebug->leave_sub();
1014 }
1015
1016 sub evaluate_rights_ary {
1017   $main::lxdebug->enter_sub(2);
1018
1019   my $ary    = shift;
1020
1021   my $value  = 0;
1022   my $action = '|';
1023
1024   foreach my $el (@{$ary}) {
1025     if (ref $el eq "ARRAY") {
1026       if ($action eq '|') {
1027         $value |= evaluate_rights_ary($el);
1028       } else {
1029         $value &= evaluate_rights_ary($el);
1030       }
1031
1032     } elsif (($el eq '&') || ($el eq '|')) {
1033       $action = $el;
1034
1035     } elsif ($action eq '|') {
1036       $value |= $el;
1037
1038     } else {
1039       $value &= $el;
1040
1041     }
1042   }
1043
1044   $main::lxdebug->leave_sub(2);
1045
1046   return $value;
1047 }
1048
1049 sub _parse_rights_string {
1050   $main::lxdebug->enter_sub(2);
1051
1052   my $self   = shift;
1053
1054   my $login  = shift;
1055   my $access = shift;
1056
1057   my @stack;
1058   my $cur_ary = [];
1059
1060   push @stack, $cur_ary;
1061
1062   while ($access =~ m/^([a-z_0-9]+|\||\&|\(|\)|\s+)/) {
1063     my $token = $1;
1064     substr($access, 0, length $1) = "";
1065
1066     next if ($token =~ /\s/);
1067
1068     if ($token eq "(") {
1069       my $new_cur_ary = [];
1070       push @stack, $new_cur_ary;
1071       push @{$cur_ary}, $new_cur_ary;
1072       $cur_ary = $new_cur_ary;
1073
1074     } elsif ($token eq ")") {
1075       pop @stack;
1076
1077       if (!@stack) {
1078         $main::lxdebug->leave_sub(2);
1079         return 0;
1080       }
1081
1082       $cur_ary = $stack[-1];
1083
1084     } elsif (($token eq "|") || ($token eq "&")) {
1085       push @{$cur_ary}, $token;
1086
1087     } else {
1088       push @{$cur_ary}, $self->{RIGHTS}->{$login}->{$token} * 1;
1089     }
1090   }
1091
1092   my $result = ($access || (1 < scalar @stack)) ? 0 : evaluate_rights_ary($stack[0]);
1093
1094   $main::lxdebug->leave_sub(2);
1095
1096   return $result;
1097 }
1098
1099 sub check_right {
1100   $main::lxdebug->enter_sub(2);
1101
1102   my $self    = shift;
1103   my $login   = shift;
1104   my $right   = shift;
1105   my $default = shift;
1106
1107   $self->{FULL_RIGHTS}           ||= { };
1108   $self->{FULL_RIGHTS}->{$login} ||= { };
1109
1110   if (!defined $self->{FULL_RIGHTS}->{$login}->{$right}) {
1111     $self->{RIGHTS}           ||= { };
1112     $self->{RIGHTS}->{$login} ||= $self->load_rights_for_user($login);
1113
1114     $self->{FULL_RIGHTS}->{$login}->{$right} = $self->_parse_rights_string($login, $right);
1115   }
1116
1117   my $granted = $self->{FULL_RIGHTS}->{$login}->{$right};
1118   $granted    = $default if (!defined $granted);
1119
1120   $main::lxdebug->leave_sub(2);
1121
1122   return $granted;
1123 }
1124
1125 sub assert {
1126   $::lxdebug->enter_sub(2);
1127   my ($self, $right, $dont_abort) = @_;
1128
1129   if ($self->check_right($::myconfig{login}, $right)) {
1130     $::lxdebug->leave_sub(2);
1131     return 1;
1132   }
1133
1134   if (!$dont_abort) {
1135     delete $::form->{title};
1136     $::form->show_generic_error($::locale->text("You do not have the permissions to access this function."));
1137   }
1138
1139   $::lxdebug->leave_sub(2);
1140
1141   return 0;
1142 }
1143
1144 sub load_rights_for_user {
1145   $::lxdebug->enter_sub;
1146
1147   my ($self, $login) = @_;
1148   my $dbh   = $self->dbconnect;
1149   my ($query, $sth, $row, $rights);
1150
1151   $rights = { map { $_ => 0 } all_rights() };
1152
1153   $query =
1154     qq|SELECT gr."right", gr.granted
1155        FROM auth.group_rights gr
1156        WHERE group_id IN
1157          (SELECT ug.group_id
1158           FROM auth.user_group ug
1159           LEFT JOIN auth."user" u ON (ug.user_id = u.id)
1160           WHERE u.login = ?)|;
1161
1162   $sth = prepare_execute_query($::form, $dbh, $query, $login);
1163
1164   while ($row = $sth->fetchrow_hashref()) {
1165     $rights->{$row->{right}} |= $row->{granted};
1166   }
1167   $sth->finish();
1168
1169   $::lxdebug->leave_sub;
1170
1171   return $rights;
1172 }
1173
1174 1;
1175 __END__
1176
1177 =pod
1178
1179 =encoding utf8
1180
1181 =head1 NAME
1182
1183 SL::Auth - Authentication and session handling
1184
1185 =head1 FUNCTIONS
1186
1187 =over 4
1188
1189 =item C<set_session_value %values>
1190
1191 Store all key/value pairs in C<%values> in the session. All of these
1192 values are copied back into C<$::form> in the next request
1193 automatically.
1194
1195 The values can be any Perl structure. They are stored as YAML dumps.
1196
1197 =item C<get_session_value $key>
1198
1199 Retrieve a value from the session. Returns C<undef> if the value
1200 doesn't exist.
1201
1202 =item C<create_unique_sesion_value $value, %params>
1203
1204 Create a unique key in the session and store C<$value>
1205 there.
1206
1207 If C<$params{expiration}> is set then it is interpreted as a number of
1208 seconds after which the value is removed from the session. It will
1209 never expire if that parameter is falsish.
1210
1211 Returns the key created in the session.
1212
1213 =item C<expire_session_keys>
1214
1215 Removes all keys from the session that have an expiration time set and
1216 whose expiration time is in the past.
1217
1218 =item C<save_session>
1219
1220 Stores the session values in the database. This is the only function
1221 that actually stores stuff in the database. Neither the various
1222 setters nor the deleter access the database.
1223
1224 =item <save_form_in_session %params>
1225
1226 Stores the content of C<$params{form}> (default: C<$::form>) in the
1227 session using L</create_unique_sesion_value>.
1228
1229 If C<$params{non_scalars}> is trueish then non-scalar values will be
1230 stored as well. Default is to only store scalar values.
1231
1232 The following keys will never be saved: C<login>, C<password>,
1233 C<stylesheet>, C<titlebar>, C<version>. Additional keys not to save
1234 can be given as an array ref in C<$params{skip_keys}>.
1235
1236 Returns the unique key under which the form is stored.
1237
1238 =item <restore_form_from_session $key, %params>
1239
1240 Restores the form from the session into C<$params{form}> (default:
1241 C<$::form>).
1242
1243 If C<$params{clobber}> is falsish then existing values with the same
1244 key in C<$params{form}> will not be overwritten. C<$params{clobber}>
1245 is on by default.
1246
1247 Returns C<$self>.
1248
1249 =back
1250
1251 =head1 BUGS
1252
1253 Nothing here yet.
1254
1255 =head1 AUTHOR
1256
1257 Moritz Bunkus E<lt>m.bunkus@linet-services.deE<gt>
1258
1259 =cut