SL/Auth.pm

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