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 & 'CSS new' backed menus have been removed.
 493   my %menustyle_map = ( xml => 'new', v4 => 'v3' );
 494   $user_data{menustyle} = $menustyle_map{lc($user_data{menustyle} || '')} || $user_data{menustyle};
 495
 496   # The 'Win2000.css' stylesheet has been removed.
 497   $user_data{stylesheet} = 'kivitendo.css' if ($user_data{stylesheet} || '') =~ m/win2000/i;
 498
 499   # Set default language if selected language does not exist (anymore).
 500   $user_data{countrycode} = $::lx_office_conf{system}->{language} unless $user_data{countrycode} && -d "locale/$user_data{countrycode}";
 501
 502   $sth->finish();
 503
 504   $main::lxdebug->leave_sub();
 505
 506   return %user_data;
 507 }
 508
 509 sub get_user_id {
 510   $main::lxdebug->enter_sub();
 511
 512   my $self  = shift;
 513   my $login = shift;
 514
 515   my $dbh   = $self->dbconnect();
 516   my ($id)  = selectrow_query($main::form, $dbh, qq|SELECT id FROM auth."user" WHERE login = ?|, $login);
 517
 518   $main::lxdebug->leave_sub();
 519
 520   return $id;
 521 }
 522
 523 sub delete_user {
 524   $::lxdebug->enter_sub;
 525
 526   my $self  = shift;
 527   my $login = shift;
 528
 529   my $dbh   = $self->dbconnect;
 530   my $id    = $self->get_user_id($login);
 531   my $user_db_exists;
 532
 533   $dbh->rollback and return $::lxdebug->leave_sub if (!$id);
 534
 535   my $u_dbh = $self->get_user_dbh($login, may_fail => 1);
 536   $user_db_exists = $self->check_tables($u_dbh) if $u_dbh;
 537
 538   $u_dbh->begin_work if $u_dbh && $user_db_exists;
 539
 540   $dbh->begin_work;
 541
 542   do_query($::form, $dbh, qq|DELETE FROM auth.user_group WHERE user_id = ?|, $id);
 543   do_query($::form, $dbh, qq|DELETE FROM auth.user_config WHERE user_id = ?|, $id);
 544   do_query($::form, $dbh, qq|DELETE FROM auth.user WHERE id = ?|, $id);
 545   do_query($::form, $u_dbh, qq|UPDATE employee SET deleted = 't' WHERE login = ?|, $login) if $u_dbh && $user_db_exists;
 546
 547   $dbh->commit;
 548   $u_dbh->commit if $u_dbh && $user_db_exists;
 549
 550   $::lxdebug->leave_sub;
 551 }
 552
 553 # --------------------------------------
 554
 555 my $session_id;
 556
 557 sub restore_session {
 558   $main::lxdebug->enter_sub();
 559
 560   my $self = shift;
 561
 562   $session_id        =  $::request->{cgi}->cookie($self->get_session_cookie_name());
 563   $session_id        =~ s|[^0-9a-f]||g if $session_id;
 564
 565   $self->{SESSION}   = { };
 566
 567   if (!$session_id) {
 568     $main::lxdebug->leave_sub();
 569     return SESSION_NONE;
 570   }
 571
 572   my ($dbh, $query, $sth, $cookie, $ref, $form);
 573
 574   $form   = $main::form;
 575
 576   # Don't fail if the auth DB doesn't yet.
 577   if (!( $dbh = $self->dbconnect(1) )) {
 578     $::lxdebug->leave_sub;
 579     return SESSION_NONE;
 580   }
 581
 582   # Don't fail if the "auth" schema doesn't exist yet, e.g. if the
 583   # admin is creating the session tables at the moment.
 584   $query  = qq|SELECT *, (mtime < (now() - '$self->{session_timeout}m'::interval)) AS is_expired FROM auth.session WHERE id = ?|;
 585
 586   if (!($sth = $dbh->prepare($query)) || !$sth->execute($session_id)) {
 587     $sth->finish if $sth;
 588     $::lxdebug->leave_sub;
 589     return SESSION_NONE;
 590   }
 591
 592   $cookie = $sth->fetchrow_hashref;
 593   $sth->finish;
 594
 595   if (!$cookie || $cookie->{is_expired} || ($cookie->{ip_address} ne $ENV{REMOTE_ADDR})) {
 596     $self->destroy_session();
 597     $main::lxdebug->leave_sub();
 598     return $cookie ? SESSION_EXPIRED : SESSION_NONE;
 599   }
 600
 601   if ($self->{column_information}->has('auto_restore')) {
 602     $self->_load_with_auto_restore_column($dbh, $session_id);
 603   } else {
 604     $self->_load_without_auto_restore_column($dbh, $session_id);
 605   }
 606
 607   $main::lxdebug->leave_sub();
 608
 609   return SESSION_OK;
 610 }
 611
 612 sub _load_without_auto_restore_column {
 613   my ($self, $dbh, $session_id) = @_;
 614
 615   my $query = <<SQL;
 616     SELECT sess_key, sess_value
 617     FROM auth.session_content
 618     WHERE (session_id = ?)
 619 SQL
 620   my $sth = prepare_execute_query($::form, $dbh, $query, $session_id);
 621
 622   while (my $ref = $sth->fetchrow_hashref) {
 623     my $value = SL::Auth::SessionValue->new(auth  => $self,
 624                                             key   => $ref->{sess_key},
 625                                             value => $ref->{sess_value},
 626                                             raw   => 1);
 627     $self->{SESSION}->{ $ref->{sess_key} } = $value;
 628
 629     next if defined $::form->{$ref->{sess_key}};
 630
 631     my $data                    = $value->get;
 632     $::form->{$ref->{sess_key}} = $data if $value->{auto_restore} || !ref $data;
 633   }
 634 }
 635
 636 sub _load_with_auto_restore_column {
 637   my ($self, $dbh, $session_id) = @_;
 638
 639   my $auto_restore_keys = join ', ', map { "'${_}'" } qw(login password rpw);
 640
 641   my $query = <<SQL;
 642     SELECT sess_key, sess_value, auto_restore
 643     FROM auth.session_content
 644     WHERE (session_id = ?)
 645       AND (   auto_restore
 646            OR sess_key IN (${auto_restore_keys}))
 647 SQL
 648   my $sth = prepare_execute_query($::form, $dbh, $query, $session_id);
 649
 650   while (my $ref = $sth->fetchrow_hashref) {
 651     my $value = SL::Auth::SessionValue->new(auth         => $self,
 652                                             key          => $ref->{sess_key},
 653                                             value        => $ref->{sess_value},
 654                                             auto_restore => $ref->{auto_restore},
 655                                             raw          => 1);
 656     $self->{SESSION}->{ $ref->{sess_key} } = $value;
 657
 658     next if defined $::form->{$ref->{sess_key}};
 659
 660     my $data                    = $value->get;
 661     $::form->{$ref->{sess_key}} = $data if $value->{auto_restore} || !ref $data;
 662   }
 663
 664   $sth->finish;
 665
 666   $query = <<SQL;
 667     SELECT sess_key
 668     FROM auth.session_content
 669     WHERE (session_id = ?)
 670       AND NOT COALESCE(auto_restore, FALSE)
 671       AND (sess_key NOT IN (${auto_restore_keys}))
 672 SQL
 673   $sth = prepare_execute_query($::form, $dbh, $query, $session_id);
 674
 675   while (my $ref = $sth->fetchrow_hashref) {
 676     my $value = SL::Auth::SessionValue->new(auth => $self,
 677                                             key  => $ref->{sess_key});
 678     $self->{SESSION}->{ $ref->{sess_key} } = $value;
 679   }
 680 }
 681
 682 sub destroy_session {
 683   $main::lxdebug->enter_sub();
 684
 685   my $self = shift;
 686
 687   if ($session_id) {
 688     my $dbh = $self->dbconnect();
 689
 690     $dbh->begin_work;
 691
 692     do_query($main::form, $dbh, qq|DELETE FROM auth.session_content WHERE session_id = ?|, $session_id);
 693     do_query($main::form, $dbh, qq|DELETE FROM auth.session WHERE id = ?|, $session_id);
 694
 695     $dbh->commit();
 696
 697     SL::SessionFile->destroy_session($session_id);
 698
 699     $session_id      = undef;
 700     $self->{SESSION} = { };
 701   }
 702
 703   $main::lxdebug->leave_sub();
 704 }
 705
 706 sub expire_sessions {
 707   $main::lxdebug->enter_sub();
 708
 709   my $self  = shift;
 710
 711   $main::lxdebug->leave_sub and return if !$self->session_tables_present;
 712
 713   my $dbh   = $self->dbconnect();
 714
 715   my $query = qq|SELECT id
 716                  FROM auth.session
 717                  WHERE (mtime < (now() - '$self->{session_timeout}m'::interval))|;
 718
 719   my @ids   = selectall_array_query($::form, $dbh, $query);
 720
 721   if (@ids) {
 722     $dbh->begin_work;
 723
 724     SL::SessionFile->destroy_session($_) for @ids;
 725
 726     $query = qq|DELETE FROM auth.session_content
 727                 WHERE session_id IN (| . join(', ', ('?') x scalar(@ids)) . qq|)|;
 728     do_query($main::form, $dbh, $query, @ids);
 729
 730     $query = qq|DELETE FROM auth.session
 731                 WHERE id IN (| . join(', ', ('?') x scalar(@ids)) . qq|)|;
 732     do_query($main::form, $dbh, $query, @ids);
 733
 734     $dbh->commit();
 735   }
 736
 737   $main::lxdebug->leave_sub();
 738 }
 739
 740 sub _create_session_id {
 741   $main::lxdebug->enter_sub();
 742
 743   my @data;
 744   map { push @data, int(rand() * 255); } (1..32);
 745
 746   my $id = md5_hex(pack 'C*', @data);
 747
 748   $main::lxdebug->leave_sub();
 749
 750   return $id;
 751 }
 752
 753 sub create_or_refresh_session {
 754   $session_id ||= shift->_create_session_id;
 755 }
 756
 757 sub save_session {
 758   $::lxdebug->enter_sub;
 759   my $self         = shift;
 760   my $provided_dbh = shift;
 761
 762   my $dbh          = $provided_dbh || $self->dbconnect(1);
 763
 764   $::lxdebug->leave_sub && return unless $dbh && $session_id;
 765
 766   $dbh->begin_work unless $provided_dbh;
 767
 768   # If this fails then the "auth" schema might not exist yet, e.g. if
 769   # the admin is just trying to create the auth database.
 770   if (!$dbh->do(qq|LOCK auth.session_content|)) {
 771     $dbh->rollback unless $provided_dbh;
 772     $::lxdebug->leave_sub;
 773     return;
 774   }
 775
 776   my @unfetched_keys = map     { $_->{key}        }
 777                        grep    { ! $_->{fetched}  }
 778                        values %{ $self->{SESSION} };
 779   # $::lxdebug->dump(0, "unfetched_keys", [ sort @unfetched_keys ]);
 780   # $::lxdebug->dump(0, "all keys", [ sort map { $_->{key} } values %{ $self->{SESSION} } ]);
 781   my $query          = qq|DELETE FROM auth.session_content WHERE (session_id = ?)|;
 782   $query            .= qq| AND (sess_key NOT IN (| . join(', ', ('?') x scalar @unfetched_keys) . qq|))| if @unfetched_keys;
 783
 784   do_query($::form, $dbh, $query, $session_id, @unfetched_keys);
 785
 786   my ($id) = selectrow_query($::form, $dbh, qq|SELECT id FROM auth.session WHERE id = ?|, $session_id);
 787
 788   if ($id) {
 789     do_query($::form, $dbh, qq|UPDATE auth.session SET mtime = now() WHERE id = ?|, $session_id);
 790   } else {
 791     do_query($::form, $dbh, qq|INSERT INTO auth.session (id, ip_address, mtime) VALUES (?, ?, now())|, $session_id, $ENV{REMOTE_ADDR});
 792   }
 793
 794   my @values_to_save = grep    { $_->{fetched} }
 795                        values %{ $self->{SESSION} };
 796   if (@values_to_save) {
 797     my ($columns, $placeholders) = ('', '');
 798     my $auto_restore             = $self->{column_information}->has('auto_restore');
 799
 800     if ($auto_restore) {
 801       $columns      .= ', auto_restore';
 802       $placeholders .= ', ?';
 803     }
 804
 805     $query  = qq|INSERT INTO auth.session_content (session_id, sess_key, sess_value ${columns}) VALUES (?, ?, ? ${placeholders})|;
 806     my $sth = prepare_query($::form, $dbh, $query);
 807
 808     foreach my $value (@values_to_save) {
 809       my @values = ($value->{key}, $value->get_dumped);
 810       push @values, $value->{auto_restore} if $auto_restore;
 811
 812       do_statement($::form, $sth, $query, $session_id, @values);
 813     }
 814
 815     $sth->finish();
 816   }
 817
 818   $dbh->commit() unless $provided_dbh;
 819   $::lxdebug->leave_sub;
 820 }
 821
 822 sub set_session_value {
 823   $main::lxdebug->enter_sub();
 824
 825   my $self   = shift;
 826   my @params = @_;
 827
 828   $self->{SESSION} ||= { };
 829
 830   while (@params) {
 831     my $key = shift @params;
 832
 833     if (ref $key eq 'HASH') {
 834       $self->{SESSION}->{ $key->{key} } = SL::Auth::SessionValue->new(key          => $key->{key},
 835                                                                       value        => $key->{value},
 836                                                                       auto_restore => $key->{auto_restore});
 837
 838     } else {
 839       my $value = shift @params;
 840       $self->{SESSION}->{ $key } = SL::Auth::SessionValue->new(key   => $key,
 841                                                                value => $value);
 842     }
 843   }
 844
 845   $main::lxdebug->leave_sub();
 846
 847   return $self;
 848 }
 849
 850 sub delete_session_value {
 851   $main::lxdebug->enter_sub();
 852
 853   my $self = shift;
 854
 855   $self->{SESSION} ||= { };
 856   delete @{ $self->{SESSION} }{ @_ };
 857
 858   $main::lxdebug->leave_sub();
 859
 860   return $self;
 861 }
 862
 863 sub get_session_value {
 864   $main::lxdebug->enter_sub();
 865
 866   my $self = shift;
 867   my $data = $self->{SESSION} && $self->{SESSION}->{ $_[0] } ? $self->{SESSION}->{ $_[0] }->get : undef;
 868
 869   $main::lxdebug->leave_sub();
 870
 871   return $data;
 872 }
 873
 874 sub create_unique_sesion_value {
 875   my ($self, $value, %params) = @_;
 876
 877   $self->{SESSION} ||= { };
 878
 879   my @now                   = gettimeofday();
 880   my $key                   = "$$-" . ($now[0] * 1000000 + $now[1]) . "-";
 881   $self->{unique_counter} ||= 0;
 882
 883   my $hashed_key;
 884   do {
 885     $self->{unique_counter}++;
 886     $hashed_key = md5_hex($key . $self->{unique_counter});
 887   } while (exists $self->{SESSION}->{$hashed_key});
 888
 889   $self->set_session_value($hashed_key => $value);
 890
 891   return $hashed_key;
 892 }
 893
 894 sub save_form_in_session {
 895   my ($self, %params) = @_;
 896
 897   my $form        = delete($params{form}) || $::form;
 898   my $non_scalars = delete $params{non_scalars};
 899   my $data        = {};
 900
 901   my %skip_keys   = map { ( $_ => 1 ) } (qw(login password stylesheet version titlebar), @{ $params{skip_keys} || [] });
 902
 903   foreach my $key (grep { !$skip_keys{$_} } keys %{ $form }) {
 904     $data->{$key} = $form->{$key} if !ref($form->{$key}) || $non_scalars;
 905   }
 906
 907   return $self->create_unique_sesion_value($data, %params);
 908 }
 909
 910 sub restore_form_from_session {
 911   my ($self, $key, %params) = @_;
 912
 913   my $data = $self->get_session_value($key);
 914   return $self unless $data;
 915
 916   my $form    = delete($params{form}) || $::form;
 917   my $clobber = exists $params{clobber} ? $params{clobber} : 1;
 918
 919   map { $form->{$_} = $data->{$_} if $clobber || !exists $form->{$_} } keys %{ $data };
 920
 921   return $self;
 922 }
 923
 924 sub set_cookie_environment_variable {
 925   my $self = shift;
 926   $ENV{HTTP_COOKIE} = $self->get_session_cookie_name() . "=${session_id}";
 927 }
 928
 929 sub get_session_cookie_name {
 930   my $self = shift;
 931
 932   return $self->{cookie_name} || 'lx_office_erp_session_id';
 933 }
 934
 935 sub get_session_id {
 936   return $session_id;
 937 }
 938
 939 sub session_tables_present {
 940   $main::lxdebug->enter_sub();
 941
 942   my $self = shift;
 943
 944   # Only re-check for the presence of auth tables if either the check
 945   # hasn't been done before of if they weren't present.
 946   if ($self->{session_tables_present}) {
 947     $main::lxdebug->leave_sub();
 948     return $self->{session_tables_present};
 949   }
 950
 951   my $dbh  = $self->dbconnect(1);
 952
 953   if (!$dbh) {
 954     $main::lxdebug->leave_sub();
 955     return 0;
 956   }
 957
 958   my $query =
 959     qq|SELECT COUNT(*)
 960        FROM pg_tables
 961        WHERE (schemaname = 'auth')
 962          AND (tablename IN ('session', 'session_content'))|;
 963
 964   my ($count) = selectrow_query($main::form, $dbh, $query);
 965
 966   $self->{session_tables_present} = 2 == $count;
 967
 968   $main::lxdebug->leave_sub();
 969
 970   return $self->{session_tables_present};
 971 }
 972
 973 # --------------------------------------
 974
 975 sub all_rights_full {
 976   my $locale = $main::locale;
 977
 978   my @all_rights = (
 979     ["--crm",                          $locale->text("CRM optional software")],
 980     ["crm_search",                     $locale->text("CRM search")],
 981     ["crm_new",                        $locale->text("CRM create customers, vendors and contacts")],
 982     ["crm_service",                    $locale->text("CRM services")],
 983     ["crm_admin",                      $locale->text("CRM admin")],
 984     ["crm_adminuser",                  $locale->text("CRM user")],
 985     ["crm_adminstatus",                $locale->text("CRM status")],
 986     ["crm_email",                      $locale->text("CRM send email")],
 987     ["crm_termin",                     $locale->text("CRM termin")],
 988     ["crm_opportunity",                $locale->text("CRM opportunity")],
 989     ["crm_knowhow",                    $locale->text("CRM know how")],
 990     ["crm_follow",                     $locale->text("CRM follow up")],
 991     ["crm_notices",                    $locale->text("CRM notices")],
 992     ["crm_other",                      $locale->text("CRM other")],
 993     ["--master_data",                  $locale->text("Master Data")],
 994     ["customer_vendor_edit",           $locale->text("Create customers and vendors. Edit all vendors. Edit only customers where salesman equals employee (login)")],
 995     ["customer_vendor_all_edit",       $locale->text("Create customers and vendors. Edit all vendors. Edit all customers")],
 996     ["part_service_assembly_edit",     $locale->text("Create and edit parts, services, assemblies")],
 997     ["project_edit",                   $locale->text("Create and edit projects")],
 998     ["--ar",                           $locale->text("AR")],
 999     ["sales_quotation_edit",           $locale->text("Create and edit sales quotations")],
1000     ["sales_order_edit",               $locale->text("Create and edit sales orders")],
1001     ["sales_delivery_order_edit",      $locale->text("Create and edit sales delivery orders")],
1002     ["invoice_edit",                   $locale->text("Create and edit invoices and credit notes")],
1003     ["dunning_edit",                   $locale->text("Create and edit dunnings")],
1004     ["sales_all_edit",                 $locale->text("View/edit all employees sales documents")],
1005     ["edit_prices",                    $locale->text("Edit prices and discount (if not used, textfield is ONLY set readonly)")],
1006     ["--ap",                           $locale->text("AP")],
1007     ["request_quotation_edit",         $locale->text("Create and edit RFQs")],
1008     ["purchase_order_edit",            $locale->text("Create and edit purchase orders")],
1009     ["purchase_delivery_order_edit",   $locale->text("Create and edit purchase delivery orders")],
1010     ["vendor_invoice_edit",            $locale->text("Create and edit vendor invoices")],
1011     ["--warehouse_management",         $locale->text("Warehouse management")],
1012     ["warehouse_contents",             $locale->text("View warehouse content")],
1013     ["warehouse_management",           $locale->text("Warehouse management")],
1014     ["--general_ledger_cash",          $locale->text("General ledger and cash")],
1015     ["general_ledger",                 $locale->text("Transactions, AR transactions, AP transactions")],
1016     ["datev_export",                   $locale->text("DATEV Export")],
1017     ["cash",                           $locale->text("Receipt, payment, reconciliation")],
1018     ["--reports",                      $locale->text('Reports')],
1019     ["report",                         $locale->text('All reports')],
1020     ["advance_turnover_tax_return",    $locale->text('Advance turnover tax return')],
1021     ["--batch_printing",               $locale->text("Batch Printing")],
1022     ["batch_printing",                 $locale->text("Batch Printing")],
1023     ["--others",                       $locale->text("Others")],
1024     ["email_bcc",                      $locale->text("May set the BCC field when sending emails")],
1025     ["config",                         $locale->text("Change Lx-Office installation settings (all menu entries beneath 'System')")],
1026     ["admin",                          $locale->text("Administration (Used to access instance administration from user logins)")],
1027     );
1028
1029   return @all_rights;
1030 }
1031
1032 sub all_rights {
1033   return grep !/^--/, map { $_->[0] } all_rights_full();
1034 }
1035
1036 sub read_groups {
1037   $main::lxdebug->enter_sub();
1038
1039   my $self = shift;
1040
1041   my $form   = $main::form;
1042   my $groups = {};
1043   my $dbh    = $self->dbconnect();
1044
1045   my $query  = 'SELECT * FROM auth."group"';
1046   my $sth    = prepare_execute_query($form, $dbh, $query);
1047
1048   my ($row, $group);
1049
1050   while ($row = $sth->fetchrow_hashref()) {
1051     $groups->{$row->{id}} = $row;
1052   }
1053   $sth->finish();
1054
1055   $query = 'SELECT * FROM auth.user_group WHERE group_id = ?';
1056   $sth   = prepare_query($form, $dbh, $query);
1057
1058   foreach $group (values %{$groups}) {
1059     my @members;
1060
1061     do_statement($form, $sth, $query, $group->{id});
1062
1063     while ($row = $sth->fetchrow_hashref()) {
1064       push @members, $row->{user_id};
1065     }
1066     $group->{members} = [ uniq @members ];
1067   }
1068   $sth->finish();
1069
1070   $query = 'SELECT * FROM auth.group_rights WHERE group_id = ?';
1071   $sth   = prepare_query($form, $dbh, $query);
1072
1073   foreach $group (values %{$groups}) {
1074     $group->{rights} = {};
1075
1076     do_statement($form, $sth, $query, $group->{id});
1077
1078     while ($row = $sth->fetchrow_hashref()) {
1079       $group->{rights}->{$row->{right}} |= $row->{granted};
1080     }
1081
1082     map { $group->{rights}->{$_} = 0 if (!defined $group->{rights}->{$_}); } all_rights();
1083   }
1084   $sth->finish();
1085
1086   $main::lxdebug->leave_sub();
1087
1088   return $groups;
1089 }
1090
1091 sub save_group {
1092   $main::lxdebug->enter_sub();
1093
1094   my $self  = shift;
1095   my $group = shift;
1096
1097   my $form  = $main::form;
1098   my $dbh   = $self->dbconnect();
1099
1100   $dbh->begin_work;
1101
1102   my ($query, $sth, $row, $rights);
1103
1104   if (!$group->{id}) {
1105     ($group->{id}) = selectrow_query($form, $dbh, qq|SELECT nextval('auth.group_id_seq')|);
1106
1107     $query = qq|INSERT INTO auth."group" (id, name, description) VALUES (?, '', '')|;
1108     do_query($form, $dbh, $query, $group->{id});
1109   }
1110
1111   do_query($form, $dbh, qq|UPDATE auth."group" SET name = ?, description = ? WHERE id = ?|, map { $group->{$_} } qw(name description id));
1112
1113   do_query($form, $dbh, qq|DELETE FROM auth.user_group WHERE group_id = ?|, $group->{id});
1114
1115   $query  = qq|INSERT INTO auth.user_group (user_id, group_id) VALUES (?, ?)|;
1116   $sth    = prepare_query($form, $dbh, $query);
1117
1118   foreach my $user_id (uniq @{ $group->{members} }) {
1119     do_statement($form, $sth, $query, $user_id, $group->{id});
1120   }
1121   $sth->finish();
1122
1123   do_query($form, $dbh, qq|DELETE FROM auth.group_rights WHERE group_id = ?|, $group->{id});
1124
1125   $query = qq|INSERT INTO auth.group_rights (group_id, "right", granted) VALUES (?, ?, ?)|;
1126   $sth   = prepare_query($form, $dbh, $query);
1127
1128   foreach my $right (keys %{ $group->{rights} }) {
1129     do_statement($form, $sth, $query, $group->{id}, $right, $group->{rights}->{$right} ? 't' : 'f');
1130   }
1131   $sth->finish();
1132
1133   $dbh->commit();
1134
1135   $main::lxdebug->leave_sub();
1136 }
1137
1138 sub delete_group {
1139   $main::lxdebug->enter_sub();
1140
1141   my $self = shift;
1142   my $id   = shift;
1143
1144   my $form = $main::form;
1145
1146   my $dbh  = $self->dbconnect();
1147   $dbh->begin_work;
1148
1149   do_query($form, $dbh, qq|DELETE FROM auth.user_group WHERE group_id = ?|, $id);
1150   do_query($form, $dbh, qq|DELETE FROM auth.group_rights WHERE group_id = ?|, $id);
1151   do_query($form, $dbh, qq|DELETE FROM auth."group" WHERE id = ?|, $id);
1152
1153   $dbh->commit();
1154
1155   $main::lxdebug->leave_sub();
1156 }
1157
1158 sub evaluate_rights_ary {
1159   $main::lxdebug->enter_sub(2);
1160
1161   my $ary    = shift;
1162
1163   my $value  = 0;
1164   my $action = '|';
1165
1166   foreach my $el (@{$ary}) {
1167     if (ref $el eq "ARRAY") {
1168       if ($action eq '|') {
1169         $value |= evaluate_rights_ary($el);
1170       } else {
1171         $value &= evaluate_rights_ary($el);
1172       }
1173
1174     } elsif (($el eq '&') || ($el eq '|')) {
1175       $action = $el;
1176
1177     } elsif ($action eq '|') {
1178       $value |= $el;
1179
1180     } else {
1181       $value &= $el;
1182
1183     }
1184   }
1185
1186   $main::lxdebug->leave_sub(2);
1187
1188   return $value;
1189 }
1190
1191 sub _parse_rights_string {
1192   $main::lxdebug->enter_sub(2);
1193
1194   my $self   = shift;
1195
1196   my $login  = shift;
1197   my $access = shift;
1198
1199   my @stack;
1200   my $cur_ary = [];
1201
1202   push @stack, $cur_ary;
1203
1204   while ($access =~ m/^([a-z_0-9]+|\||\&|\(|\)|\s+)/) {
1205     my $token = $1;
1206     substr($access, 0, length $1) = "";
1207
1208     next if ($token =~ /\s/);
1209
1210     if ($token eq "(") {
1211       my $new_cur_ary = [];
1212       push @stack, $new_cur_ary;
1213       push @{$cur_ary}, $new_cur_ary;
1214       $cur_ary = $new_cur_ary;
1215
1216     } elsif ($token eq ")") {
1217       pop @stack;
1218
1219       if (!@stack) {
1220         $main::lxdebug->leave_sub(2);
1221         return 0;
1222       }
1223
1224       $cur_ary = $stack[-1];
1225
1226     } elsif (($token eq "|") || ($token eq "&")) {
1227       push @{$cur_ary}, $token;
1228
1229     } else {
1230       push @{$cur_ary}, $self->{RIGHTS}->{$login}->{$token} * 1;
1231     }
1232   }
1233
1234   my $result = ($access || (1 < scalar @stack)) ? 0 : evaluate_rights_ary($stack[0]);
1235
1236   $main::lxdebug->leave_sub(2);
1237
1238   return $result;
1239 }
1240
1241 sub check_right {
1242   $main::lxdebug->enter_sub(2);
1243
1244   my $self    = shift;
1245   my $login   = shift;
1246   my $right   = shift;
1247   my $default = shift;
1248
1249   $self->{FULL_RIGHTS}           ||= { };
1250   $self->{FULL_RIGHTS}->{$login} ||= { };
1251
1252   if (!defined $self->{FULL_RIGHTS}->{$login}->{$right}) {
1253     $self->{RIGHTS}           ||= { };
1254     $self->{RIGHTS}->{$login} ||= $self->load_rights_for_user($login);
1255
1256     $self->{FULL_RIGHTS}->{$login}->{$right} = $self->_parse_rights_string($login, $right);
1257   }
1258
1259   my $granted = $self->{FULL_RIGHTS}->{$login}->{$right};
1260   $granted    = $default if (!defined $granted);
1261
1262   $main::lxdebug->leave_sub(2);
1263
1264   return $granted;
1265 }
1266
1267 sub assert {
1268   $::lxdebug->enter_sub(2);
1269   my ($self, $right, $dont_abort) = @_;
1270
1271   if ($self->check_right($::myconfig{login}, $right)) {
1272     $::lxdebug->leave_sub(2);
1273     return 1;
1274   }
1275
1276   if (!$dont_abort) {
1277     delete $::form->{title};
1278     $::form->show_generic_error($::locale->text("You do not have the permissions to access this function."));
1279   }
1280
1281   $::lxdebug->leave_sub(2);
1282
1283   return 0;
1284 }
1285
1286 sub load_rights_for_user {
1287   $::lxdebug->enter_sub;
1288
1289   my ($self, $login) = @_;
1290   my $dbh   = $self->dbconnect;
1291   my ($query, $sth, $row, $rights);
1292
1293   $rights = { map { $_ => 0 } all_rights() };
1294
1295   $query =
1296     qq|SELECT gr."right", gr.granted
1297        FROM auth.group_rights gr
1298        WHERE group_id IN
1299          (SELECT ug.group_id
1300           FROM auth.user_group ug
1301           LEFT JOIN auth."user" u ON (ug.user_id = u.id)
1302           WHERE u.login = ?)|;
1303
1304   $sth = prepare_execute_query($::form, $dbh, $query, $login);
1305
1306   while ($row = $sth->fetchrow_hashref()) {
1307     $rights->{$row->{right}} |= $row->{granted};
1308   }
1309   $sth->finish();
1310
1311   $::lxdebug->leave_sub;
1312
1313   return $rights;
1314 }
1315
1316 1;
1317 __END__
1318
1319 =pod
1320
1321 =encoding utf8
1322
1323 =head1 NAME
1324
1325 SL::Auth - Authentication and session handling
1326
1327 =head1 FUNCTIONS
1328
1329 =over 4
1330
1331 =item C<set_session_value @values>
1332
1333 =item C<set_session_value %values>
1334
1335 Store all values of C<@values> or C<%values> in the session. Each
1336 member of C<@values> is tested if it is a hash reference. If it is
1337 then it must contain the keys C<key> and C<value> and can optionally
1338 contain the key C<auto_restore>. In this case C<value> is associated
1339 with C<key> and restored to C<$::form> upon the next request
1340 automatically if C<auto_restore> is trueish or if C<value> is a scalar
1341 value.
1342
1343 If the current member of C<@values> is not a hash reference then it
1344 will be used as the C<key> and the next entry of C<@values> is used as
1345 the C<value> to store. In this case setting C<auto_restore> is not
1346 possible.
1347
1348 Therefore the following two invocations are identical:
1349
1350   $::auth-E<gt>set_session_value(name =E<gt> "Charlie");
1351   $::auth-E<gt>set_session_value({ key =E<gt> "name", value =E<gt> "Charlie" });
1352
1353 All of these values are copied back into C<$::form> for the next
1354 request automatically if they're scalar values or if they have
1355 C<auto_restore> set to trueish.
1356
1357 The values can be any Perl structure. They are stored as YAML dumps.
1358
1359 =item C<get_session_value $key>
1360
1361 Retrieve a value from the session. Returns C<undef> if the value
1362 doesn't exist.
1363
1364 =item C<create_unique_sesion_value $value, %params>
1365
1366 Create a unique key in the session and store C<$value>
1367 there.
1368
1369 Returns the key created in the session.
1370
1371 =item C<save_session>
1372
1373 Stores the session values in the database. This is the only function
1374 that actually stores stuff in the database. Neither the various
1375 setters nor the deleter access the database.
1376
1377 =item <save_form_in_session %params>
1378
1379 Stores the content of C<$params{form}> (default: C<$::form>) in the
1380 session using L</create_unique_sesion_value>.
1381
1382 If C<$params{non_scalars}> is trueish then non-scalar values will be
1383 stored as well. Default is to only store scalar values.
1384
1385 The following keys will never be saved: C<login>, C<password>,
1386 C<stylesheet>, C<titlebar>, C<version>. Additional keys not to save
1387 can be given as an array ref in C<$params{skip_keys}>.
1388
1389 Returns the unique key under which the form is stored.
1390
1391 =item <restore_form_from_session $key, %params>
1392
1393 Restores the form from the session into C<$params{form}> (default:
1394 C<$::form>).
1395
1396 If C<$params{clobber}> is falsish then existing values with the same
1397 key in C<$params{form}> will not be overwritten. C<$params{clobber}>
1398 is on by default.
1399
1400 Returns C<$self>.
1401
1402 =back
1403
1404 =head1 BUGS
1405
1406 Nothing here yet.
1407
1408 =head1 AUTHOR
1409
1410 Moritz Bunkus E<lt>m.bunkus@linet-services.deE<gt>
1411
1412 =cut