View | Details | Raw Unified | Return to bug 7174
Collapse All | Expand All

(-)a/C4/Auth.pm (-81 / +200 lines)
Lines 19-25 package C4::Auth; Link Here
19
19
20
use strict;
20
use strict;
21
use warnings;
21
use warnings;
22
use Digest::MD5 qw(md5_base64);
22
use Digest::MD5 qw(md5_base64); #@DEPRECATED Digest::MD5, don't use it or you will get hurt.
23
use JSON qw/encode_json/;
23
use JSON qw/encode_json/;
24
use URI::Escape;
24
use URI::Escape;
25
use CGI::Session;
25
use CGI::Session;
Lines 34-39 use C4::Branch; # GetBranches Link Here
34
use C4::Search::History;
34
use C4::Search::History;
35
use Koha;
35
use Koha;
36
use Koha::AuthUtils qw(hash_password);
36
use Koha::AuthUtils qw(hash_password);
37
use Koha::Auth;
38
use Koha::Auth::Challenge::OPACMaintenance;
39
use Koha::Auth::Challenge::Version;
37
use POSIX qw/strftime/;
40
use POSIX qw/strftime/;
38
use List::MoreUtils qw/ any /;
41
use List::MoreUtils qw/ any /;
39
use Encode qw( encode is_utf8);
42
use Encode qw( encode is_utf8);
Lines 317-322 sub get_template_and_user { Link Here
317
                # clear out the search history from the session now that
320
                # clear out the search history from the session now that
318
                # we've saved it to the database
321
                # we've saved it to the database
319
                C4::Search::History::set_to_session( { cgi => $in->{'query'}, search_history => [] } );
322
                C4::Search::History::set_to_session( { cgi => $in->{'query'}, search_history => [] } );
323
324
                #If the user didn't have any search history on his account prior to entering here,
325
                #Make sure the anonymous search history counts.
326
                $template->param( EnableOpacSearchHistory => 1 );
320
            }
327
            }
