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