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