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