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     $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 = ?) AND (auto_restore OR sess_key IN (@{[ join ',', ("?") x keys %auto_restore_keys ]}))
 639 SQL
 640   my $sth = prepare_execute_query($::form, $dbh, $query, $session_id, keys %auto_restore_keys);
 641
 642   my $need_delete;
 643   while (my $ref = $sth->fetchrow_hashref) {
 644     $need_delete = 1 if $ref->{auto_restore};
 645     my $value = SL::Auth::SessionValue->new(auth         => $self,
 646                                             key          => $ref->{sess_key},
 647                                             value        => $ref->{sess_value},
 648                                             auto_restore => $ref->{auto_restore},
 649                                             raw          => 1);
 650     $self->{SESSION}->{ $ref->{sess_key} } = $value;
 651
 652     next if defined $::form->{$ref->{sess_key}};
 653
 654     my $data                    = $value->get;
 655     $::form->{$ref->{sess_key}} = $data if $value->{auto_restore} || !ref $data;
 656   }
 657
 658   $sth->finish;
 659
 660   if ($need_delete) {
 661     do_query($::form, $dbh, 'DELETE FROM auth.session_content WHERE auto_restore AND session_id = ?', $session_id);
 662   }
 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 ($id) = selectrow_query($::form, $dbh, qq|SELECT id FROM auth.session WHERE id = ?|, $session_id);
 757
 758   if ($id) {
 759     do_query($::form, $dbh, qq|UPDATE auth.session SET mtime = now() WHERE id = ?|, $session_id);
 760   } else {
 761     do_query($::form, $dbh, qq|INSERT INTO auth.session (id, ip_address, mtime) VALUES (?, ?, now())|, $session_id, $ENV{REMOTE_ADDR});
 762   }
 763
 764   if ($self->{column_information}->has('api_token', 'session')) {
 765     my ($stored_api_token) = $dbh->selectrow_array(qq|SELECT api_token FROM auth.session WHERE id = ?|, undef, $session_id);
 766     do_query($::form, $dbh, qq|UPDATE auth.session SET api_token = ? WHERE id = ?|, $self->_create_session_id, $session_id) unless $stored_api_token;
 767   }
 768
 769   my @values_to_save = grep    { $_->{modified} }
 770                        values %{ $self->{SESSION} };
 771   if (@values_to_save) {
 772     my %known_keys = map { $_ => 1 }
 773       selectall_ids($::form, $dbh, qq|SELECT sess_key FROM auth.session_content WHERE session_id = ?|, 'sess_key', $session_id);
 774     my $auto_restore             = $self->{column_information}->has('auto_restore');
 775
 776     my $insert_query  = $auto_restore
 777       ? "INSERT INTO auth.session_content (session_id, sess_key, sess_value, auto_restore) VALUES (?, ?, ?, ?)"
 778       : "INSERT INTO auth.session_content (session_id, sess_key, sess_value) VALUES (?, ?, ?)";
 779     my $insert_sth = prepare_query($::form, $dbh, $insert_query);
 780
 781     my $update_query  = $auto_restore
 782       ? "UPDATE auth.session_content SET sess_value = ?, auto_restore = ? WHERE session_id = ? AND sess_key = ?"
 783       : "UPDATE auth.session_content SET sess_value = ? WHERE session_id = ? AND sess_key = ?";
 784     my $update_sth = prepare_query($::form, $dbh, $update_query);
 785
 786     foreach my $value (@values_to_save) {
 787       my @values = ($value->{key}, $value->get_dumped);
 788       push @values, $value->{auto_restore} if $auto_restore;
 789
 790       if ($known_keys{$value->{key}}) {
 791         do_statement($::form, $update_sth, $update_query,
 792           $value->get_dumped, ( $value->{auto_restore} )x!!$auto_restore, $session_id, $value->{key}
 793         );
 794       } else {
 795         do_statement($::form, $insert_sth, $insert_query,
 796           $session_id, $value->{key}, $value->get_dumped, ( $value->{auto_restore} )x!!$auto_restore
 797         );
 798       }
 799     }
 800
 801     $insert_sth->finish;
 802     $update_sth->finish;
 803   }
 804
 805   $dbh->commit() unless $provided_dbh;
 806 }
 807
 808 sub set_session_value {
 809   my $self   = shift;
 810   my @params = @_;
 811
 812   $self->{SESSION} ||= { };
 813
 814   while (@params) {
 815     my $key = shift @params;
 816
 817     if (ref $key eq 'HASH') {
 818       $self->{SESSION}->{ $key->{key} } = SL::Auth::SessionValue->new(key          => $key->{key},
 819                                                                       value        => $key->{value},
 820                                                                       modified     => 1,
 821                                                                       auto_restore => $key->{auto_restore});
 822
 823     } else {
 824       my $value = shift @params;
 825       $self->{SESSION}->{ $key } = SL::Auth::SessionValue->new(key   => $key,
 826                                                                value => $value,
 827                                                                modified => 1);
 828     }
 829   }
 830
 831   return $self;
 832 }
 833
 834 sub delete_session_value {
 835   my $self = shift;
 836
 837   $self->{SESSION} ||= { };
 838   delete @{ $self->{SESSION} }{ @_ };
 839
 840   return $self;
 841 }
 842
 843 sub get_session_value {
 844   my ($self, $key) = @_;
 845
 846   return if !$self->{SESSION};
 847
 848   ($self->{SESSION}{$key} //= SL::Auth::SessionValue->new(auth => $self, key => $key))->get
 849 }
 850
 851 sub create_unique_sesion_value {
 852   my ($self, $value, %params) = @_;
 853
 854   $self->{SESSION} ||= { };
 855
 856   my @now                   = gettimeofday();
 857   my $key                   = "$$-" . ($now[0] * 1000000 + $now[1]) . "-";
 858   $self->{unique_counter} ||= 0;
 859
 860   my $hashed_key;
 861   do {
 862     $self->{unique_counter}++;
 863     $hashed_key = md5_hex($key . $self->{unique_counter});
 864   } while (exists $self->{SESSION}->{$hashed_key});
 865
 866   $self->set_session_value($hashed_key => $value);
 867
 868   return $hashed_key;
 869 }
 870
 871 sub save_form_in_session {
 872   my ($self, %params) = @_;
 873
 874   my $form        = delete($params{form}) || $::form;
 875   my $non_scalars = delete $params{non_scalars};
 876   my $data        = {};
 877
 878   my %skip_keys   = map { ( $_ => 1 ) } (qw(login password stylesheet version titlebar), @{ $params{skip_keys} || [] });
 879
 880   foreach my $key (grep { !$skip_keys{$_} } keys %{ $form }) {
 881     $data->{$key} = $form->{$key} if !ref($form->{$key}) || $non_scalars;
 882   }
 883
 884   return $self->create_unique_sesion_value($data, %params);
 885 }
 886
 887 sub restore_form_from_session {
 888   my ($self, $key, %params) = @_;
 889
 890   my $data = $self->get_session_value($key);
 891   return $self unless $data;
 892
 893   my $form    = delete($params{form}) || $::form;
 894   my $clobber = exists $params{clobber} ? $params{clobber} : 1;
 895
 896   map { $form->{$_} = $data->{$_} if $clobber || !exists $form->{$_} } keys %{ $data };
 897
 898   return $self;
 899 }
 900
 901 sub set_cookie_environment_variable {
 902   my $self = shift;
 903   $ENV{HTTP_COOKIE} = $self->get_session_cookie_name() . "=${session_id}";
 904 }
 905
 906 sub get_session_cookie_name {
 907   my ($self, %params) = @_;
 908
 909   $params{type}     ||= 'id';
 910   my $name            = $self->{cookie_name} || 'lx_office_erp_session_id';
 911   $name              .= '_api_token' if $params{type} eq 'api_token';
 912
 913   return $name;
 914 }
 915
 916 sub get_session_id {
 917   return $session_id;
 918 }
 919
 920 sub get_api_token_cookie {
 921   my ($self) = @_;
 922
 923   $::request->{cgi}->cookie($self->get_session_cookie_name(type => 'api_token'));
 924 }
 925
 926 sub is_api_token_cookie_valid {
 927   my ($self)             = @_;
 928   my $provided_api_token = $self->get_api_token_cookie;
 929   return $self->{api_token} && $provided_api_token && ($self->{api_token} eq $provided_api_token);
 930 }
 931
 932 sub _tables_present {
 933   my ($self, @tables) = @_;
 934   my $cache_key = join '_', @tables;
 935
 936   # Only re-check for the presence of auth tables if either the check
 937   # hasn't been done before of if they weren't present.
 938   return $self->{"$cache_key\_tables_present"} ||= do {
 939     my $dbh  = $self->dbconnect(1);
 940
 941     if (!$dbh) {
 942       return 0;
 943     }
 944
 945     my $query =
 946       qq|SELECT COUNT(*)
 947          FROM pg_tables
 948          WHERE (schemaname = 'auth')
 949            AND (tablename IN (@{[ join ', ', ('?') x @tables ]}))|;
 950
 951     my ($count) = selectrow_query($main::form, $dbh, $query, @tables);
 952
 953     scalar @tables == $count;
 954   }
 955 }
 956
 957 sub session_tables_present {
 958   $_[0]->_tables_present('session', 'session_content');
 959 }
 960
 961 sub master_rights_present {
 962   $_[0]->_tables_present('master_rights');
 963 }
 964
 965 # --------------------------------------
 966
 967 sub all_rights_full {
 968   my ($self) = @_;
 969
 970   @{ $self->{master_rights} ||= do {
 971       $self->dbconnect->selectall_arrayref("SELECT name, description, category FROM auth.master_rights ORDER BY position");
 972     }
 973   }
 974 }
 975
 976 sub all_rights {
 977   return map { $_->[0] } grep { !$_->[2] } $_[0]->all_rights_full;
 978 }
 979
 980 sub read_groups {
 981   my $self = shift;
 982
 983   my $form   = $main::form;
 984   my $groups = {};
 985   my $dbh    = $self->dbconnect();
 986
 987   my $query  = 'SELECT * FROM auth."group"';
 988   my $sth    = prepare_execute_query($form, $dbh, $query);
 989
 990   my ($row, $group);
 991
 992   while ($row = $sth->fetchrow_hashref()) {
 993     $groups->{$row->{id}} = $row;
 994   }
 995   $sth->finish();
 996
 997   $query = 'SELECT * FROM auth.user_group WHERE group_id = ?';
 998   $sth   = prepare_query($form, $dbh, $query);
 999
1000   foreach $group (values %{$groups}) {
1001     my @members;
1002
1003     do_statement($form, $sth, $query, $group->{id});
1004
1005     while ($row = $sth->fetchrow_hashref()) {
1006       push @members, $row->{user_id};
1007     }
1008     $group->{members} = [ uniq @members ];
1009   }
1010   $sth->finish();
1011
1012   $query = 'SELECT * FROM auth.group_rights WHERE group_id = ?';
1013   $sth   = prepare_query($form, $dbh, $query);
1014
1015   foreach $group (values %{$groups}) {
1016     $group->{rights} = {};
1017
1018     do_statement($form, $sth, $query, $group->{id});
1019
1020     while ($row = $sth->fetchrow_hashref()) {
1021       $group->{rights}->{$row->{right}} |= $row->{granted};
1022     }
1023
1024     map { $group->{rights}->{$_} = 0 if (!defined $group->{rights}->{$_}); } $self->all_rights;
1025   }
1026   $sth->finish();
1027
1028   return $groups;
1029 }
1030
1031 sub save_group {
1032   my $self  = shift;
1033   my $group = shift;
1034
1035   my $form  = $main::form;
1036   my $dbh   = $self->dbconnect();
1037
1038   $dbh->begin_work;
1039
1040   my ($query, $sth, $row, $rights);
1041
1042   if (!$group->{id}) {
1043     ($group->{id}) = selectrow_query($form, $dbh, qq|SELECT nextval('auth.group_id_seq')|);
1044
1045     $query = qq|INSERT INTO auth."group" (id, name, description) VALUES (?, '', '')|;
1046     do_query($form, $dbh, $query, $group->{id});
1047   }
1048
1049   do_query($form, $dbh, qq|UPDATE auth."group" SET name = ?, description = ? WHERE id = ?|, map { $group->{$_} } qw(name description id));
1050
1051   do_query($form, $dbh, qq|DELETE FROM auth.user_group WHERE group_id = ?|, $group->{id});
1052
1053   $query  = qq|INSERT INTO auth.user_group (user_id, group_id) VALUES (?, ?)|;
1054   $sth    = prepare_query($form, $dbh, $query);
1055
1056   foreach my $user_id (uniq @{ $group->{members} }) {
1057     do_statement($form, $sth, $query, $user_id, $group->{id});
1058   }
1059   $sth->finish();
1060
1061   do_query($form, $dbh, qq|DELETE FROM auth.group_rights WHERE group_id = ?|, $group->{id});
1062
1063   $query = qq|INSERT INTO auth.group_rights (group_id, "right", granted) VALUES (?, ?, ?)|;
1064   $sth   = prepare_query($form, $dbh, $query);
1065
1066   foreach my $right (keys %{ $group->{rights} }) {
1067     do_statement($form, $sth, $query, $group->{id}, $right, $group->{rights}->{$right} ? 't' : 'f');
1068   }
1069   $sth->finish();
1070
1071   $dbh->commit();
1072 }
1073
1074 sub delete_group {
1075   my $self = shift;
1076   my $id   = shift;
1077
1078   my $form = $main::form;
1079
1080   my $dbh  = $self->dbconnect();
1081   $dbh->begin_work;
1082
1083   do_query($form, $dbh, qq|DELETE FROM auth.user_group WHERE group_id = ?|, $id);
1084   do_query($form, $dbh, qq|DELETE FROM auth.group_rights WHERE group_id = ?|, $id);
1085   do_query($form, $dbh, qq|DELETE FROM auth."group" WHERE id = ?|, $id);
1086
1087   $dbh->commit();
1088 }
1089
1090 sub evaluate_rights_ary {
1091   my $ary    = shift;
1092
1093   my $value  = 0;
1094   my $action = '|';
1095   my $negate = 0;
1096
1097   foreach my $el (@{$ary}) {
1098     if (ref $el eq "ARRAY") {
1099       my $val = evaluate_rights_ary($el);
1100       $val    = !$val if $negate;
1101       $negate = 0;
1102       if ($action eq '|') {
1103         $value |= $val;
1104       } else {
1105         $value &= $val;
1106       }
1107
1108     } elsif (($el eq '&') || ($el eq '|')) {
1109       $action = $el;
1110
1111     } elsif ($el eq '!') {
1112       $negate = !$negate;
1113
1114     } elsif ($action eq '|') {
1115       my $val = $el;
1116       $val    = !$val if $negate;
1117       $negate = 0;
1118       $value |= $val;
1119
1120     } else {
1121       my $val = $el;
1122       $val    = !$val if $negate;
1123       $negate = 0;
1124       $value &= $val;
1125
1126     }
1127   }
1128
1129   return $value;
1130 }
1131
1132 sub _parse_rights_string {
1133   my $self   = shift;
1134
1135   my $login  = shift;
1136   my $access = shift;
1137
1138   my @stack;
1139   my $cur_ary = [];
1140
1141   push @stack, $cur_ary;
1142
1143   while ($access =~ m/^([a-z_0-9]+|\||\&|\(|\)|\s+)/) {
1144     my $token = $1;
1145     substr($access, 0, length $1) = "";
1146
1147     next if ($token =~ /\s/);
1148
1149     if ($token eq "(") {
1150       my $new_cur_ary = [];
1151       push @stack, $new_cur_ary;
1152       push @{$cur_ary}, $new_cur_ary;
1153       $cur_ary = $new_cur_ary;
1154
1155     } elsif ($token eq ")") {
1156       pop @stack;
1157
1158       if (!@stack) {
1159         return 0;
1160       }
1161
1162       $cur_ary = $stack[-1];
1163
1164     } elsif (($token eq "|") || ($token eq "&")) {
1165       push @{$cur_ary}, $token;
1166
1167     } else {
1168       push @{$cur_ary}, ($self->{RIGHTS}->{$login}->{$token} // 0) * 1;
1169     }
1170   }
1171
1172   my $result = ($access || (1 < scalar @stack)) ? 0 : evaluate_rights_ary($stack[0]);
1173
1174   return $result;
1175 }
1176
1177 sub check_right {
1178   my $self    = shift;
1179   my $login   = shift;
1180   my $right   = shift;
1181   my $default = shift;
1182
1183   $self->{FULL_RIGHTS}           ||= { };
1184   $self->{FULL_RIGHTS}->{$login} ||= { };
1185
1186   if (!defined $self->{FULL_RIGHTS}->{$login}->{$right}) {
1187     $self->{RIGHTS}           ||= { };
1188     $self->{RIGHTS}->{$login} ||= $self->load_rights_for_user($login);
1189
1190     $self->{FULL_RIGHTS}->{$login}->{$right} = $self->_parse_rights_string($login, $right);
1191   }
1192
1193   my $granted = $self->{FULL_RIGHTS}->{$login}->{$right};
1194   $granted    = $default if (!defined $granted);
1195
1196   return $granted;
1197 }
1198
1199 sub assert {
1200   my ($self, $right, $dont_abort) = @_;
1201
1202   if ($self->check_right($::myconfig{login}, $right)) {
1203     return 1;
1204   }
1205
1206   if (!$dont_abort) {
1207     delete $::form->{title};
1208     $::form->show_generic_error($::locale->text("You do not have the permissions to access this function."));
1209   }
1210
1211   return 0;
1212 }
1213
1214 sub load_rights_for_user {
1215   my ($self, $login) = @_;
1216   my $dbh   = $self->dbconnect;
1217   my ($query, $sth, $row, $rights);
1218
1219   $rights = { map { $_ => 0 } $self->all_rights };
1220
1221   return $rights if !$self->client || !$login;
1222
1223   $query =
1224     qq|SELECT gr."right", gr.granted
1225        FROM auth.group_rights gr
1226        WHERE group_id IN
1227          (SELECT ug.group_id
1228           FROM auth.user_group ug
1229           LEFT JOIN auth."user" u ON (ug.user_id = u.id)
1230           WHERE u.login = ?)
1231        AND group_id IN
1232          (SELECT cg.group_id
1233           FROM auth.clients_groups cg
1234           WHERE cg.client_id = ?)|;
1235
1236   $sth = prepare_execute_query($::form, $dbh, $query, $login, $self->client->{id});
1237
1238   while ($row = $sth->fetchrow_hashref()) {
1239     $rights->{$row->{right}} |= $row->{granted};
1240   }
1241   $sth->finish();
1242
1243   return $rights;
1244 }
1245
1246 1;
1247 __END__
1248
1249 =pod
1250
1251 =encoding utf8
1252
1253 =head1 NAME
1254
1255 SL::Auth - Authentication and session handling
1256
1257 =head1 METHODS
1258
1259 =over 4
1260
1261 =item C<set_session_value @values>
1262
1263 =item C<set_session_value %values>
1264
1265 Store all values of C<@values> or C<%values> in the session. Each
1266 member of C<@values> is tested if it is a hash reference. If it is
1267 then it must contain the keys C<key> and C<value> and can optionally
1268 contain the key C<auto_restore>. In this case C<value> is associated
1269 with C<key> and restored to C<$::form> upon the next request
1270 automatically if C<auto_restore> is trueish or if C<value> is a scalar
1271 value.
1272
1273 If the current member of C<@values> is not a hash reference then it
1274 will be used as the C<key> and the next entry of C<@values> is used as
1275 the C<value> to store. In this case setting C<auto_restore> is not
1276 possible.
1277
1278 Therefore the following two invocations are identical:
1279
1280   $::auth-E<gt>set_session_value(name =E<gt> "Charlie");
1281   $::auth-E<gt>set_session_value({ key =E<gt> "name", value =E<gt> "Charlie" });
1282
1283 All of these values are copied back into C<$::form> for the next
1284 request automatically if they're scalar values or if they have
1285 C<auto_restore> set to trueish.
1286
1287 The values can be any Perl structure. They are stored as YAML dumps.
1288
1289 =item C<get_session_value $key>
1290
1291 Retrieve a value from the session. Returns C<undef> if the value
1292 doesn't exist.
1293
1294 =item C<create_unique_sesion_value $value, %params>
1295
1296 Create a unique key in the session and store C<$value>
1297 there.
1298
1299 Returns the key created in the session.
1300
1301 =item C<save_session>
1302
1303 Stores the session values in the database. This is the only function
1304 that actually stores stuff in the database. Neither the various
1305 setters nor the deleter access the database.
1306
1307 =item C<save_form_in_session %params>
1308
1309 Stores the content of C<$params{form}> (default: C<$::form>) in the
1310 session using L</create_unique_sesion_value>.
1311
1312 If C<$params{non_scalars}> is trueish then non-scalar values will be
1313 stored as well. Default is to only store scalar values.
1314
1315 The following keys will never be saved: C<login>, C<password>,
1316 C<stylesheet>, C<titlebar>, C<version>. Additional keys not to save
1317 can be given as an array ref in C<$params{skip_keys}>.
1318
1319 Returns the unique key under which the form is stored.
1320
1321 =item C<restore_form_from_session $key, %params>
1322
1323 Restores the form from the session into C<$params{form}> (default:
1324 C<$::form>).
1325
1326 If C<$params{clobber}> is falsish then existing values with the same
1327 key in C<$params{form}> will not be overwritten. C<$params{clobber}>
1328 is on by default.
1329
1330 Returns C<$self>.
1331
1332 =item C<reset>
1333
1334 C<reset> deletes every state information from previous requests, but does not
1335 close the database connection.
1336
1337 Creating a new database handle on each request can take up to 30% of the
1338 pre-request startup time, so we want to avoid that for fast ajax calls.
1339
1340 =item C<assert, $right, $dont_abort>
1341
1342 Checks if current user has the C<$right>. If C<$dont_abort> is falsish
1343 the request dies with a access denied error, otherwise returns true or false.
1344
1345 =back
1346
1347 =head1 BUGS
1348
1349 Nothing here yet.
1350
1351 =head1 AUTHOR
1352
1353 Moritz Bunkus E<lt>m.bunkus@linet-services.deE<gt>
1354
1355 =cut