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