321
        } elsif ( $in->{type} eq 'intranet' and C4::Context->preference('EnableSearchHistory') ) {
328
        } elsif ( $in->{type} eq 'intranet' and C4::Context->preference('EnableSearchHistory') ) {
322
            $template->param( EnableSearchHistory => 1 );
329
            $template->param( EnableSearchHistory => 1 );
Lines 636-685 has authenticated. Link Here
636
643
637
=cut
644
=cut
638
645
646
=head _version_check
647
#@DEPRECATED See Bug 7174
648
use Koha::Auth::Challenge::* instead
649
=cut
650
639
sub _version_check {
651
sub _version_check {
652
    #@DEPRECATED See Bug 7174
640
    my $type  = shift;
653
    my $type  = shift;
641
    my $query = shift;
654
    my $query = shift;
642
    my $version;
655
    my $version;
643
656
644
    # If version syspref is unavailable, it means Koha is being installed,
657
    try {
645
    # and so we must redirect to OPAC maintenance page or to the WebInstaller
658
        Koha::Auth::Challenge::OPACMaintenance::challenge() if ( $type eq 'opac' );
646
    # also, if OpacMaintenance is ON, OPAC should redirect to maintenance
659
        Koha::Auth::Challenge::Version::challenge();
647
    if ( C4::Context->preference('OpacMaintenance') && $type eq 'opac' ) {
660
    } catch {
648
        warn "OPAC Install required, redirecting to maintenance";
661
        if (blessed($_)) {
649
        print $query->redirect("/cgi-bin/koha/maintenance.pl");
662
            if ($_->isa('Koha::Exception::VersionMismatch')) {
650
        safe_exit;
663
                # check that database and koha version are the same
651
    }
664
                # there is no DB version, it's a fresh install,
652
    unless ( $version = C4::Context->preference('Version') ) {    # assignment, not comparison
665
                # go to web installer
653
        if ( $type ne 'opac' ) {
666
                # there is a DB version, compare it to the code version
654
            warn "Install required, redirecting to Installer";
667
                my $warning = $_->error()." Redirecting to %s.";
655
            print $query->redirect("/cgi-bin/koha/installer/install.pl");
668
                if ( $type ne 'opac' ) {
656
        } else {
669
                    warn sprintf( $warning, 'Installer' );
657
            warn "OPAC Install required, redirecting to maintenance";
670
                    print $query->redirect("/cgi-bin/koha/installer/install.pl?step=1&op=updatestructure");
658
            print $query->redirect("/cgi-bin/koha/maintenance.pl");
671
                } else {
672
                    warn sprintf( "OPAC: " . $warning, 'maintenance' );
673
                    print $query->redirect("/cgi-bin/koha/maintenance.pl");
674
                }
675
                safe_exit;
676
            }
677
            elsif ($_->isa('Koha::Exception::ServiceTemporarilyUnavailable')) {
678
                # also, if OpacMaintenance is ON, OPAC should redirect to maintenance
679
                warn "OPAC Install required, redirecting to maintenance";
680
                print $query->redirect("/cgi-bin/koha/maintenance.pl");
681
                safe_exit;
682
            }
683
            elsif ($_->isa('Koha::Exception::BadSystemPreference')) {
684
                # If version syspref is unavailable, it means Koha is being installed,
685
                # and so we must redirect to OPAC maintenance page or to the WebInstaller
686
                if ( $type ne 'opac' ) {
687
                    warn "Install required, redirecting to Installer";
688
                    print $query->redirect("/cgi-bin/koha/installer/install.pl");
689
                } else {
690
                    warn "OPAC Install required, redirecting to maintenance";
691
                    print $query->redirect("/cgi-bin/koha/maintenance.pl");
692
                }
693
                safe_exit;
694
            }
695
            else {
696
                warn "Unknown exception class ".ref($_)."\n";
697
                die $_->rethrow(); #Unhandled exception case
698
            }
659
        }
699
        }
660
        safe_exit;
700
        else {
661
    }
701
            die $_; #Not a Koha::Exception-object, so rethrow it
662
663
    # check that database and koha version are the same
664
    # there is no DB version, it's a fresh install,
665
    # go to web installer
666
    # there is a DB version, compare it to the code version
667
    my $kohaversion = Koha::version();
668
669
    # remove the 3 last . to have a Perl number
670
    $kohaversion =~ s/(.*\..*)\.(.*)\.(.*)/$1$2$3/;
671
    $debug and print STDERR "kohaversion : $kohaversion\n";
672
    if ( $version < $kohaversion ) {
673
        my $warning = "Database update needed, redirecting to %s. Database is $version and Koha is $kohaversion";
674
        if ( $type ne 'opac' ) {
675
            warn sprintf( $warning, 'Installer' );
676
            print $query->redirect("/cgi-bin/koha/installer/install.pl?step=1&op=updatestructure");
677
        } else {
678
            warn sprintf( "OPAC: " . $warning, 'maintenance' );
679
            print $query->redirect("/cgi-bin/koha/maintenance.pl");
680
        }
702
        }
681
        safe_exit;
703
    };
682
    }
683
}
704
}
684
705
685
sub _session_log {
706
sub _session_log {
Lines 699-705 sub _timeout_syspref { Link Here
699
    return $timeout;
720
    return $timeout;
700
}
721
}
701
722
723
=head checkauth
724
725
Compatibility layer for old Koha authentication system.
726
Tries to authenticate using Koha::Auth, but if no authentication mechanism is
727
identified, falls back to the deprecated legacy behaviour.
728
=cut
729
702
sub checkauth {
730
sub checkauth {
731
    my @params = @_; #Clone params so we don't accidentally change them if we fallback to checkauth_legacy()
732
    my $query = shift;
733
    my $authnotrequired = shift;
734
    my $flagsrequired   = _changeAllPermissionsMarkerToAnyPermissionMarker(shift); #circulate => 1 is deprecated, only circulate => '*' is supported.
735
    my $type            = shift;
736
    my $persona         = shift;
737
738
    ##Revert to legacy authentication for more complex authentication mechanisms.
739
    if ($persona && $cas && $shib) {
740
        return checkauth_legacy(@params);
741
    }
742
743
    my ($borrower, $cookie);
744
    try {
745
        ($borrower, $cookie) = Koha::Auth::authenticate($query, $flagsrequired, {authnotrequired => $authnotrequired});
746
    } catch {
747
        if (blessed($_)) {
748
            if ($_->isa('Koha::Exception::VersionMismatch')) {
749
750
                my $warning = $_->error()." Redirecting to %s.";
751
                if ( $type ne 'opac' ) {
752
                    warn sprintf( $warning, 'Installer' );
753
                    print $query->redirect("/cgi-bin/koha/installer/install.pl?step=1&op=updatestructure");
754
                } else {
755
                    warn sprintf( "OPAC: " . $warning, 'maintenance' );
756
                    print $query->redirect("/cgi-bin/koha/maintenance.pl");
757
                }
758
                safe_exit;
759
760
            }
761
            elsif ($_->isa('Koha::Exception::BadSystemPreference')) {
762
763
                if ( $type ne 'opac' ) {
764
                    warn $_->error()." Redirecting to installer.";
765
                    print $query->redirect("/cgi-bin/koha/installer/install.pl");
766
                } else {
767
                    warn $_->error()." Redirecting to maintenance.";
768
                    print $query->redirect("/cgi-bin/koha/maintenance.pl");
769
                }
770
                safe_exit;
771
772
            }
773
            elsif ($_->isa('Koha::Exception::LoginFailed')) {
774
                _showLoginPage($query, $type, $query->cookie(-name => 'CGISESSID'), {invalid_username_or_password => 1}, undef);
775
            }
776
            elsif ($_->isa('Koha::Exception::NoPermission')) {
777
                _showLoginPage($query, $type, $query->cookie(-name => 'CGISESSID'), {nopermission => 1}, undef);
778
            }
779
            elsif ($_->isa('Koha::Exception::Logout')) {
780
                _showLoginPage($query, $type, $query->cookie(-name => 'CGISESSID'), {}, undef);
781
            }
782
            elsif ($_->isa('Koha::Exception::ServiceTemporarilyUnavailable')) {
783
                warn $_->error();
784
                print $query->redirect("/cgi-bin/koha/maintenance.pl");
785
                safe_exit;
786
            }
787
            else {
788
                warn "Unknown exception class ".ref($_)."\n";
789
                $_->rethrow(); #Unhandled exception case
790
            }
791
        }
792
        else {
793
            die $_; #Not a Koha::Exception-object
794
        }
795
    };
796
797
    if ($borrower) { #We authenticated succesfully! Emulate the legacy interface for get_template_and_user();
798
        my $user = $borrower->userid;
799
        my $sessionID = $cookie->{value}->[0];
800
        my $aa = $borrower->userid;
801
        my $flags = getuserflags(undef, $borrower->userid, undef) if $borrower->userid;
802
        return ( $user, $cookie, $sessionID, $flags );
803
    }
804
}
805
806
=head checkauth_legacy
807
@DEPRECATED See Bug 7174
808
809
We are calling this because the given authentication mechanism is not yet supported
810
in Koha::Auth.
811
812
See checkauth-documentation floating somewhere in this file for info about the
813
legacy authentication.
814
=cut
815
816
sub checkauth_legacy {
817
    #@DEPRECATED See Bug 7174
703
    my $query = shift;
818
    my $query = shift;
704
    $debug and warn "Checking Auth";
819
    $debug and warn "Checking Auth";
705
820
Lines 989-995 sub checkauth { Link Here
989
                    $info{'nopermission'} = 1;
1104
                    $info{'nopermission'} = 1;
990
                    C4::Context->_unset_userenv($sessionID);
1105
                    C4::Context->_unset_userenv($sessionID);
991
                }
1106
                }
992
                my ( $borrowernumber, $firstname, $surname, $userflags,
1107
                my ( $borrowernumber, $firstname, $surname,
993
                    $branchcode, $branchname, $branchprinter, $emailaddress );
1108
                    $branchcode, $branchname, $branchprinter, $emailaddress );
994
1109
995
                if ( $return == 1 ) {
1110
                if ( $return == 1 ) {
Lines 1020-1026 sub checkauth { Link Here
1020
                        ( $borrowernumber, $firstname, $surname,
1135
                        ( $borrowernumber, $firstname, $surname,
1021
                            $branchcode, $branchname, $branchprinter, $emailaddress ) = $sth->fetchrow;
1136
                            $branchcode, $branchname, $branchprinter, $emailaddress ) = $sth->fetchrow;
1022
                        $debug and print STDERR "AUTH_3 results: " .
1137
                        $debug and print STDERR "AUTH_3 results: " .
1023
                          "$cardnumber,$borrowernumber,$userid,$firstname,$surname,$userflags,$branchcode,$emailaddress\n";
1138
                          "$cardnumber,$borrowernumber,$userid,$firstname,$surname,$branchcode,$emailaddress\n";
1024
                    } else {
1139
                    } else {
1025
                        print STDERR "AUTH_3: no results for userid='$userid', cardnumber='$cardnumber'.\n";
1140
                        print STDERR "AUTH_3: no results for userid='$userid', cardnumber='$cardnumber'.\n";
1026
                    }
1141
                    }
Lines 1036-1042 sub checkauth { Link Here
1036
                        $branchname = GetBranchName($branchcode);
1151
                        $branchname = GetBranchName($branchcode);
1037
                    }
1152
                    }
1038
                    my $branches = GetBranches();
1153
                    my $branches = GetBranches();
1039
                    if ( C4::Context->boolean_preference('IndependentBranches') && C4::Context->boolean_preference('Autolocation') ) {
1154
                    if ( C4::Context->boolean_preference('IndependentBranches') && C4::Context->boolean_preference('Autolocation') ) { #Why Autolocation cannot work without IndependetBranches??
1040
1155
1041
                        # we have to check they are coming from the right ip range
1156
                        # we have to check they are coming from the right ip range
1042
                        my $domain = $branches->{$branchcode}->{'branchip'};
1157
                        my $domain = $branches->{$branchcode}->{'branchip'};
Lines 1066-1072 sub checkauth { Link Here
1066
                    $session->param( 'surname',      $surname );
1181
                    $session->param( 'surname',      $surname );
1067
                    $session->param( 'branch',       $branchcode );
1182
                    $session->param( 'branch',       $branchcode );
1068
                    $session->param( 'branchname',   $branchname );
1183
                    $session->param( 'branchname',   $branchname );
1069
                    $session->param( 'flags',        $userflags );
1070
                    $session->param( 'emailaddress', $emailaddress );
1184
                    $session->param( 'emailaddress', $emailaddress );
1071
                    $session->param( 'ip',           $session->remote_addr() );
1185
                    $session->param( 'ip',           $session->remote_addr() );
1072
                    $session->param( 'lasttime',     time() );
1186
                    $session->param( 'lasttime',     time() );
Lines 1149-1154 sub checkauth { Link Here
1149
    #
1263
    #
1150
1264
1151
    # get the inputs from the incoming query
1265
    # get the inputs from the incoming query
1266
    _showLoginPage($query, $type, $cookie, \%info, $casparam);
1267
}
1268
1269
sub _showLoginPage {
1270
    my ($query, $type, $cookie, $info, $casparam) = @_;
1271
1152
    my @inputs = ();
1272
    my @inputs = ();
1153
    foreach my $name ( param $query) {
1273
    foreach my $name ( param $query) {
1154
        (next) if ( $name eq 'userid' || $name eq 'password' || $name eq 'ticket' );
1274
        (next) if ( $name eq 'userid' || $name eq 'password' || $name eq 'ticket' );
Lines 1200-1206 sub checkauth { Link Here
1200
        IntranetUserJS                        => C4::Context->preference("IntranetUserJS"),
1320
        IntranetUserJS                        => C4::Context->preference("IntranetUserJS"),
1201
        IndependentBranches                   => C4::Context->preference("IndependentBranches"),
1321
        IndependentBranches                   => C4::Context->preference("IndependentBranches"),
1202
        AutoLocation                          => C4::Context->preference("AutoLocation"),
1322
        AutoLocation                          => C4::Context->preference("AutoLocation"),
1203
        wrongip                               => $info{'wrongip'},
1323
        wrongip                               => $info->{'wrongip'},
1204
        PatronSelfRegistration                => C4::Context->preference("PatronSelfRegistration"),
1324
        PatronSelfRegistration                => C4::Context->preference("PatronSelfRegistration"),
1205
        PatronSelfRegistrationDefaultCategory => C4::Context->preference("PatronSelfRegistrationDefaultCategory"),
1325
        PatronSelfRegistrationDefaultCategory => C4::Context->preference("PatronSelfRegistrationDefaultCategory"),
1206
        persona                               => C4::Context->preference("Persona"),
1326
        persona                               => C4::Context->preference("Persona"),
Lines 1208-1214 sub checkauth { Link Here
1208
    );
1328
    );
1209
1329
1210
    $template->param( OpacPublic => C4::Context->preference("OpacPublic") );
1330
    $template->param( OpacPublic => C4::Context->preference("OpacPublic") );
1211
    $template->param( loginprompt => 1 ) unless $info{'nopermission'};
1331
    $template->param( loginprompt => 1 ) unless $info->{'nopermission'};
1212
1332
1213
    if ( $type eq 'opac' ) {
1333
    if ( $type eq 'opac' ) {
1214
        require C4::VirtualShelves;
1334
        require C4::VirtualShelves;
Lines 1238-1244 sub checkauth { Link Here
1238
        }
1358
        }
1239
1359
1240
        $template->param(
1360
        $template->param(
1241
            invalidCasLogin => $info{'invalidCasLogin'}
1361
            invalidCasLogin => $info->{'invalidCasLogin'}
1242
        );
1362
        );
1243
    }
1363
    }
1244
1364
Lines 1254-1260 sub checkauth { Link Here
1254
        url         => $self_url,
1374
        url         => $self_url,
1255
        LibraryName => C4::Context->preference("LibraryName"),
1375
        LibraryName => C4::Context->preference("LibraryName"),
1256
    );
1376
    );
1257
    $template->param(%info);
1377
    $template->param(%$info);
1258
1378
1259
    #    $cookie = $query->cookie(CGISESSID => $session->id
1379
    #    $cookie = $query->cookie(CGISESSID => $session->id
1260
    #   );
1380
    #   );
Lines 1268-1273 sub checkauth { Link Here
1268
}
1388
}
1269
1389
1270
=head2 check_api_auth
1390
=head2 check_api_auth
1391
@DEPRECATED See Bug 7174
1271
1392
1272
  ($status, $cookie, $sessionId) = check_api_auth($query, $userflags);
1393
  ($status, $cookie, $sessionId) = check_api_auth($query, $userflags);
1273
1394
Lines 1302-1307 Possible return values in C<$status> are: Link Here
1302
=cut
1423
=cut
1303
1424
1304
sub check_api_auth {
1425
sub check_api_auth {
1426
    #@DEPRECATED See Bug 7174
1305
    my $query         = shift;
1427
    my $query         = shift;
1306
    my $flagsrequired = shift;
1428
    my $flagsrequired = shift;
1307
1429
Lines 1433-1449 sub check_api_auth { Link Here
1433
            if ( $return == 1 ) {
1555
            if ( $return == 1 ) {
1434
                my (
1556
                my (
1435
                    $borrowernumber, $firstname,  $surname,
1557
                    $borrowernumber, $firstname,  $surname,
1436
                    $userflags,      $branchcode, $branchname,
1558
                    $branchcode, $branchname,
1437
                    $branchprinter,  $emailaddress
1559
                    $branchprinter,  $emailaddress
1438
                );
1560
                );
1439
                my $sth =
1561
                my $sth =
1440
                  $dbh->prepare(
1562
                  $dbh->prepare(
1441
"select borrowernumber, firstname, surname, flags, borrowers.branchcode, branches.branchname as branchname,branches.branchprinter as branchprinter, email from borrowers left join branches on borrowers.branchcode=branches.branchcode where userid=?"
1563
"select borrowernumber, firstname, surname, borrowers.branchcode, branches.branchname as branchname,branches.branchprinter as branchprinter, email from borrowers left join branches on borrowers.branchcode=branches.branchcode where userid=?"
1442
                  );
1564
                  );
1443
                $sth->execute($userid);
1565
                $sth->execute($userid);
1444
                (
1566
                (
1445
                    $borrowernumber, $firstname,  $surname,
1567
                    $borrowernumber, $firstname,  $surname,
1446
                    $userflags,      $branchcode, $branchname,
1568
                    $branchcode, $branchname,
1447
                    $branchprinter,  $emailaddress
1569
                    $branchprinter,  $emailaddress
1448
                ) = $sth->fetchrow if ( $sth->rows );
1570
                ) = $sth->fetchrow if ( $sth->rows );
1449
1571
Lines 1454-1467 sub check_api_auth { Link Here
1454
                    $sth->execute($cardnumber);
1576
                    $sth->execute($cardnumber);
1455
                    (
1577
                    (
1456
                        $borrowernumber, $firstname,  $surname,
1578
                        $borrowernumber, $firstname,  $surname,
1457
                        $userflags,      $branchcode, $branchname,
1579
                        $branchcode, $branchname,
1458
                        $branchprinter,  $emailaddress
1580
                        $branchprinter,  $emailaddress
1459
                    ) = $sth->fetchrow if ( $sth->rows );
1581
                    ) = $sth->fetchrow if ( $sth->rows );
1460
1582
1461
                    unless ( $sth->rows ) {
1583
                    unless ( $sth->rows ) {
1462
                        $sth->execute($userid);
1584
                        $sth->execute($userid);
1463
                        (
1585
                        (
1464
                            $borrowernumber, $firstname,  $surname,       $userflags,
1586
                            $borrowernumber, $firstname,  $surname,
1465
                            $branchcode,     $branchname, $branchprinter, $emailaddress
1587
                            $branchcode,     $branchname, $branchprinter, $emailaddress
1466
                        ) = $sth->fetchrow if ( $sth->rows );
1588
                        ) = $sth->fetchrow if ( $sth->rows );
1467
                    }
1589
                    }
Lines 1495-1501 sub check_api_auth { Link Here
1495
                $session->param( 'surname',      $surname );
1617
                $session->param( 'surname',      $surname );
1496
                $session->param( 'branch',       $branchcode );
1618
                $session->param( 'branch',       $branchcode );
1497
                $session->param( 'branchname',   $branchname );
1619
                $session->param( 'branchname',   $branchname );
1498
                $session->param( 'flags',        $userflags );
1499
                $session->param( 'emailaddress', $emailaddress );
1620
                $session->param( 'emailaddress', $emailaddress );
1500
                $session->param( 'ip',           $session->remote_addr() );
1621
                $session->param( 'ip',           $session->remote_addr() );
1501
                $session->param( 'lasttime',     time() );
1622
                $session->param( 'lasttime',     time() );
Lines 1529-1534 sub check_api_auth { Link Here
1529
}
1650
}
1530
1651
1531
=head2 check_cookie_auth
1652
=head2 check_cookie_auth
1653
@DEPRECATED See Bug 7174
1532
1654
1533
  ($status, $sessionId) = check_api_auth($cookie, $userflags);
1655
  ($status, $sessionId) = check_api_auth($cookie, $userflags);
1534
1656
Lines 1556-1561 Possible return values in C<$status> are: Link Here
1556
=cut
1678
=cut
1557
1679
1558
sub check_cookie_auth {
1680
sub check_cookie_auth {
1681
    #@DEPRECATED See Bug 7174
1559
    my $cookie        = shift;
1682
    my $cookie        = shift;
1560
    my $flagsrequired = shift;
1683
    my $flagsrequired = shift;
1561
1684
Lines 1679-1690 sub get_session { Link Here
1679
    return $session;
1802
    return $session;
1680
}
1803
}
1681
1804
1805
#@DEPRECATED See Bug 7174
1682
sub checkpw {
1806
sub checkpw {
1683
    my ( $dbh, $userid, $password, $query, $type ) = @_;
1807
    my ( $dbh, $userid, $password, $query, $type ) = @_;
1684
    $type = 'opac' unless $type;
1808
    $type = 'opac' unless $type;
1685
    if ($ldap) {
1809
    if ($ldap) {
1686
        $debug and print STDERR "## checkpw - checking LDAP\n";
1810
        $debug and print STDERR "## checkpw - checking LDAP\n";
1687
        my ( $retval, $retcard, $retuserid ) = checkpw_ldap(@_);    # EXTERNAL AUTH
1811
        my ( $retval, $retcard, $retuserid ) = checkpw_ldap($userid, $password);    # EXTERNAL AUTH
1688
        return 0 if $retval == -1;                                  # Incorrect password for LDAP login attempt
1812
        return 0 if $retval == -1;                                  # Incorrect password for LDAP login attempt
1689
        ($retval) and return ( $retval, $retcard, $retuserid );
1813
        ($retval) and return ( $retval, $retcard, $retuserid );
1690
    }
1814
    }
Lines 1723-1728 sub checkpw { Link Here
1723
    return checkpw_internal(@_)
1847
    return checkpw_internal(@_)
1724
}
1848
}
1725
1849
1850
#@DEPRECATED See Bug 7174
1726
sub checkpw_internal {
1851
sub checkpw_internal {
1727
    my ( $dbh, $userid, $password ) = @_;
1852
    my ( $dbh, $userid, $password ) = @_;
1728
1853
Lines 1748-1760 sub checkpw_internal { Link Here
1748
    $sth->execute($userid);
1873
    $sth->execute($userid);
1749
    if ( $sth->rows ) {
1874
    if ( $sth->rows ) {
1750
        my ( $stored_hash, $cardnumber, $borrowernumber, $userid, $firstname,
1875
        my ( $stored_hash, $cardnumber, $borrowernumber, $userid, $firstname,
1751
            $surname, $branchcode, $branchname, $flags )
1876
            $surname, $branchcode, $branchname )
1752
          = $sth->fetchrow;
1877
          = $sth->fetchrow;
1753
1878
1754
        if ( checkpw_hash( $password, $stored_hash ) ) {
1879
        if ( checkpw_hash( $password, $stored_hash ) ) {
1755
1880
1756
            C4::Context->set_userenv( "$borrowernumber", $userid, $cardnumber,
1881
            C4::Context->set_userenv( "$borrowernumber", $userid, $cardnumber,
1757
                $firstname, $surname, $branchcode, $branchname, $flags );
1882
                $firstname, $surname, $branchcode, $branchname );
1758
            return 1, $cardnumber, $userid;
1883
            return 1, $cardnumber, $userid;
1759
        }
1884
        }
1760
    }
1885
    }
Lines 1775-1780 sub checkpw_internal { Link Here
1775
            return 1, $cardnumber, $userid;
1900
            return 1, $cardnumber, $userid;
1776
        }
1901
        }
1777
    }
1902
    }
1903
1904
    #@DEPRECATED see Bug 7174. I think the demo-user should be represented with permissions instead of a hard-coded non-borrower anomaly.
1778
    if ( $userid && $userid eq 'demo'
1905
    if ( $userid && $userid eq 'demo'
1779
        && "$password" eq 'demo'
1906
        && "$password" eq 'demo'
1780
        && C4::Context->config('demo') )
1907
        && C4::Context->config('demo') )
Lines 1787-1792 sub checkpw_internal { Link Here
1787
    return 0;
1914
    return 0;
1788
}
1915
}
1789
1916
1917
#@DEPRECATED See Bug 7174
1790
sub checkpw_hash {
1918
sub checkpw_hash {
1791
    my ( $password, $stored_hash ) = @_;
1919
    my ( $password, $stored_hash ) = @_;
1792
1920
Lines 1797-1802 sub checkpw_hash { Link Here
1797
    if ( substr( $stored_hash, 0, 2 ) eq '$2' ) {
1925
    if ( substr( $stored_hash, 0, 2 ) eq '$2' ) {
1798
        $hash = hash_password( $password, $stored_hash );
1926
        $hash = hash_password( $password, $stored_hash );
1799
    } else {
1927
    } else {
1928
        #@DEPRECATED Digest::MD5, don't use it or you will get hurt.
1800
        $hash = md5_base64($password);
1929
        $hash = md5_base64($password);
1801
    }
1930
    }
1802
    return $hash eq $stored_hash;
1931
    return $hash eq $stored_hash;
Lines 1820-1826 sub getuserflags { Link Here
1820
    my $flags  = shift;
1949
    my $flags  = shift;
1821
    my $userid = shift;
1950
    my $userid = shift;
1822
    my $dbh    = @_ ? shift : C4::Context->dbh;
1951
    my $dbh    = @_ ? shift : C4::Context->dbh;
1823
    my $userflags;
1824
    {
1952
    {
1825
        # I don't want to do this, but if someone logs in as the database
1953
        # I don't want to do this, but if someone logs in as the database
1826
        # user, it would be preferable not to spam them to death with
1954
        # user, it would be preferable not to spam them to death with
Lines 1829-1856 sub getuserflags { Link Here
1829
        $flags += 0;
1957
        $flags += 0;
1830
    }
1958
    }
1831
    return get_user_subpermissions($userid);
1959
    return get_user_subpermissions($userid);
1832
1833
    #@DEPRECATED, USE THE Koha::Auth::PermissionManager
1834
    my $sth = $dbh->prepare("SELECT bit, flag, defaulton FROM userflags");
1835
    $sth->execute;
1836
1837
    while ( my ( $bit, $flag, $defaulton ) = $sth->fetchrow ) {
1838
        if ( ( $flags & ( 2**$bit ) ) || $defaulton ) {
1839
            $userflags->{$flag} = 1;
1840
        }
1841
        else {
1842
            $userflags->{$flag} = 0;
1843
        }
1844
    }
1845
1846
    # get subpermissions and merge with top-level permissions
1847
    my $user_subperms = get_user_subpermissions($userid);
1848
    foreach my $module ( keys %$user_subperms ) {
1849
        next if $userflags->{$module} == 1;    # user already has permission for everything in this module
1850
        $userflags->{$module} = $user_subperms->{$module};
1851
    }
1852
1853
    return $userflags;
1854
}
1960
}
1855
1961
1856
=head2 get_user_subpermissions
1962
=head2 get_user_subpermissions
Lines 1952-1960 sub haspermission { Link Here
1952
2058
1953
    my $flags = getuserflags( undef, $userid );
2059
    my $flags = getuserflags( undef, $userid );
1954
    #Sanitate 1 to * because we no longer have 1's from the koha.borrowers.flags.
2060
    #Sanitate 1 to * because we no longer have 1's from the koha.borrowers.flags.
1955
    foreach my $module (%$flagsrequired) {
2061
    _changeAllPermissionsMarkerToAnyPermissionMarker($flagsrequired);
1956
        $flagsrequired->{$module} = '*' if $flagsrequired->{$module} && $flagsrequired->{$module} eq '1';
1957
    }
1958
2062
1959
    if ( $userid eq C4::Context->config('user') ) {
2063
    if ( $userid eq C4::Context->config('user') ) {
1960
2064
Lines 1989-1995 sub haspermission { Link Here
1989
    #FIXME - This fcn should return the failed permission so a suitable error msg can be delivered.
2093
    #FIXME - This fcn should return the failed permission so a suitable error msg can be delivered.
1990
}
2094
}
1991
2095
2096
=head
2097
@DEPRECATED
2098
Sanitate 1 to * because we no longer have 1's from the koha.borrowers.flags.
2099
=cut
2100
2101
sub _changeAllPermissionsMarkerToAnyPermissionMarker {
2102
    #@DEPRECATED
2103
    my ($flagsrequired) = @_;
2104
    foreach my $module (%$flagsrequired) {
2105
        $flagsrequired->{$module} = '*' if $flagsrequired->{$module} && $flagsrequired->{$module} eq '1';
2106
    }
2107
    return $flagsrequired;
2108
}
2109
1992
sub getborrowernumber {
2110
sub getborrowernumber {
2111
    #@DEPRECATED See Bug 7174
1993
    my ($userid) = @_;
2112
    my ($userid) = @_;
1994
    my $userenv = C4::Context->userenv;
2113
    my $userenv = C4::Context->userenv;
1995
    if ( defined($userenv) && ref($userenv) eq 'HASH' && $userenv->{number} ) {
2114
    if ( defined($userenv) && ref($userenv) eq 'HASH' && $userenv->{number} ) {
(-)a/C4/Auth_with_ldap.pm (-1 / +10 lines)
Lines 103-110 sub search_method { Link Here
103
    return $search;
103
    return $search;
104
}
104
}
105
105
106
=head checkpw_ldap
107
108
@RETURNS Integer, -1 if login failed
109
                , 0 if connection to the LDAP server couldn't be reliably established.
110
		 or List of (-1|1|0, $cardnumber, $local_userid);
111
		 where $cardnumber is koha.borrowers.cardnumber
112
		       $local_userid is the koha.borrowers.userid
113
=cut
114
106
sub checkpw_ldap {
115
sub checkpw_ldap {
107
    my ($dbh, $userid, $password) = @_;
116
    my ($userid, $password) = @_;
108
    my @hosts = split(',', $prefhost);
117
    my @hosts = split(',', $prefhost);
109
    my $db = Net::LDAP->new(\@hosts);
118
    my $db = Net::LDAP->new(\@hosts);
110
    unless ( $db ) {
119
    unless ( $db ) {
(-)a/C4/Context.pm (-4 / +5 lines)
Lines 1073-1079 sub userenv { Link Here
1073
1073
1074
  C4::Context->set_userenv($usernum, $userid, $usercnum,
1074
  C4::Context->set_userenv($usernum, $userid, $usercnum,
1075
                           $userfirstname, $usersurname,
1075
                           $userfirstname, $usersurname,
1076
                           $userbranch, $branchname, $userflags,
1076
                           $userbranch, $branchname, $superlibrarian,
1077
                           $emailaddress, $branchprinter, $persona);
1077
                           $emailaddress, $branchprinter, $persona);
1078
1078
1079
Establish a hash of user environment variables.
1079
Establish a hash of user environment variables.
Lines 1085-1091 set_userenv is called in Auth.pm Link Here
1085
#'
1085
#'
1086
sub set_userenv {
1086
sub set_userenv {
1087
    shift @_;
1087
    shift @_;
1088
    my ($usernum, $userid, $usercnum, $userfirstname, $usersurname, $userbranch, $branchname, $userflags, $emailaddress, $branchprinter, $persona, $shibboleth)=
1088
    my ($usernum, $userid, $usercnum, $userfirstname, $usersurname, $userbranch, $branchname, $superlibrarian, $emailaddress, $branchprinter, $persona, $shibboleth)=
1089
    map { Encode::is_utf8( $_ ) ? $_ : Encode::decode('UTF-8', $_) } # CGI::Session doesn't handle utf-8, so we decode it here
1089
    map { Encode::is_utf8( $_ ) ? $_ : Encode::decode('UTF-8', $_) } # CGI::Session doesn't handle utf-8, so we decode it here
1090
    @_;
1090
    @_;
1091
    my $var=$context->{"activeuser"} || '';
1091
    my $var=$context->{"activeuser"} || '';
Lines 1098-1104 sub set_userenv { Link Here
1098
        #possibly a law problem
1098
        #possibly a law problem
1099
        "branch"     => $userbranch,
1099
        "branch"     => $userbranch,
1100
        "branchname" => $branchname,
1100
        "branchname" => $branchname,
1101
        "flags"      => $userflags,
1101
        "flags"      => $superlibrarian, #@DEPRECATED, use Koha::Borrower->isSuperlibrarian() instead of flags
1102
        "emailaddress"     => $emailaddress,
1102
        "emailaddress"     => $emailaddress,
1103
        "branchprinter"    => $branchprinter,
1103
        "branchprinter"    => $branchprinter,
1104
        "persona"    => $persona,
1104
        "persona"    => $persona,
Lines 1213-1218 sub tz { Link Here
1213
1213
1214
1214
1215
=head2 IsSuperLibrarian
1215
=head2 IsSuperLibrarian
1216
@DEPRECATED, use Koha::Borrower->isSuperlibrarian()
1216
1217
1217
    C4::Context->IsSuperLibrarian();
1218
    C4::Context->IsSuperLibrarian();
1218
1219
Lines 1229-1235 sub IsSuperLibrarian { Link Here
1229
        return 1;
1230
        return 1;
1230
    }
1231
    }
1231
1232
1232
    return ($userenv->{flags}//0) % 2;
1233
    return ($userenv->{flags}//0) % 2; #If flags == 1, this is true.
1233
}
1234
}
1234
1235
1235
=head2 interface
1236
=head2 interface
(-)a/t/db_dependent/Auth_with_ldap.t (-10 / +9 lines)
Lines 74-80 subtest "checkpw_ldap tests" => sub { Link Here
74
74
75
    ## Connection fail tests
75
    ## Connection fail tests
76
    $desired_connection_result = 'error';
76
    $desired_connection_result = 'error';
77
    warning_is { $ret = C4::Auth_with_ldap::checkpw_ldap( $dbh, 'hola', password => 'hey' ) }
77
    warning_is { $ret = C4::Auth_with_ldap::checkpw_ldap( 'hola', password => 'hey' ) }
78
        "LDAP connexion failed",
78
        "LDAP connexion failed",
79
        "checkpw_ldap prints correct warning if LDAP conexion fails";
79
        "checkpw_ldap prints correct warning if LDAP conexion fails";
80
    is( $ret, 0, "checkpw_ldap returns 0 if LDAP conexion fails");
80
    is( $ret, 0, "checkpw_ldap returns 0 if LDAP conexion fails");
Lines 96-102 subtest "checkpw_ldap tests" => sub { Link Here
96
96
97
97
98
        warning_like { $ret = C4::Auth_with_ldap::checkpw_ldap(
98
        warning_like { $ret = C4::Auth_with_ldap::checkpw_ldap(
99
                               $dbh, 'hola', password => 'hey' ) }
99
                               'hola', password => 'hey' ) }
100
                    qr/Anonymous LDAP bind failed: LDAP error #1: error_name/,
100
                    qr/Anonymous LDAP bind failed: LDAP error #1: error_name/,
101
                    "checkpw_ldap prints correct warning if LDAP anonymous bind fails";
101
                    "checkpw_ldap prints correct warning if LDAP anonymous bind fails";
102
        is( $ret, 0, "checkpw_ldap returns 0 if LDAP anonymous bind fails");
102
        is( $ret, 0, "checkpw_ldap returns 0 if LDAP anonymous bind fails");
Lines 108-121 subtest "checkpw_ldap tests" => sub { Link Here
108
        $desired_count_result  = 0; # user auth problem
108
        $desired_count_result  = 0; # user auth problem
109
        $non_anonymous_bind_result = 'success';
109
        $non_anonymous_bind_result = 'success';
110
        reload_ldap_module();
110
        reload_ldap_module();
111
        is ( C4::Auth_with_ldap::checkpw_ldap( $dbh, 'hola', password => 'hey' ),
111
        is ( C4::Auth_with_ldap::checkpw_ldap( 'hola', password => 'hey' ),
112
            0, "checkpw_ldap returns 0 if user lookup returns 0");
112
            0, "checkpw_ldap returns 0 if user lookup returns 0");
113
113
114
        $non_anonymous_bind_result = 'error';
114
        $non_anonymous_bind_result = 'error';
115
        reload_ldap_module();
115
        reload_ldap_module();
116
116
117
        warning_like { $ret = C4::Auth_with_ldap::checkpw_ldap(
117
        warning_like { $ret = C4::Auth_with_ldap::checkpw_ldap(
118
                               $dbh, 'hola', password => 'hey' ) }
118
                               'hola', password => 'hey' ) }
119
                    qr/LDAP bind failed as kohauser hola: LDAP error #1: error_name/,
119
                    qr/LDAP bind failed as kohauser hola: LDAP error #1: error_name/,
120
                    "checkpw_ldap prints correct warning if LDAP bind fails";
120
                    "checkpw_ldap prints correct warning if LDAP bind fails";
121
        is ( $ret, -1, "checkpw_ldap returns -1 LDAP bind fails for user (Bug 8148)");
121
        is ( $ret, -1, "checkpw_ldap returns -1 LDAP bind fails for user (Bug 8148)");
Lines 130-136 subtest "checkpw_ldap tests" => sub { Link Here
130
        reload_ldap_module();
130
        reload_ldap_module();
131
131
132
        warning_like { $ret = C4::Auth_with_ldap::checkpw_ldap(
132
        warning_like { $ret = C4::Auth_with_ldap::checkpw_ldap(
133
                               $dbh, 'hola', password => 'hey' ) }
133
                               'hola', password => 'hey' ) }
134
                    qr/LDAP bind failed as kohauser hola: LDAP error #1: error_name/,
134
                    qr/LDAP bind failed as kohauser hola: LDAP error #1: error_name/,
135
                    "checkpw_ldap prints correct warning if LDAP bind fails";
135
                    "checkpw_ldap prints correct warning if LDAP bind fails";
136
        is ( $ret, 0, "checkpw_ldap returns 0 LDAP bind fails for user (Bug 12831)");
136
        is ( $ret, 0, "checkpw_ldap returns 0 LDAP bind fails for user (Bug 12831)");
Lines 150-156 subtest "checkpw_ldap tests" => sub { Link Here
150
        reload_ldap_module();
150
        reload_ldap_module();
151
151
152
        warning_like { $ret = C4::Auth_with_ldap::checkpw_ldap(
152
        warning_like { $ret = C4::Auth_with_ldap::checkpw_ldap(
153
                               $dbh, 'hola', password => 'hey' ) }
153
                               'hola', password => 'hey' ) }
154
                    qr/LDAP bind failed as ldapuser cn=Manager,dc=metavore,dc=com: LDAP error #1: error_name/,
154
                    qr/LDAP bind failed as ldapuser cn=Manager,dc=metavore,dc=com: LDAP error #1: error_name/,
155
                    "checkpw_ldap prints correct warning if LDAP bind fails";
155
                    "checkpw_ldap prints correct warning if LDAP bind fails";
156
        is ( $ret, 0, "checkpw_ldap returns 0 if bind fails");
156
        is ( $ret, 0, "checkpw_ldap returns 0 if bind fails");
Lines 162-168 subtest "checkpw_ldap tests" => sub { Link Here
162
        reload_ldap_module();
162
        reload_ldap_module();
163
163
164
        warning_like { $ret = C4::Auth_with_ldap::checkpw_ldap(
164
        warning_like { $ret = C4::Auth_with_ldap::checkpw_ldap(
165
                               $dbh, 'hola', password => 'hey' ) }
165
                               'hola', password => 'hey' ) }
166
                    qr/LDAP Auth rejected : invalid password for user 'hola'. LDAP error #1: error_name/,
166
                    qr/LDAP Auth rejected : invalid password for user 'hola'. LDAP error #1: error_name/,
167
                    "checkpw_ldap prints correct warning if LDAP bind fails";
167
                    "checkpw_ldap prints correct warning if LDAP bind fails";
168
        is ( $ret, -1, "checkpw_ldap returns -1 if bind fails (Bug 8148)");
168
        is ( $ret, -1, "checkpw_ldap returns -1 if bind fails (Bug 8148)");
Lines 175-181 subtest "checkpw_ldap tests" => sub { Link Here
175
        reload_ldap_module();
175
        reload_ldap_module();
176
176
177
        warning_like { $ret = C4::Auth_with_ldap::checkpw_ldap(
177
        warning_like { $ret = C4::Auth_with_ldap::checkpw_ldap(
178
                               $dbh, 'hola', password => 'hey' ) }
178
                               'hola', password => 'hey' ) }
179
                    qr/LDAP bind failed as ldapuser cn=Manager,dc=metavore,dc=com: LDAP error #1: error_name/,
179
                    qr/LDAP bind failed as ldapuser cn=Manager,dc=metavore,dc=com: LDAP error #1: error_name/,
180
                    "checkpw_ldap prints correct warning if LDAP bind fails";
180
                    "checkpw_ldap prints correct warning if LDAP bind fails";
181
        is ( $ret, 0, "checkpw_ldap returns 0 if bind fails");
181
        is ( $ret, 0, "checkpw_ldap returns 0 if bind fails");
Lines 187-193 subtest "checkpw_ldap tests" => sub { Link Here
187
        reload_ldap_module();
187
        reload_ldap_module();
188
188
189
        warning_like { $ret = C4::Auth_with_ldap::checkpw_ldap(
189
        warning_like { $ret = C4::Auth_with_ldap::checkpw_ldap(
190
                               $dbh, 'hola', password => 'hey' ) }
190
                               'hola', password => 'hey' ) }
191
                    qr/LDAP Auth rejected : invalid password for user 'hola'. LDAP error #1: error_name/,
191
                    qr/LDAP Auth rejected : invalid password for user 'hola'. LDAP error #1: error_name/,
192
                    "checkpw_ldap prints correct warning if LDAP bind fails";
192
                    "checkpw_ldap prints correct warning if LDAP bind fails";
193
        is ( $ret, -1, "checkpw_ldap returns -1 if bind fails (Bug 8148)");
193
        is ( $ret, -1, "checkpw_ldap returns -1 if bind fails (Bug 8148)");
194
- 

Return to bug 7174