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