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