C4/Auth.pm

   1 package C4::Auth;
   2
   3 # Copyright 2000-2002 Katipo Communications
   4 #
   5 # This file is part of Koha.
   6 #
   7 # Koha is free software; you can redistribute it and/or modify it
   8 # under the terms of the GNU General Public License as published by
   9 # the Free Software Foundation; either version 3 of the License, or
  10 # (at your option) any later version.
  11 #
  12 # Koha is distributed in the hope that it will be useful, but
  13 # WITHOUT ANY WARRANTY; without even the implied warranty of
  14 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
  15 # GNU General Public License for more details.
  16 #
  17 # You should have received a copy of the GNU General Public License
  18 # along with Koha; if not, see <http://www.gnu.org/licenses>.
  19
  20 use strict;
  21 use warnings;
  22 use Carp qw( croak );
  23
  24 use Digest::MD5 qw( md5_base64 );
  25 use CGI::Session;
  26 use CGI::Session::ErrorHandler;
  27 use URI;
  28 use URI::QueryParam;
  29
  30 use C4::Context;
  31 use C4::Templates;    # to get the template
  32 use C4::Languages;
  33 use C4::Search::History;
  34 use Koha;
  35 use Koha::Logger;
  36 use Koha::Caches;
  37 use Koha::AuthUtils qw( get_script_name hash_password );
  38 use Koha::Auth::TwoFactorAuth;
  39 use Koha::Checkouts;
  40 use Koha::DateUtils qw( dt_from_string );
  41 use Koha::Library::Groups;
  42 use Koha::Libraries;
  43 use Koha::Cash::Registers;
  44 use Koha::Desks;
  45 use Koha::Patrons;
  46 use Koha::Patron::Consents;
  47 use List::MoreUtils qw( any );
  48 use Encode;
  49 use C4::Auth_with_shibboleth qw( shib_ok get_login_shib login_shib_url logout_shib checkpw_shib );
  50 use Net::CIDR;
  51 use C4::Log qw( logaction );
  52 use Koha::CookieManager;
  53 use Koha::Auth::Permissions;
  54
  55 # use utf8;
  56
  57 use vars qw($ldap $cas $caslogout);
  58 our (@ISA, @EXPORT_OK);
  59
  60 #NOTE: The utility of keeping the safe_exit function is that it can be easily re-defined in unit tests and plugins
  61 sub safe_exit {
  62     # It's fine for us to "exit" because CGI::Compile (used in Plack::App::WrapCGI) redefines "exit" for us automatically.
  63     # Since we only seem to use C4::Auth::safe_exit in a CGI context, we don't actually need PSGI detection at all here.
  64     exit;
  65 }
  66
  67
  68 BEGIN {
  69     C4::Context->set_remote_address;
  70
  71     require Exporter;
  72     @ISA = qw(Exporter);
  73
  74     @EXPORT_OK = qw(
  75       checkauth check_api_auth get_session check_cookie_auth checkpw checkpw_internal checkpw_hash
  76       get_all_subpermissions get_user_subpermissions track_login_daily in_iprange
  77       get_template_and_user haspermission create_basic_session
  78     );
  79
  80     $ldap      = C4::Context->config('useldapserver') || 0;
  81     $cas       = C4::Context->preference('casAuthentication');
  82     $caslogout = C4::Context->preference('casLogout');
  83
  84     if ($ldap) {
  85         require C4::Auth_with_ldap;
  86         import C4::Auth_with_ldap qw(checkpw_ldap);
  87     }
  88     if ($cas) {
  89         require C4::Auth_with_cas;    # no import
  90         import C4::Auth_with_cas qw(check_api_auth_cas checkpw_cas login_cas logout_cas login_cas_url logout_if_required multipleAuth getMultipleAuth);
  91     }
  92
  93 }
  94
  95 =head1 NAME
  96
  97 C4::Auth - Authenticates Koha users
  98
  99 =head1 SYNOPSIS
 100
 101   use CGI qw ( -utf8 );
 102   use C4::Auth;
 103   use C4::Output;
 104
 105   my $query = CGI->new;
 106
 107   my ($template, $borrowernumber, $cookie)
 108     = get_template_and_user(
 109         {
 110             template_name   => "opac-main.tt",
 111             query           => $query,
 112       type            => "opac",
 113       authnotrequired => 0,
 114       flagsrequired   => { catalogue => '*', tools => 'import_patrons' },
 115   }
 116     );
 117
 118   output_html_with_http_headers $query, $cookie, $template->output;
 119
 120 =head1 DESCRIPTION
 121
 122 The main function of this module is to provide
 123 authentification. However the get_template_and_user function has
 124 been provided so that a users login information is passed along
 125 automatically. This gets loaded into the template.
 126
 127 =head1 FUNCTIONS
 128
 129 =head2 get_template_and_user
 130
 131  my ($template, $borrowernumber, $cookie)
 132      = get_template_and_user(
 133        {
 134          template_name   => "opac-main.tt",
 135          query           => $query,
 136          type            => "opac",
 137          authnotrequired => 0,
 138          flagsrequired   => { catalogue => '*', tools => 'import_patrons' },
 139        }
 140      );
 141
 142 This call passes the C<query>, C<flagsrequired> and C<authnotrequired>
 143 to C<&checkauth> (in this module) to perform authentification.
 144 See C<&checkauth> for an explanation of these parameters.
 145
 146 The C<template_name> is then used to find the correct template for
 147 the page. The authenticated users details are loaded onto the
 148 template in the logged_in_user variable (which is a Koha::Patron object). Also the
 149 C<sessionID> is passed to the template. This can be used in templates
 150 if cookies are disabled. It needs to be put as and input to every
 151 authenticated page.
 152
 153 More information on the C<gettemplate> sub can be found in the
 154 Output.pm module.
 155
 156 =cut
 157
 158 sub get_template_and_user {
 159
 160     my $in = shift;
 161     my ( $user, $cookie, $sessionID, $flags );
 162     $cookie = [];
 163
 164     my $cookie_mgr = Koha::CookieManager->new;
 165
 166     # Get shibboleth login attribute
 167     my $shib = C4::Context->config('useshibboleth') && shib_ok();
 168     my $shib_login = $shib ? get_login_shib() : undef;
 169
 170     C4::Context->interface( $in->{type} );
 171
 172     $in->{'authnotrequired'} ||= 0;
 173
 174     # the following call includes a bad template check; might croak
 175     my $template = C4::Templates::gettemplate(
 176         $in->{'template_name'},
 177         $in->{'type'},
 178         $in->{'query'},
 179     );
 180
 181     if ( $in->{'template_name'} !~ m/maintenance/ ) {
 182         ( $user, $cookie, $sessionID, $flags ) = checkauth(
 183             $in->{'query'},
 184             $in->{'authnotrequired'},
 185             $in->{'flagsrequired'},
 186             $in->{'type'},
 187             undef,
 188             $in->{template_name},
 189         );
 190     }
 191
 192     # If we enforce GDPR and the user did not consent, redirect
 193     # Exceptions for consent page itself and SCI/SCO system
 194     if( $in->{type} eq 'opac' && $user &&
 195         $in->{'template_name'} !~ /^(opac-page|opac-patron-consent|sc[io]\/)/ &&
 196         C4::Context->preference('GDPR_Policy') eq 'Enforced' )
 197     {
 198         my $consent = Koha::Patron::Consents->search({
 199             borrowernumber => getborrowernumber($user),
 200             type => 'GDPR_PROCESSING',
 201             given_on => { '!=', undef },
 202         })->next;
 203         if( !$consent ) {
 204             print $in->{query}->redirect(-uri => '/cgi-bin/koha/opac-patron-consent.pl', -cookie => $cookie);
 205             safe_exit;
 206         }
 207     }
 208
 209     if ( $in->{type} eq 'opac' && $user ) {
 210         my $is_sco_user;
 211         if ($sessionID){
 212             my $session = get_session($sessionID);
 213             if ($session){
 214                 $is_sco_user = $session->param('sco_user');
 215             }
 216         }
 217         my $kick_out;
 218
 219         if (
 220 # If the user logged in is the SCO user and they try to go out of the SCO module,
 221 # log the user out removing the CGISESSID cookie
 222             $in->{template_name} !~ m|sco/| && $in->{template_name} !~ m|errors/errorpage.tt|
 223             && (
 224                 $is_sco_user ||
 225                 (
 226                     C4::Context->preference('AutoSelfCheckID')
 227                     && $user eq C4::Context->preference('AutoSelfCheckID')
 228                 )
 229             )
 230           )
 231         {
 232             $kick_out = 1;
 233         }
 234         elsif (
 235 # If the user logged in is the SCI user and they try to go out of the SCI module,
 236 # kick them out unless it is SCO with a valid permission
 237 # or they are a superlibrarian
 238                $in->{template_name} !~ m|sci/|
 239             && haspermission( $user, { self_check => 'self_checkin_module' } )
 240             && !(
 241                 $in->{template_name} =~ m|sco/| && haspermission(
 242                     $user, { self_check => 'self_checkout_module' }
 243                 )
 244             )
 245             && $flags && $flags->{superlibrarian} != 1
 246           )
 247         {
 248             $kick_out = 1;
 249         }
 250
 251         if ($kick_out) {
 252             $template = C4::Templates::gettemplate( 'opac-auth.tt', 'opac',
 253                 $in->{query} );
 254             $cookie = $cookie_mgr->replace_in_list( $cookie, $in->{query}->cookie(
 255                 -name     => 'CGISESSID',
 256                 -value    => '',
 257                 -HttpOnly => 1,
 258                 -secure => ( C4::Context->https_enabled() ? 1 : 0 ),
 259                 -sameSite => 'Lax',
 260             ));
 261
 262             my $auth_error = $in->{query}->param('auth_error');
 263
 264             $template->param(
 265                 loginprompt => 1,
 266                 script_name => get_script_name(),
 267                 auth_error  => $auth_error,
 268             );
 269
 270             print $in->{query}->header(
 271                 {
 272                     type              => 'text/html',
 273                     charset           => 'utf-8',
 274                     cookie            => $cookie,
 275                     'X-Frame-Options' => 'SAMEORIGIN'
 276                 }
 277               ),
 278               $template->output;
 279             safe_exit;
 280         }
 281     }
 282
 283     my $borrowernumber;
 284     if ($user) {
 285
 286         # It's possible for $user to be the borrowernumber if they don't have a
 287         # userid defined (and are logging in through some other method, such
 288         # as SSL certs against an email address)
 289         my $patron;
 290         $borrowernumber = getborrowernumber($user) if defined($user);
 291         if ( !defined($borrowernumber) && defined($user) ) {
 292             $patron = Koha::Patrons->find( $user );
 293             if ($patron) {
 294                 $borrowernumber = $user;
 295
 296                 # A bit of a hack, but I don't know there's a nicer way
 297                 # to do it.
 298                 $user = $patron->firstname . ' ' . $patron->surname;
 299             }
 300         } else {
 301             $patron = Koha::Patrons->find( $borrowernumber );
 302             # FIXME What to do if $patron does not exist?
 303         }
 304
 305         # user info
 306         $template->param( loggedinusername   => $user ); # OBSOLETE - Do not reuse this in template, use logged_in_user.userid instead
 307         $template->param( loggedinusernumber => $borrowernumber ); # FIXME Should be replaced with logged_in_user.borrowernumber
 308         $template->param( logged_in_user     => $patron );
 309         $template->param( sessionID          => $sessionID );
 310
 311         if ( $in->{'type'} eq 'opac' ) {
 312             require Koha::Virtualshelves;
 313             my $some_private_shelves = Koha::Virtualshelves->get_some_shelves(
 314                 {
 315                     borrowernumber => $borrowernumber,
 316                     public         => 0,
 317                 }
 318             );
 319             my $some_public_shelves = Koha::Virtualshelves->get_some_shelves(
 320                 {
 321                     public => 1,
 322                 }
 323             );
 324             $template->param(
 325                 some_private_shelves => $some_private_shelves,
 326                 some_public_shelves  => $some_public_shelves,
 327             );
 328         }
 329
 330         # We are going to use the $flags returned by checkauth
 331         # to create the template's parameters that will indicate
 332         # which menus the user can access.
 333         my $authz = Koha::Auth::Permissions->get_authz_from_flags({ flags => $flags });
 334         foreach my $permission ( keys %{ $authz } ){
 335             $template->param( $permission => $authz->{$permission} );
 336         }
 337
 338         # Logged-in opac search history
 339         # If the requested template is an opac one and opac search history is enabled
 340         if ( $in->{type} eq 'opac' && C4::Context->preference('EnableOpacSearchHistory') ) {
 341             my $dbh   = C4::Context->dbh;
 342             my $query = "SELECT COUNT(*) FROM search_history WHERE userid=?";
 343             my $sth   = $dbh->prepare($query);
 344             $sth->execute($borrowernumber);
 345
 346             # If at least one search has already been performed
 347             if ( $sth->fetchrow_array > 0 ) {
 348
 349                 # We show the link in opac
 350                 $template->param( EnableOpacSearchHistory => 1 );
 351             }
 352             if (C4::Context->preference('LoadSearchHistoryToTheFirstLoggedUser'))
 353             {
 354                 # And if there are searches performed when the user was not logged in,
 355                 # we add them to the logged-in search history
 356                 my @recentSearches = C4::Search::History::get_from_session( { cgi => $in->{'query'} } );
 357                 if (@recentSearches) {
 358                     my $query = q{
 359                         INSERT INTO search_history(userid, sessionid, query_desc, query_cgi, type,  total, time )
 360                         VALUES (?, ?, ?, ?, ?, ?, ?)
 361                     };
 362                     my $sth = $dbh->prepare($query);
 363                     $sth->execute( $borrowernumber,
 364                         $in->{query}->cookie("CGISESSID"),
 365                         $_->{query_desc},
 366                         $_->{query_cgi},
 367                         $_->{type} || 'biblio',
 368                         $_->{total},
 369                         $_->{time},
 370                     ) foreach @recentSearches;
 371
 372                     # clear out the search history from the session now that
 373                     # we've saved it to the database
 374                  }
 375               }
 376               C4::Search::History::set_to_session( { cgi => $in->{'query'}, search_history => [] } );
 377
 378         } elsif ( $in->{type} eq 'intranet' and C4::Context->preference('EnableSearchHistory') ) {
 379             $template->param( EnableSearchHistory => 1 );
 380         }
 381     }
 382     else {    # if this is an anonymous session, setup to display public lists...
 383
 384         # If shibboleth is enabled, and we're in an anonymous session, we should allow
 385         # the user to attempt login via shibboleth.
 386         if ($shib) {
 387             $template->param( shibbolethAuthentication => $shib,
 388                 shibbolethLoginUrl => login_shib_url( $in->{'query'} ),
 389             );
 390
 391             # If shibboleth is enabled and we have a shibboleth login attribute,
 392             # but we are in an anonymous session, then we clearly have an invalid
 393             # shibboleth koha account.
 394             if ($shib_login) {
 395                 $template->param( invalidShibLogin => '1' );
 396             }
 397         }
 398
 399         $template->param( sessionID => $sessionID );
 400
 401         if ( $in->{'type'} eq 'opac' ){
 402             require Koha::Virtualshelves;
 403             my $some_public_shelves = Koha::Virtualshelves->get_some_shelves(
 404                 {
 405                     public => 1,
 406                 }
 407             );
 408             $template->param(
 409                 some_public_shelves  => $some_public_shelves,
 410             );
 411
 412             # Set default branch if one has been passed by the environment.
 413             $template->param( default_branch => $ENV{OPAC_BRANCH_DEFAULT} ) if $ENV{OPAC_BRANCH_DEFAULT};
 414         }
 415     }
 416
 417     # Sysprefs disabled via URL param
 418     # Note that value must be defined in order to override via ENV
 419     foreach my $syspref (
 420         qw(
 421             OPACUserCSS
 422             OPACUserJS
 423             IntranetUserCSS
 424             IntranetUserJS
 425             OpacAdditionalStylesheet
 426             opaclayoutstylesheet
 427             intranetcolorstylesheet
 428             intranetstylesheet
 429         )
 430       )
 431     {
 432         $ENV{"OVERRIDE_SYSPREF_$syspref"} = q{}
 433           if $in->{'query'}->param("DISABLE_SYSPREF_$syspref");
 434     }
 435
 436     # Anonymous opac search history
 437     # If opac search history is enabled and at least one search has already been performed
 438     if ( C4::Context->preference('EnableOpacSearchHistory') ) {
 439         my @recentSearches = C4::Search::History::get_from_session( { cgi => $in->{'query'} } );
 440         if (@recentSearches) {
 441             $template->param( EnableOpacSearchHistory => 1 );
 442         }
 443     }
 444
 445     if ( C4::Context->preference('dateformat') ) {
 446         $template->param( dateformat => C4::Context->preference('dateformat') );
 447     }
 448
 449     $template->param(auth_forwarded_hash => scalar $in->{'query'}->param('auth_forwarded_hash'));
 450
 451     # these template parameters are set the same regardless of $in->{'type'}
 452
 453     # Decide if the patron can make suggestions in the OPAC
 454     my $can_make_suggestions;
 455     if ( C4::Context->preference('Suggestion') && C4::Context->preference('AnonSuggestions') ) {
 456         $can_make_suggestions = 1;
 457     } elsif ( C4::Context->userenv && C4::Context->userenv->{'number'} ) {
 458         $can_make_suggestions = Koha::Patrons->find(C4::Context->userenv->{'number'})->category->can_make_suggestions;
 459     }
 460
 461     my $minPasswordLength = C4::Context->preference('minPasswordLength');
 462     $minPasswordLength = 3 if not $minPasswordLength or $minPasswordLength < 3;
 463     $template->param(
 464         EnhancedMessagingPreferences                                       => C4::Context->preference('EnhancedMessagingPreferences'),
 465         GoogleJackets                                                      => C4::Context->preference("GoogleJackets"),
 466         OpenLibraryCovers                                                  => C4::Context->preference("OpenLibraryCovers"),
 467         KohaAdminEmailAddress                                              => "" . C4::Context->preference("KohaAdminEmailAddress"),
 468         LoginFirstname  => ( C4::Context->userenv ? C4::Context->userenv->{"firstname"} : "Bel" ),
 469         LoginSurname    => C4::Context->userenv ? C4::Context->userenv->{"surname"}      : "Inconnu",
 470         emailaddress    => C4::Context->userenv ? C4::Context->userenv->{"emailaddress"} : undef,
 471         TagsEnabled     => C4::Context->preference("TagsEnabled"),
 472         hide_marc       => C4::Context->preference("hide_marc"),
 473         item_level_itypes  => C4::Context->preference('item-level_itypes'),
 474         patronimages       => C4::Context->preference("patronimages"),
 475         singleBranchMode   => ( Koha::Libraries->search->count == 1 ),
 476         noItemTypeImages   => C4::Context->preference("noItemTypeImages"),
 477         marcflavour        => C4::Context->preference("marcflavour"),
 478         OPACBaseURL        => C4::Context->preference('OPACBaseURL'),
 479         minPasswordLength  => $minPasswordLength,
 480     );
 481     if ( $in->{'type'} eq "intranet" ) {
 482         $template->param(
 483             AmazonCoverImages                                                          => C4::Context->preference("AmazonCoverImages"),
 484             AutoLocation                                                               => C4::Context->preference("AutoLocation"),
 485             PatronAutoComplete                                                         => C4::Context->preference("PatronAutoComplete"),
 486             FRBRizeEditions                                                            => C4::Context->preference("FRBRizeEditions"),
 487             IndependentBranches                                                        => C4::Context->preference("IndependentBranches"),
 488             IntranetNav                                                                => C4::Context->preference("IntranetNav"),
 489             IntranetmainUserblock                                                      => C4::Context->preference("IntranetmainUserblock"),
 490             LibraryName                                                                => C4::Context->preference("LibraryName"),
 491             advancedMARCEditor                                                         => C4::Context->preference("advancedMARCEditor"),
 492             canreservefromotherbranches                                                => C4::Context->preference('canreservefromotherbranches'),
 493             intranetcolorstylesheet                                                    => C4::Context->preference("intranetcolorstylesheet"),
 494             IntranetFavicon                                                            => C4::Context->preference("IntranetFavicon"),
 495             intranetreadinghistory                                                     => C4::Context->preference("intranetreadinghistory"),
 496             intranetstylesheet                                                         => C4::Context->preference("intranetstylesheet"),
 497             IntranetUserCSS                                                            => C4::Context->preference("IntranetUserCSS"),
 498             IntranetUserJS                                                             => C4::Context->preference("IntranetUserJS"),
 499             suggestion                                                                 => $can_make_suggestions,
 500             virtualshelves                                                             => C4::Context->preference("virtualshelves"),
 501             StaffSerialIssueDisplayCount                                               => C4::Context->preference("StaffSerialIssueDisplayCount"),
 502             EasyAnalyticalRecords                                                      => C4::Context->preference('EasyAnalyticalRecords'),
 503             LocalCoverImages                                                           => C4::Context->preference('LocalCoverImages'),
 504             OPACLocalCoverImages                                                       => C4::Context->preference('OPACLocalCoverImages'),
 505             AllowMultipleCovers                                                        => C4::Context->preference('AllowMultipleCovers'),
 506             EnableBorrowerFiles                                                        => C4::Context->preference('EnableBorrowerFiles'),
 507             UseCourseReserves                                                          => C4::Context->preference("UseCourseReserves"),
 508             useDischarge                                                               => C4::Context->preference('useDischarge'),
 509             pending_checkout_notes                                                     => Koha::Checkouts->search({ noteseen => 0 }),
 510             plugins_enabled                                                            => C4::Context->config("enable_plugins"),
 511         );
 512     }
 513     else {
 514         warn "template type should be OPAC, here it is=[" . $in->{'type'} . "]" unless ( $in->{'type'} eq 'opac' );
 515
 516         #TODO : replace LibraryName syspref with 'system name', and remove this html processing
 517         my $LibraryNameTitle = C4::Context->preference("LibraryName");
 518         $LibraryNameTitle =~ s/<(?:\/?)(?:br|p)\s*(?:\/?)>/ /sgi;
 519         $LibraryNameTitle =~ s/<(?:[^<>'"]|'(?:[^']*)'|"(?:[^"]*)")*>//sg;
 520
 521         # clean up the busc param in the session
 522         # if the page is not opac-detail and not the "add to list" page
 523         # and not the "edit comments" page
 524         if ( C4::Context->preference("OpacBrowseResults")
 525             && $in->{'template_name'} =~ /opac-(.+)\.(?:tt|tmpl)$/ ) {
 526             my $pagename = $1;
 527             unless ( $pagename =~ /^(?:MARC|ISBD)?detail$/
 528                 or $pagename =~ /^showmarc$/
 529                 or $pagename =~ /^addbybiblionumber$/
 530                 or $pagename =~ /^review$/ )
 531             {
 532                 my $sessionSearch = get_session( $sessionID );
 533                 $sessionSearch->clear( ["busc"] ) if $sessionSearch;
 534             }
 535         }
 536
 537         # variables passed from CGI: opac_css_override and opac_search_limits.
 538         my $opac_search_limit   = $ENV{'OPAC_SEARCH_LIMIT'};
 539         my $opac_limit_override = $ENV{'OPAC_LIMIT_OVERRIDE'};
 540         my $opac_name           = '';
 541         if (
 542             ( $opac_limit_override && $opac_search_limit && $opac_search_limit =~ /branch:([\w-]+)/ ) ||
 543             ( $in->{'query'}->param('limit') && $in->{'query'}->param('limit') =~ /branch:([\w-]+)/ ) ||
 544             ( $in->{'query'}->param('limit') && $in->{'query'}->param('limit') =~ /multibranchlimit:(\w+)/ )
 545           ) {
 546             $opac_name = $1;    # opac_search_limit is a branch, so we use it.
 547         } elsif ( $in->{'query'}->param('multibranchlimit') ) {
 548             $opac_name = $in->{'query'}->param('multibranchlimit');
 549         } elsif ( C4::Context->preference("SearchMyLibraryFirst") && C4::Context->userenv && C4::Context->userenv->{'branch'} ) {
 550             $opac_name = C4::Context->userenv->{'branch'};
 551         }
 552
 553         my @search_groups = Koha::Library::Groups->get_search_groups({ interface => 'opac' })->as_list;
 554         $template->param(
 555             AnonSuggestions                       => "" . C4::Context->preference("AnonSuggestions"),
 556             LibrarySearchGroups                   => \@search_groups,
 557             opac_name                             => $opac_name,
 558             LibraryName                           => "" . C4::Context->preference("LibraryName"),
 559             LibraryNameTitle                      => "" . $LibraryNameTitle,
 560             OPACAmazonCoverImages                 => C4::Context->preference("OPACAmazonCoverImages"),
 561             OPACFRBRizeEditions                   => C4::Context->preference("OPACFRBRizeEditions"),
 562             OpacHighlightedWords                  => C4::Context->preference("OpacHighlightedWords"),
 563             OPACShelfBrowser                      => "" . C4::Context->preference("OPACShelfBrowser"),
 564             OPACURLOpenInNewWindow                => "" . C4::Context->preference("OPACURLOpenInNewWindow"),
 565             OPACUserCSS                           => "" . C4::Context->preference("OPACUserCSS"),
 566             OpacAuthorities                       => C4::Context->preference("OpacAuthorities"),
 567             opac_css_override                     => $ENV{'OPAC_CSS_OVERRIDE'},
 568             opac_search_limit                     => $opac_search_limit,
 569             opac_limit_override                   => $opac_limit_override,
 570             OpacBrowser                           => C4::Context->preference("OpacBrowser"),
 571             OpacCloud                             => C4::Context->preference("OpacCloud"),
 572             OpacKohaUrl                           => C4::Context->preference("OpacKohaUrl"),
 573             OpacPasswordChange                    => C4::Context->preference("OpacPasswordChange"),
 574             OPACPatronDetails                     => C4::Context->preference("OPACPatronDetails"),
 575             OPACPrivacy                           => C4::Context->preference("OPACPrivacy"),
 576             OPACFinesTab                          => C4::Context->preference("OPACFinesTab"),
 577             OpacTopissue                          => C4::Context->preference("OpacTopissue"),
 578             'Version'                             => C4::Context->preference('Version'),
 579             hidelostitems                         => C4::Context->preference("hidelostitems"),
 580             mylibraryfirst                        => ( C4::Context->preference("SearchMyLibraryFirst") && C4::Context->userenv ) ? C4::Context->userenv->{'branch'} : '',
 581             opacbookbag                           => "" . C4::Context->preference("opacbookbag"),
 582             OpacFavicon                           => C4::Context->preference("OpacFavicon"),
 583             opaclanguagesdisplay                  => "" . C4::Context->preference("opaclanguagesdisplay"),
 584             opacreadinghistory                    => C4::Context->preference("opacreadinghistory"),
 585             OPACUserJS                            => C4::Context->preference("OPACUserJS"),
 586             opacuserlogin                         => "" . C4::Context->preference("opacuserlogin"),
 587             OpenLibrarySearch                     => C4::Context->preference("OpenLibrarySearch"),
 588             ShowReviewer                          => C4::Context->preference("ShowReviewer"),
 589             ShowReviewerPhoto                     => C4::Context->preference("ShowReviewerPhoto"),
 590             suggestion                            => $can_make_suggestions,
 591             virtualshelves                        => "" . C4::Context->preference("virtualshelves"),
 592             OPACSerialIssueDisplayCount           => C4::Context->preference("OPACSerialIssueDisplayCount"),
 593             SyndeticsClientCode                   => C4::Context->preference("SyndeticsClientCode"),
 594             SyndeticsEnabled                      => C4::Context->preference("SyndeticsEnabled"),
 595             SyndeticsCoverImages                  => C4::Context->preference("SyndeticsCoverImages"),
 596             SyndeticsTOC                          => C4::Context->preference("SyndeticsTOC"),
 597             SyndeticsSummary                      => C4::Context->preference("SyndeticsSummary"),
 598             SyndeticsEditions                     => C4::Context->preference("SyndeticsEditions"),
 599             SyndeticsExcerpt                      => C4::Context->preference("SyndeticsExcerpt"),
 600             SyndeticsReviews                      => C4::Context->preference("SyndeticsReviews"),
 601             SyndeticsAuthorNotes                  => C4::Context->preference("SyndeticsAuthorNotes"),
 602             SyndeticsAwards                       => C4::Context->preference("SyndeticsAwards"),
 603             SyndeticsSeries                       => C4::Context->preference("SyndeticsSeries"),
 604             SyndeticsCoverImageSize               => C4::Context->preference("SyndeticsCoverImageSize"),
 605             OPACLocalCoverImages                  => C4::Context->preference("OPACLocalCoverImages"),
 606             PatronSelfRegistration                => C4::Context->preference("PatronSelfRegistration"),
 607             PatronSelfRegistrationDefaultCategory => C4::Context->preference("PatronSelfRegistrationDefaultCategory"),
 608             useDischarge                 => C4::Context->preference('useDischarge'),
 609         );
 610
 611         $template->param( OpacPublic => '1' ) if ( $user || C4::Context->preference("OpacPublic") );
 612     }
 613
 614     # Check if we were asked using parameters to force a specific language
 615     if ( defined $in->{'query'}->param('language') ) {
 616
 617         # Extract the language, let C4::Languages::getlanguage choose
 618         # what to do
 619         my $language = C4::Languages::getlanguage( $in->{'query'} );
 620         my $languagecookie = C4::Templates::getlanguagecookie( $in->{'query'}, $language );
 621         $cookie = $cookie_mgr->replace_in_list( $cookie, $languagecookie );
 622     }
 623
 624     return ( $template, $borrowernumber, $cookie, $flags );
 625 }
 626
 627 =head2 checkauth
 628
 629   ($userid, $cookie, $sessionID) = &checkauth($query, $noauth, $flagsrequired, $type);
 630
 631 Verifies that the user is authorized to run this script.  If
 632 the user is authorized, a (userid, cookie, session-id, flags)
 633 quadruple is returned.  If the user is not authorized but does
 634 not have the required privilege (see $flagsrequired below), it
 635 displays an error page and exits.  Otherwise, it displays the
 636 login page and exits.
 637
 638 Note that C<&checkauth> will return if and only if the user
 639 is authorized, so it should be called early on, before any
 640 unfinished operations (e.g., if you've opened a file, then
 641 C<&checkauth> won't close it for you).
 642
 643 C<$query> is the CGI object for the script calling C<&checkauth>.
 644
 645 The C<$noauth> argument is optional. If it is set, then no
 646 authorization is required for the script.
 647
 648 C<&checkauth> fetches user and session information from C<$query> and
 649 ensures that the user is authorized to run scripts that require
 650 authorization.
 651
 652 The C<$flagsrequired> argument specifies the required privileges
 653 the user must have if the username and password are correct.
 654 It should be specified as a reference-to-hash; keys in the hash
 655 should be the "flags" for the user, as specified in the Members
 656 intranet module. Any key specified must correspond to a "flag"
 657 in the userflags table. E.g., { circulate => 1 } would specify
 658 that the user must have the "circulate" privilege in order to
 659 proceed. To make sure that access control is correct, the
 660 C<$flagsrequired> parameter must be specified correctly.
 661
 662 Koha also has a concept of sub-permissions, also known as
 663 granular permissions.  This makes the value of each key
 664 in the C<flagsrequired> hash take on an additional
 665 meaning, i.e.,
 666
 667  1
 668
 669 The user must have access to all subfunctions of the module
 670 specified by the hash key.
 671
 672  *
 673
 674 The user must have access to at least one subfunction of the module
 675 specified by the hash key.
 676
 677  specific permission, e.g., 'export_catalog'
 678
 679 The user must have access to the specific subfunction list, which
 680 must correspond to a row in the permissions table.
 681
 682 The C<$type> argument specifies whether the template should be
 683 retrieved from the opac or intranet directory tree.  "opac" is
 684 assumed if it is not specified; however, if C<$type> is specified,
 685 "intranet" is assumed if it is not "opac".
 686
 687 If C<$query> does not have a valid session ID associated with it
 688 (i.e., the user has not logged in) or if the session has expired,
 689 C<&checkauth> presents the user with a login page (from the point of
 690 view of the original script, C<&checkauth> does not return). Once the
 691 user has authenticated, C<&checkauth> restarts the original script
 692 (this time, C<&checkauth> returns).
 693
 694 The login page is provided using a HTML::Template, which is set in the
 695 systempreferences table or at the top of this file. The variable C<$type>
 696 selects which template to use, either the opac or the intranet
 697 authentification template.
 698
 699 C<&checkauth> returns a user ID, a cookie, and a session ID. The
 700 cookie should be sent back to the browser; it verifies that the user
 701 has authenticated.
 702
 703 =cut
 704
 705 sub _version_check {
 706     my $type  = shift;
 707     my $query = shift;
 708     my $version;
 709
 710     # If version syspref is unavailable, it means Koha is being installed,
 711     # and so we must redirect to OPAC maintenance page or to the WebInstaller
 712     # also, if OpacMaintenance is ON, OPAC should redirect to maintenance
 713     if ( C4::Context->preference('OpacMaintenance') && $type eq 'opac' ) {
 714         warn "OPAC Install required, redirecting to maintenance";
 715         print $query->redirect("/cgi-bin/koha/maintenance.pl");
 716         safe_exit;
 717     }
 718     unless ( $version = C4::Context->preference('Version') ) {    # assignment, not comparison
 719         if ( $type ne 'opac' ) {
 720             warn "Install required, redirecting to Installer";
 721             print $query->redirect("/cgi-bin/koha/installer/install.pl");
 722         } else {
 723             warn "OPAC Install required, redirecting to maintenance";
 724             print $query->redirect("/cgi-bin/koha/maintenance.pl");
 725         }
 726         safe_exit;
 727     }
 728
 729     # check that database and koha version are the same
 730     # there is no DB version, it's a fresh install,
 731     # go to web installer
 732     # there is a DB version, compare it to the code version
 733     my $kohaversion = Koha::version();
 734
 735     # remove the 3 last . to have a Perl number
 736     $kohaversion =~ s/(.*\..*)\.(.*)\.(.*)/$1$2$3/;
 737     Koha::Logger->get->debug("kohaversion : $kohaversion");
 738     if ( $version < $kohaversion ) {
 739         my $warning = "Database update needed, redirecting to %s. Database is $version and Koha is $kohaversion";
 740         if ( $type ne 'opac' ) {
 741             warn sprintf( $warning, 'Installer' );
 742             print $query->redirect("/cgi-bin/koha/installer/install.pl?step=1&op=updatestructure");
 743         } else {
 744             warn sprintf( "OPAC: " . $warning, 'maintenance' );
 745             print $query->redirect("/cgi-bin/koha/maintenance.pl");
 746         }
 747         safe_exit;
 748     }
 749 }
 750
 751 sub _timeout_syspref {
 752     my $default_timeout = 600;
 753     my $timeout = C4::Context->preference('timeout') || $default_timeout;
 754
 755     # value in days, convert in seconds
 756     if ( $timeout =~ /^(\d+)[dD]$/ ) {
 757         $timeout = $1 * 86400;
 758     }
 759     # value in hours, convert in seconds
 760     elsif ( $timeout =~ /^(\d+)[hH]$/ ) {
 761         $timeout = $1 * 3600;
 762     }
 763     elsif ( $timeout !~ m/^\d+$/ ) {
 764         warn "The value of the system preference 'timeout' is not correct, defaulting to $default_timeout";
 765         $timeout = $default_timeout;
 766     }
 767
 768     return $timeout;
 769 }
 770
 771 sub checkauth {
 772     my $query = shift;
 773
 774     # Get shibboleth login attribute
 775     my $shib = C4::Context->config('useshibboleth') && shib_ok();
 776     my $shib_login = $shib ? get_login_shib() : undef;
 777
 778     # $authnotrequired will be set for scripts which will run without authentication
 779     my $authnotrequired = shift;
 780     my $flagsrequired   = shift;
 781     my $type            = shift;
 782     my $emailaddress    = shift;
 783     my $template_name   = shift;
 784     $type = 'opac' unless $type;
 785
 786     if ( $type eq 'opac' && !C4::Context->preference("OpacPublic") ) {
 787         my @allowed_scripts_for_private_opac = qw(
 788           opac-memberentry.tt
 789           opac-registration-email-sent.tt
 790           opac-registration-confirmation.tt
 791           opac-memberentry-update-submitted.tt
 792           opac-password-recovery.tt
 793           opac-reset-password.tt
 794         );
 795         $authnotrequired = 0 unless grep { $_ eq $template_name }
 796           @allowed_scripts_for_private_opac;
 797     }
 798
 799     my $timeout = _timeout_syspref();
 800
 801     my $cookie_mgr = Koha::CookieManager->new;
 802
 803     _version_check( $type, $query );
 804
 805     # state variables
 806     my $loggedin = 0;
 807     my $auth_state = 'failed';
 808     my %info;
 809     my ( $userid, $cookie, $sessionID, $flags );
 810     $cookie = [];
 811     my $logout = $query->param('logout.x');
 812
 813     my $anon_search_history;
 814     my $cas_ticket = '';
 815     # This parameter is the name of the CAS server we want to authenticate against,
 816     # when using authentication against multiple CAS servers, as configured in Auth_cas_servers.yaml
 817     my $casparam = $query->param('cas');
 818     my $q_userid = $query->param('userid') // '';
 819
 820     my $session;
 821     my $invalid_otp_token;
 822     my $require_2FA =
 823       ( $type ne "opac" # Only available for the staff interface
 824           && C4::Context->preference('TwoFactorAuthentication') ne "disabled" ) # If "enabled" or "enforced"
 825       ? 1 : 0;
 826
 827     # Basic authentication is incompatible with the use of Shibboleth,
 828     # as Shibboleth may return REMOTE_USER as a Shibboleth attribute,
 829     # and it may not be the attribute we want to use to match the koha login.
 830     #
 831     # Also, do not consider an empty REMOTE_USER.
 832     #
 833     # Finally, after those tests, we can assume (although if it would be better with
 834     # a syspref) that if we get a REMOTE_USER, that's from basic authentication,
 835     # and we can affect it to $userid.
 836     if ( !$shib and defined( $ENV{'REMOTE_USER'} ) and $ENV{'REMOTE_USER'} ne '' and $userid = $ENV{'REMOTE_USER'} ) {
 837
 838         # Using Basic Authentication, no cookies required
 839         $cookie = $cookie_mgr->replace_in_list( $cookie, $query->cookie(
 840             -name     => 'CGISESSID',
 841             -value    => '',
 842             -HttpOnly => 1,
 843             -secure => ( C4::Context->https_enabled() ? 1 : 0 ),
 844             -sameSite => 'Lax',
 845         ));
 846         $loggedin = 1;
 847     }
 848     elsif ( $emailaddress) {
 849         # the Google OpenID Connect passes an email address
 850     }
 851     elsif ( $sessionID = $query->cookie("CGISESSID") ) {    # assignment, not comparison
 852         my ( $return, $more_info );
 853         # NOTE: $flags in the following call is still undefined !
 854         ( $return, $session, $more_info ) = check_cookie_auth( $sessionID, $flags,
 855             { remote_addr => $ENV{REMOTE_ADDR}, skip_version_check => 1 }
 856         );
 857
 858         if ( $return eq 'ok' || $return eq 'additional-auth-needed' ) {
 859             $userid = $session->param('id');
 860         }
 861
 862         $auth_state =
 863             $return eq 'ok'                     ? 'completed'
 864           : $return eq 'additional-auth-needed' ? 'additional-auth-needed'
 865           :                                       'failed';
 866
 867         # We are at the second screen if the waiting-for-2FA is set in session
 868         # and otp_token param has been passed
 869         if (   $require_2FA
 870             && $auth_state eq 'additional-auth-needed'
 871             && ( my $otp_token = $query->param('otp_token') ) )
 872         {
 873             my $patron    = Koha::Patrons->find( { userid => $userid } );
 874             my $auth      = Koha::Auth::TwoFactorAuth->new( { patron => $patron } );
 875             my $verified = $auth->verify($otp_token, 1);
 876             $auth->clear;
 877             if ( $verified ) {
 878                 # The token is correct, the user is fully logged in!
 879                 $auth_state = 'completed';
 880                 $session->param( 'waiting-for-2FA', 0 );
 881                 $session->param( 'waiting-for-2FA-setup', 0 );
 882
 883                # This is an ugly trick to pass the test
 884                # $query->param('koha_login_context') && ( $q_userid ne $userid )
 885                # few lines later
 886                 $q_userid = $userid;
 887             }
 888             else {
 889                 $invalid_otp_token = 1;
 890             }
 891         }
 892
 893         if ( $auth_state eq 'completed' ) {
 894             Koha::Logger->get->debug(sprintf "AUTH_SESSION: (%s)\t%s %s - %s", map { $session->param($_) || q{} } qw(cardnumber firstname surname branch));
 895
 896             if ( ( $query->param('koha_login_context') && ( $q_userid ne $userid ) )
 897                 || ( $cas && $query->param('ticket') && !C4::Context->userenv->{'id'} )
 898                 || ( $shib && $shib_login && !$logout && !C4::Context->userenv->{'id'} )
 899             ) {
 900
 901                 #if a user enters an id ne to the id in the current session, we need to log them in...
 902                 #first we need to clear the anonymous session...
 903                 $anon_search_history = $session->param('search_history');
 904                 $session->delete();
 905                 $session->flush;
 906                 $cookie = $cookie_mgr->clear_unless( $query->cookie, @$cookie );
 907                 C4::Context::_unset_userenv($sessionID);
 908                 $sessionID = undef;
 909                 undef $userid; # IMPORTANT: this assures us a new session in code below
 910             } elsif (!$logout) {
 911
 912                 $cookie = $cookie_mgr->replace_in_list( $cookie, $query->cookie(
 913                     -name     => 'CGISESSID',
 914                     -value    => $session->id,
 915                     -HttpOnly => 1,
 916                     -secure => ( C4::Context->https_enabled() ? 1 : 0 ),
 917                     -sameSite => 'Lax',
 918                 ));
 919
 920                 $flags = haspermission( $userid, $flagsrequired );
 921                 unless ( $flags ) {
 922                     $auth_state = 'failed';
 923                     $info{'nopermission'} = 1;
 924                 }
 925             }
 926         } elsif ( !$logout ) {
 927             if ( $return eq 'expired' ) {
 928                 $info{timed_out} = 1;
 929             } elsif ( $return eq 'restricted' ) {
 930                 $info{oldip}        = $more_info->{old_ip};
 931                 $info{newip}        = $more_info->{new_ip};
 932                 $info{different_ip} = 1;
 933             } elsif ( $return eq 'password_expired' ) {
 934                 $info{password_has_expired} = 1;
 935             }
 936         }
 937     }
 938
 939     if ( $auth_state eq 'failed' || $logout ) {
 940         $sessionID = undef;
 941         $userid    = undef;
 942     }
 943
 944     if ($logout) {
 945
 946         # voluntary logout the user
 947         # check wether the user was using their shibboleth session or a local one
 948         my $shibSuccess = C4::Context->userenv ? C4::Context->userenv->{'shibboleth'} : undef;
 949         if ( $session ) {
 950             $session->delete();
 951             $session->flush;
 952         }
 953         C4::Context::_unset_userenv($sessionID);
 954         $cookie = $cookie_mgr->clear_unless( $query->cookie, @$cookie );
 955
 956         if ($cas and $caslogout) {
 957             logout_cas($query, $type);
 958         }
 959
 960         # If we are in a shibboleth session (shibboleth is enabled, a shibboleth match attribute is set and matches koha matchpoint)
 961         if ( $shib and $shib_login and $shibSuccess) {
 962             logout_shib($query);
 963         }
 964
 965         $session   = undef;
 966         $auth_state = 'logout';
 967     }
 968
 969     unless ( $userid ) {
 970         #we initiate a session prior to checking for a username to allow for anonymous sessions...
 971         if( !$session or !$sessionID ) { # if we cleared sessionID, we need a new session
 972             $session = get_session() or die "Auth ERROR: Cannot get_session()";
 973         }
 974
 975         # Save anonymous search history in new session so it can be retrieved
 976         # by get_template_and_user to store it in user's search history after
 977         # a successful login.
 978         if ($anon_search_history) {
 979             $session->param( 'search_history', $anon_search_history );
 980         }
 981
 982         $sessionID = $session->id;
 983         C4::Context->_new_userenv($sessionID);
 984         $cookie = $cookie_mgr->replace_in_list( $cookie, $query->cookie(
 985             -name     => 'CGISESSID',
 986             -value    => $sessionID,
 987             -HttpOnly => 1,
 988             -secure => ( C4::Context->https_enabled() ? 1 : 0 ),
 989             -sameSite => 'Lax',
 990         ));
 991         my $pki_field = C4::Context->preference('AllowPKIAuth');
 992         if ( !defined($pki_field) ) {
 993             print STDERR "ERROR: Missing system preference AllowPKIAuth.\n";
 994             $pki_field = 'None';
 995         }
 996         if ( ( $cas && $query->param('ticket') )
 997             || $q_userid
 998             || ( $shib && $shib_login )
 999             || $pki_field ne 'None'
1000             || $emailaddress )
1001         {
1002             my $password    = $query->param('password');
1003             my $shibSuccess = 0;
1004             my ( $return, $cardnumber );
1005
1006             # If shib is enabled and we have a shib login, does the login match a valid koha user
1007             if ( $shib && $shib_login ) {
1008                 my $retuserid;
1009
1010                 # Do not pass password here, else shib will not be checked in checkpw.
1011                 ( $return, $cardnumber, $retuserid ) = checkpw( $q_userid, undef, $query );
1012                 $userid      = $retuserid;
1013                 $shibSuccess = $return;
1014                 $info{'invalidShibLogin'} = 1 unless ($return);
1015             }
1016
1017             # If shib login and match were successful, skip further login methods
1018             unless ($shibSuccess) {
1019                 if ( $cas && $query->param('ticket') ) {
1020                     my $retuserid;
1021                     ( $return, $cardnumber, $retuserid, $cas_ticket ) =
1022                       checkpw( $userid, $password, $query, $type );
1023                     $userid = $retuserid;
1024                     $info{'invalidCasLogin'} = 1 unless ($return);
1025                 }
1026
1027                 elsif ( $emailaddress ) {
1028                     my $value = $emailaddress;
1029
1030                     # If we're looking up the email, there's a chance that the person
1031                     # doesn't have a userid. So if there is none, we pass along the
1032                     # borrower number, and the bits of code that need to know the user
1033                     # ID will have to be smart enough to handle that.
1034                     my $patrons = Koha::Patrons->search({ email => $value });
1035                     if ($patrons->count) {
1036
1037                         # First the userid, then the borrowernum
1038                         my $patron = $patrons->next;
1039                         $value = $patron->userid || $patron->borrowernumber;
1040                     } else {
1041                         undef $value;
1042                     }
1043                     $return = $value ? 1 : 0;
1044                     $userid = $value;
1045                 }
1046
1047                 elsif (
1048                     ( $pki_field eq 'Common Name' && $ENV{'SSL_CLIENT_S_DN_CN'} )
1049                     || ( $pki_field eq 'emailAddress'
1050                         && $ENV{'SSL_CLIENT_S_DN_Email'} )
1051                   )
1052                 {
1053                     my $value;
1054                     if ( $pki_field eq 'Common Name' ) {
1055                         $value = $ENV{'SSL_CLIENT_S_DN_CN'};
1056                     }
1057                     elsif ( $pki_field eq 'emailAddress' ) {
1058                         $value = $ENV{'SSL_CLIENT_S_DN_Email'};
1059
1060                         # If we're looking up the email, there's a chance that the person
1061                         # doesn't have a userid. So if there is none, we pass along the
1062                         # borrower number, and the bits of code that need to know the user
1063                         # ID will have to be smart enough to handle that.
1064                         my $patrons = Koha::Patrons->search({ email => $value });
1065                         if ($patrons->count) {
1066
1067                             # First the userid, then the borrowernum
1068                             my $patron = $patrons->next;
1069                             $value = $patron->userid || $patron->borrowernumber;
1070                         } else {
1071                             undef $value;
1072                         }
1073                     }
1074
1075                     $return = $value ? 1 : 0;
1076                     $userid = $value;
1077
1078                 }
1079                 else {
1080                     my $retuserid;
1081                     my $request_method = $query->request_method // q{};
1082
1083                     if (
1084                         $request_method eq 'POST'
1085                         || ( C4::Context->preference('AutoSelfCheckID')
1086                             && $q_userid eq C4::Context->preference('AutoSelfCheckID') )
1087                       )
1088                     {
1089
1090                         ( $return, $cardnumber, $retuserid, $cas_ticket ) =
1091                           checkpw( $q_userid, $password, $query, $type );
1092                         $userid = $retuserid if ($retuserid);
1093                         $info{'invalid_username_or_password'} = 1 unless ($return);
1094                     }
1095                 }
1096             }
1097
1098             # If shib configured and shibOnly enabled, we should ignore anything other than a shibboleth type login.
1099             if (
1100                    $shib
1101                 && !$shibSuccess
1102                 && (
1103                     (
1104                         ( $type eq 'opac' )
1105                         && C4::Context->preference('OPACShibOnly')
1106                     )
1107                     || ( ( $type ne 'opac' )
1108                         && C4::Context->preference('staffShibOnly') )
1109                 )
1110               )
1111             {
1112                 $return = 0;
1113             }
1114
1115             # $return: 1 = valid user
1116             if( $return && $return > 0 ) {
1117
1118                 if ( $flags = haspermission( $userid, $flagsrequired ) ) {
1119                     $auth_state = "logged_in";
1120                 }
1121                 else {
1122                     $auth_state = 'failed';
1123                     # FIXME We could add $return = 0; or even delete the session?
1124                     # Currently return == 1 and we will fill session info later on,
1125                     # although we do present an authorization failure. (Yes, the
1126                     # authentication was actually correct.)
1127                     $info{'nopermission'} = 1;
1128                     C4::Context::_unset_userenv($sessionID);
1129                 }
1130                 my ( $borrowernumber, $firstname, $surname, $userflags,
1131                     $branchcode, $branchname, $emailaddress, $desk_id,
1132                     $desk_name, $register_id, $register_name );
1133
1134                 if ( $return == 1 ) {
1135                     my $select = "
1136                     SELECT borrowernumber, firstname, surname, flags, borrowers.branchcode,
1137                     branches.branchname    as branchname, email
1138                     FROM borrowers
1139                     LEFT JOIN branches on borrowers.branchcode=branches.branchcode
1140                     ";
1141                     my $dbh = C4::Context->dbh;
1142                     my $sth = $dbh->prepare("$select where userid=?");
1143                     $sth->execute($userid);
1144                     unless ( $sth->rows ) {
1145                         $sth = $dbh->prepare("$select where cardnumber=?");
1146                         $sth->execute($cardnumber);
1147
1148                         unless ( $sth->rows ) {
1149                             $sth->execute($userid);
1150                         }
1151                     }
1152                     if ( $sth->rows ) {
1153                         ( $borrowernumber, $firstname, $surname, $userflags,
1154                             $branchcode, $branchname, $emailaddress ) = $sth->fetchrow;
1155                     }
1156
1157                     # launch a sequence to check if we have a ip for the branch, i
1158                     # if we have one we replace the branchcode of the userenv by the branch bound in the ip.
1159
1160                     my $ip = $ENV{'REMOTE_ADDR'};
1161
1162                     # if they specify at login, use that
1163                     if ( $query->param('branch') ) {
1164                         $branchcode = $query->param('branch');
1165                         my $library = Koha::Libraries->find($branchcode);
1166                         $branchname = $library? $library->branchname: '';
1167                     }
1168                     if ( $query->param('desk_id') ) {
1169                         $desk_id = $query->param('desk_id');
1170                         my $desk = Koha::Desks->find($desk_id);
1171                         $desk_name = $desk ? $desk->desk_name : '';
1172                     }
1173                     if ( C4::Context->preference('UseCashRegisters') ) {
1174                         my $register =
1175                           $query->param('register_id')
1176                           ? Koha::Cash::Registers->find($query->param('register_id'))
1177                           : Koha::Cash::Registers->search(
1178                             { branch => $branchcode, branch_default => 1 },
1179                             { rows   => 1 } )->single;
1180                         $register_id   = $register->id   if ($register);
1181                         $register_name = $register->name if ($register);
1182                     }
1183                     my $branches = { map { $_->branchcode => $_->unblessed } Koha::Libraries->search->as_list };
1184                     if ( $type ne 'opac' and C4::Context->preference('AutoLocation') ) {
1185
1186                         # we have to check they are coming from the right ip range
1187                         my $domain = $branches->{$branchcode}->{'branchip'};
1188                         $domain =~ s|\.\*||g;
1189                         if ( $ip !~ /^$domain/ ) {
1190                             $loggedin = 0;
1191                             $cookie = $cookie_mgr->replace_in_list( $cookie, $query->cookie(
1192                                 -name     => 'CGISESSID',
1193                                 -value    => '',
1194                                 -HttpOnly => 1,
1195                                 -secure => ( C4::Context->https_enabled() ? 1 : 0 ),
1196                                 -sameSite => 'Lax',
1197                             ));
1198                             $info{'wrongip'} = 1;
1199                         }
1200                     }
1201
1202                     foreach my $br ( keys %$branches ) {
1203
1204                         #     now we work with the treatment of ip
1205                         my $domain = $branches->{$br}->{'branchip'};
1206                         if ( $domain && $ip =~ /^$domain/ ) {
1207                             $branchcode = $branches->{$br}->{'branchcode'};
1208
1209                             # new op dev : add the branchname to the cookie
1210                             $branchname    = $branches->{$br}->{'branchname'};
1211                         }
1212                     }
1213
1214                     my $is_sco_user = 0;
1215                     if ( $query->param('sco_user_login') && ( $query->param('sco_user_login') eq '1' ) ){
1216                         $is_sco_user = 1;
1217                     }
1218
1219                     $session->param( 'number',       $borrowernumber );
1220                     $session->param( 'id',           $userid );
1221                     $session->param( 'cardnumber',   $cardnumber );
1222                     $session->param( 'firstname',    $firstname );
1223                     $session->param( 'surname',      $surname );
1224                     $session->param( 'branch',       $branchcode );
1225                     $session->param( 'branchname',   $branchname );
1226                     $session->param( 'desk_id',      $desk_id);
1227                     $session->param( 'desk_name',     $desk_name);
1228                     $session->param( 'flags',        $userflags );
1229                     $session->param( 'emailaddress', $emailaddress );
1230                     $session->param( 'ip',           $session->remote_addr() );
1231                     $session->param( 'lasttime',     time() );
1232                     $session->param( 'interface',    $type);
1233                     $session->param( 'shibboleth',   $shibSuccess );
1234                     $session->param( 'register_id',  $register_id );
1235                     $session->param( 'register_name',  $register_name );
1236                     $session->param( 'sco_user', $is_sco_user );
1237                 }
1238                 $session->param('cas_ticket', $cas_ticket) if $cas_ticket;
1239                 C4::Context->set_userenv(
1240                     $session->param('number'),       $session->param('id'),
1241                     $session->param('cardnumber'),   $session->param('firstname'),
1242                     $session->param('surname'),      $session->param('branch'),
1243                     $session->param('branchname'),   $session->param('flags'),
1244                     $session->param('emailaddress'), $session->param('shibboleth'),
1245                     $session->param('desk_id'),      $session->param('desk_name'),
1246                     $session->param('register_id'),  $session->param('register_name')
1247                 );
1248
1249             }
1250             # $return: 0 = invalid user
1251             # reset to anonymous session
1252             else {
1253                 if ($userid) {
1254                     $info{'invalid_username_or_password'} = 1;
1255                     C4::Context::_unset_userenv($sessionID);
1256                 }
1257                 $session->param( 'lasttime', time() );
1258                 $session->param( 'ip',       $session->remote_addr() );
1259                 $session->param( 'sessiontype', 'anon' );
1260                 $session->param( 'interface', $type);
1261             }
1262         }    # END if ( $q_userid
1263         elsif ( $type eq "opac" ) {
1264
1265             # anonymous sessions are created only for the OPAC
1266
1267             # setting a couple of other session vars...
1268             $session->param( 'ip',          $session->remote_addr() );
1269             $session->param( 'lasttime',    time() );
1270             $session->param( 'sessiontype', 'anon' );
1271             $session->param( 'interface', $type);
1272         }
1273         $session->flush;
1274     }    # END unless ($userid)
1275
1276
1277     if ( $auth_state eq 'logged_in' ) {
1278         $auth_state = 'completed';
1279
1280         # Auth is completed unless an additional auth is needed
1281         if ( $require_2FA ) {
1282             my $patron = Koha::Patrons->find({userid => $userid});
1283             if ( C4::Context->preference('TwoFactorAuthentication') eq "enforced" && $patron->auth_method eq 'password' ) {
1284                 $auth_state = 'setup-additional-auth-needed';
1285                 $session->param('waiting-for-2FA-setup', 1);
1286                 %info = ();# We remove the warnings/errors we may have set incorrectly before
1287             } elsif ( $patron->auth_method eq 'two-factor' ) {
1288                 # Ask for the OTP token
1289                 $auth_state = 'additional-auth-needed';
1290                 $session->param('waiting-for-2FA', 1);
1291                 %info = ();# We remove the warnings/errors we may have set incorrectly before
1292             }
1293         }
1294     }
1295
1296     # finished authentification, now respond
1297     if ( $auth_state eq 'completed' || $authnotrequired ) {
1298         # successful login
1299         unless (@$cookie) {
1300             $cookie = $cookie_mgr->replace_in_list( $cookie, $query->cookie(
1301                 -name     => 'CGISESSID',
1302                 -value    => '',
1303                 -HttpOnly => 1,
1304                 -secure => ( C4::Context->https_enabled() ? 1 : 0 ),
1305                 -sameSite => 'Lax',
1306             ));
1307         }
1308
1309         track_login_daily( $userid );
1310
1311         # In case, that this request was a login attempt, we want to prevent that users can repost the opac login
1312         # request. We therefore redirect the user to the requested page again without the login parameters.
1313         # See Post/Redirect/Get (PRG) design pattern: https://en.wikipedia.org/wiki/Post/Redirect/Get
1314         if ( $type eq "opac" && $query->param('koha_login_context') && $query->param('koha_login_context') ne 'sco' && $query->param('password') && $query->param('userid') ) {
1315             my $uri = URI->new($query->url(-relative=>1, -query_string=>1));
1316             $uri->query_param_delete('userid');
1317             $uri->query_param_delete('password');
1318             $uri->query_param_delete('koha_login_context');
1319             print $query->redirect(-uri => $uri->as_string, -cookie => $cookie, -status=>'303 See other');
1320             safe_exit;
1321         }
1322
1323         return ( $userid, $cookie, $sessionID, $flags );
1324     }
1325
1326     #
1327     #
1328     # AUTH rejected, show the login/password template, after checking the DB.
1329     #
1330     #
1331
1332     my $patron = Koha::Patrons->find({ userid => $q_userid }); # Not necessary logged in!
1333
1334     # get the inputs from the incoming query
1335     my @inputs = ();
1336     my @inputs_to_clean = qw( userid password ticket logout.x otp_token );
1337     foreach my $name ( param $query) {
1338         next if grep { $name eq $_ } @inputs_to_clean;
1339         my @value = $query->multi_param($name);
1340         push @inputs, { name => $name, value => $_ } for @value;
1341     }
1342
1343     my $LibraryNameTitle = C4::Context->preference("LibraryName");
1344     $LibraryNameTitle =~ s/<(?:\/?)(?:br|p)\s*(?:\/?)>/ /sgi;
1345     $LibraryNameTitle =~ s/<(?:[^<>'"]|'(?:[^']*)'|"(?:[^"]*)")*>//sg;
1346
1347     my $auth_template_name = ( $type eq 'opac' ) ? 'opac-auth.tt' : 'auth.tt';
1348     my $auth_error = $query->param('auth_error');
1349     my $template = C4::Templates::gettemplate( $auth_template_name, $type, $query );
1350     $template->param(
1351         login                                 => 1,
1352         INPUTS                                => \@inputs,
1353         script_name                           => get_script_name(),
1354         casAuthentication                     => C4::Context->preference("casAuthentication"),
1355         shibbolethAuthentication              => $shib,
1356         suggestion                            => C4::Context->preference("suggestion"),
1357         virtualshelves                        => C4::Context->preference("virtualshelves"),
1358         LibraryName                           => "" . C4::Context->preference("LibraryName"),
1359         LibraryNameTitle                      => "" . $LibraryNameTitle,
1360         opacuserlogin                         => C4::Context->preference("opacuserlogin"),
1361         OpacFavicon                           => C4::Context->preference("OpacFavicon"),
1362         opacreadinghistory                    => C4::Context->preference("opacreadinghistory"),
1363         opaclanguagesdisplay                  => C4::Context->preference("opaclanguagesdisplay"),
1364         OPACUserJS                            => C4::Context->preference("OPACUserJS"),
1365         opacbookbag                           => "" . C4::Context->preference("opacbookbag"),
1366         OpacCloud                             => C4::Context->preference("OpacCloud"),
1367         OpacTopissue                          => C4::Context->preference("OpacTopissue"),
1368         OpacAuthorities                       => C4::Context->preference("OpacAuthorities"),
1369         OpacBrowser                           => C4::Context->preference("OpacBrowser"),
1370         TagsEnabled                           => C4::Context->preference("TagsEnabled"),
1371         OPACUserCSS                           => C4::Context->preference("OPACUserCSS"),
1372         intranetcolorstylesheet               => C4::Context->preference("intranetcolorstylesheet"),
1373         intranetstylesheet                    => C4::Context->preference("intranetstylesheet"),
1374         IntranetNav                           => C4::Context->preference("IntranetNav"),
1375         IntranetFavicon                       => C4::Context->preference("IntranetFavicon"),
1376         IntranetUserCSS                       => C4::Context->preference("IntranetUserCSS"),
1377         IntranetUserJS                        => C4::Context->preference("IntranetUserJS"),
1378         IndependentBranches                   => C4::Context->preference("IndependentBranches"),
1379         AutoLocation                          => C4::Context->preference("AutoLocation"),
1380         wrongip                               => $info{'wrongip'},
1381         PatronSelfRegistration                => C4::Context->preference("PatronSelfRegistration"),
1382         PatronSelfRegistrationDefaultCategory => C4::Context->preference("PatronSelfRegistrationDefaultCategory"),
1383         opac_css_override                     => $ENV{'OPAC_CSS_OVERRIDE'},
1384         too_many_login_attempts               => ( $patron and $patron->account_locked ),
1385         password_has_expired                  => ( $patron and $patron->password_expired ),
1386         auth_error                            => $auth_error,
1387     );
1388
1389     $template->param( SCO_login => 1 ) if ( $query->param('sco_user_login') );
1390     $template->param( SCI_login => 1 ) if ( $query->param('sci_user_login') );
1391     $template->param( OpacPublic => C4::Context->preference("OpacPublic") );
1392     $template->param( loginprompt => 1 ) unless $info{'nopermission'};
1393     if ( $auth_state eq 'additional-auth-needed' ) {
1394         my $patron = Koha::Patrons->find( { userid => $userid } );
1395         $template->param(
1396             TwoFA_prompt => 1,
1397             invalid_otp_token => $invalid_otp_token,
1398             notice_email_address => $patron->notice_email_address, # We could also pass logged_in_user if necessary
1399         );
1400     }
1401
1402     if ( $auth_state eq 'setup-additional-auth-needed' ) {
1403         $template->param(
1404             TwoFA_setup => 1,
1405         );
1406     }
1407
1408     if ( $type eq 'opac' ) {
1409         require Koha::Virtualshelves;
1410         my $some_public_shelves = Koha::Virtualshelves->get_some_shelves(
1411             {
1412                 public => 1,
1413             }
1414         );
1415         $template->param(
1416             some_public_shelves  => $some_public_shelves,
1417         );
1418     }
1419
1420     if ($cas) {
1421
1422         # Is authentication against multiple CAS servers enabled?
1423         require C4::Auth_with_cas;
1424         if ( multipleAuth() && !$casparam ) {
1425             my $casservers = getMultipleAuth();
1426             my @tmplservers;
1427             foreach my $key ( keys %$casservers ) {
1428                 push @tmplservers, { name => $key, value => login_cas_url( $query, $key, $type ) . "?cas=$key" };
1429             }
1430             $template->param(
1431                 casServersLoop => \@tmplservers
1432             );
1433         } else {
1434             $template->param(
1435                 casServerUrl => login_cas_url($query, undef, $type),
1436             );
1437         }
1438
1439         $template->param(
1440             invalidCasLogin => $info{'invalidCasLogin'}
1441         );
1442     }
1443
1444     if ($shib) {
1445         #If shibOnly is enabled just go ahead and redirect directly
1446         if ( (($type eq 'opac') && C4::Context->preference('OPACShibOnly')) || (($type ne 'opac') && C4::Context->preference('staffShibOnly')) ) {
1447             my $redirect_url = login_shib_url( $query );
1448             print $query->redirect( -uri => "$redirect_url", -status => 303 );
1449             safe_exit;
1450         }
1451
1452         $template->param(
1453             shibbolethAuthentication => $shib,
1454             shibbolethLoginUrl       => login_shib_url($query),
1455         );
1456     }
1457
1458     if (C4::Context->preference('GoogleOpenIDConnect')) {
1459         if ($query->param("OpenIDConnectFailed")) {
1460             my $reason = $query->param('OpenIDConnectFailed');
1461             $template->param(invalidGoogleOpenIDConnectLogin => $reason);
1462         }
1463     }
1464
1465     $template->param(
1466         LibraryName => C4::Context->preference("LibraryName"),
1467     );
1468     $template->param(%info);
1469
1470     #    $cookie = $query->cookie(CGISESSID => $session->id
1471     #   );
1472     print $query->header(
1473         {   type              => 'text/html',
1474             charset           => 'utf-8',
1475             cookie            => $cookie,
1476             'X-Frame-Options' => 'SAMEORIGIN',
1477             -sameSite => 'Lax'
1478         }
1479       ),
1480       $template->output;
1481     safe_exit;
1482 }
1483
1484 =head2 check_api_auth
1485
1486   ($status, $cookie, $sessionId) = check_api_auth($query, $userflags);
1487
1488 Given a CGI query containing the parameters 'userid' and 'password' and/or a session
1489 cookie, determine if the user has the privileges specified by C<$userflags>.
1490
1491 C<check_api_auth> is is meant for authenticating users of web services, and
1492 consequently will always return and will not attempt to redirect the user
1493 agent.
1494
1495 If a valid session cookie is already present, check_api_auth will return a status
1496 of "ok", the cookie, and the Koha session ID.
1497
1498 If no session cookie is present, check_api_auth will check the 'userid' and 'password
1499 parameters and create a session cookie and Koha session if the supplied credentials
1500 are OK.
1501
1502 Possible return values in C<$status> are:
1503
1504 =over
1505
1506 =item "ok" -- user authenticated; C<$cookie> and C<$sessionid> have valid values.
1507
1508 =item "failed" -- credentials are not correct; C<$cookie> and C<$sessionid> are undef
1509
1510 =item "maintenance" -- DB is in maintenance mode; no login possible at the moment
1511
1512 =item "expired -- session cookie has expired; API user should resubmit userid and password
1513
1514 =item "restricted" -- The IP has changed (if SessionRestrictionByIP)
1515
1516 =item "additional-auth-needed -- User is in an authentication process that is not finished
1517
1518 =back
1519
1520 =cut
1521
1522 sub check_api_auth {
1523
1524     my $query         = shift;
1525     my $flagsrequired = shift;
1526     my $timeout = _timeout_syspref();
1527
1528     unless ( C4::Context->preference('Version') ) {
1529
1530         # database has not been installed yet
1531         return ( "maintenance", undef, undef );
1532     }
1533     my $kohaversion = Koha::version();
1534     $kohaversion =~ s/(.*\..*)\.(.*)\.(.*)/$1$2$3/;
1535     if ( C4::Context->preference('Version') < $kohaversion ) {
1536
1537         # database in need of version update; assume that
1538         # no API should be called while databsae is in
1539         # this condition.
1540         return ( "maintenance", undef, undef );
1541     }
1542
1543     my ( $sessionID, $session );
1544     unless ( $query->param('userid') ) {
1545         $sessionID = $query->cookie("CGISESSID");
1546     }
1547     if ( $sessionID && not( $cas && $query->param('PT') ) ) {
1548
1549         my $return;
1550         ( $return, $session, undef ) = check_cookie_auth(
1551             $sessionID, $flagsrequired, { remote_addr => $ENV{REMOTE_ADDR} } );
1552
1553         return ( $return, undef, undef ) # Cookie auth failed
1554             if $return ne "ok";
1555
1556         my $cookie = $query->cookie(
1557             -name     => 'CGISESSID',
1558             -value    => $session->id,
1559             -HttpOnly => 1,
1560             -secure => ( C4::Context->https_enabled() ? 1 : 0 ),
1561             -sameSite => 'Lax'
1562         );
1563         return ( $return, $cookie, $session ); # return == 'ok' here
1564
1565     } else {
1566
1567         # new login
1568         my $userid   = $query->param('userid');
1569         my $password = $query->param('password');
1570         my ( $return, $cardnumber, $cas_ticket );
1571
1572         # Proxy CAS auth
1573         if ( $cas && $query->param('PT') ) {
1574             my $retuserid;
1575
1576             # In case of a CAS authentication, we use the ticket instead of the password
1577             my $PT = $query->param('PT');
1578             ( $return, $cardnumber, $userid, $cas_ticket ) = check_api_auth_cas( $PT, $query );    # EXTERNAL AUTH
1579         } else {
1580
1581             # User / password auth
1582             unless ( $userid and $password ) {
1583
1584                 # caller did something wrong, fail the authenticateion
1585                 return ( "failed", undef, undef );
1586             }
1587             my $newuserid;
1588             ( $return, $cardnumber, $newuserid, $cas_ticket ) = checkpw( $userid, $password, $query );
1589         }
1590
1591         if ( $return and haspermission( $userid, $flagsrequired ) ) {
1592             my $session = get_session("");
1593             return ( "failed", undef, undef ) unless $session;
1594
1595             my $sessionID = $session->id;
1596             C4::Context->_new_userenv($sessionID);
1597             my $cookie = $query->cookie(
1598                 -name     => 'CGISESSID',
1599                 -value    => $sessionID,
1600                 -HttpOnly => 1,
1601                 -secure => ( C4::Context->https_enabled() ? 1 : 0 ),
1602                 -sameSite => 'Lax'
1603             );
1604             if ( $return == 1 ) {
1605                 my (
1606                     $borrowernumber, $firstname,  $surname,
1607                     $userflags,      $branchcode, $branchname,
1608                     $emailaddress
1609                 );
1610                 my $dbh = C4::Context->dbh;
1611                 my $sth =
1612                   $dbh->prepare(
1613 "select borrowernumber, firstname, surname, flags, borrowers.branchcode, branches.branchname as branchname, email from borrowers left join branches on borrowers.branchcode=branches.branchcode where userid=?"
1614                   );
1615                 $sth->execute($userid);
1616                 (
1617                     $borrowernumber, $firstname,  $surname,
1618                     $userflags,      $branchcode, $branchname,
1619                     $emailaddress
1620                 ) = $sth->fetchrow if ( $sth->rows );
1621
1622                 unless ( $sth->rows ) {
1623                     my $sth = $dbh->prepare(
1624 "select borrowernumber, firstname, surname, flags, borrowers.branchcode, branches.branchname as branchname, email from borrowers left join branches on borrowers.branchcode=branches.branchcode where cardnumber=?"
1625                     );
1626                     $sth->execute($cardnumber);
1627                     (
1628                         $borrowernumber, $firstname,  $surname,
1629                         $userflags,      $branchcode, $branchname,
1630                         $emailaddress
1631                     ) = $sth->fetchrow if ( $sth->rows );
1632
1633                     unless ( $sth->rows ) {
1634                         $sth->execute($userid);
1635                         (
1636                             $borrowernumber, $firstname,  $surname,       $userflags,
1637                             $branchcode,     $branchname, $emailaddress
1638                         ) = $sth->fetchrow if ( $sth->rows );
1639                     }
1640                 }
1641
1642                 my $ip = $ENV{'REMOTE_ADDR'};
1643
1644                 # if they specify at login, use that
1645                 if ( $query->param('branch') ) {
1646                     $branchcode = $query->param('branch');
1647                     my $library = Koha::Libraries->find($branchcode);
1648                     $branchname = $library? $library->branchname: '';
1649                 }
1650                 my $branches = { map { $_->branchcode => $_->unblessed } Koha::Libraries->search->as_list };
1651                 foreach my $br ( keys %$branches ) {
1652
1653                     #     now we work with the treatment of ip
1654                     my $domain = $branches->{$br}->{'branchip'};
1655                     if ( $domain && $ip =~ /^$domain/ ) {
1656                         $branchcode = $branches->{$br}->{'branchcode'};
1657
1658                         # new op dev : add the branchname to the cookie
1659                         $branchname    = $branches->{$br}->{'branchname'};
1660                     }
1661                 }
1662                 $session->param( 'number',       $borrowernumber );
1663                 $session->param( 'id',           $userid );
1664                 $session->param( 'cardnumber',   $cardnumber );
1665                 $session->param( 'firstname',    $firstname );
1666                 $session->param( 'surname',      $surname );
1667                 $session->param( 'branch',       $branchcode );
1668                 $session->param( 'branchname',   $branchname );
1669                 $session->param( 'flags',        $userflags );
1670                 $session->param( 'emailaddress', $emailaddress );
1671                 $session->param( 'ip',           $session->remote_addr() );
1672                 $session->param( 'lasttime',     time() );
1673                 $session->param( 'interface',    'api'  );
1674             }
1675             $session->param( 'cas_ticket', $cas_ticket);
1676             C4::Context->set_userenv(
1677                 $session->param('number'),       $session->param('id'),
1678                 $session->param('cardnumber'),   $session->param('firstname'),
1679                 $session->param('surname'),      $session->param('branch'),
1680                 $session->param('branchname'),   $session->param('flags'),
1681                 $session->param('emailaddress'), $session->param('shibboleth'),
1682                 $session->param('desk_id'),      $session->param('desk_name'),
1683                 $session->param('register_id'),  $session->param('register_name')
1684             );
1685             return ( "ok", $cookie, $sessionID );
1686         } else {
1687             return ( "failed", undef, undef );
1688         }
1689     }
1690 }
1691
1692 =head2 check_cookie_auth
1693
1694   ($status, $sessionId) = check_cookie_auth($cookie, $userflags);
1695
1696 Given a CGISESSID cookie set during a previous login to Koha, determine
1697 if the user has the privileges specified by C<$userflags>. C<$userflags>
1698 is passed unaltered into C<haspermission> and as such accepts all options
1699 avaiable to that routine with the one caveat that C<check_api_auth> will
1700 also allow 'undef' to be passed and in such a case the permissions check
1701 will be skipped altogether.
1702
1703 C<check_cookie_auth> is meant for authenticating special services
1704 such as tools/upload-file.pl that are invoked by other pages that
1705 have been authenticated in the usual way.
1706
1707 Possible return values in C<$status> are:
1708
1709 =over
1710
1711 =item "ok" -- user authenticated; C<$sessionID> have valid values.
1712
1713 =item "anon" -- user not authenticated but valid for anonymous session.
1714
1715 =item "failed" -- credentials are not correct; C<$sessionid> are undef
1716
1717 =item "maintenance" -- DB is in maintenance mode; no login possible at the moment
1718
1719 =item "expired -- session cookie has expired; API user should resubmit userid and password
1720
1721 =item "restricted" -- The IP has changed (if SessionRestrictionByIP)
1722
1723 =back
1724
1725 =cut
1726
1727 sub check_cookie_auth {
1728     my $sessionID     = shift;
1729     my $flagsrequired = shift;
1730     my $params        = shift;
1731
1732     my $remote_addr = $params->{remote_addr} || $ENV{REMOTE_ADDR};
1733
1734     my $skip_version_check = $params->{skip_version_check}; # Only for checkauth
1735
1736     unless ( $skip_version_check ) {
1737         unless ( C4::Context->preference('Version') ) {
1738
1739             # database has not been installed yet
1740             return ( "maintenance", undef );
1741         }
1742         my $kohaversion = Koha::version();
1743         $kohaversion =~ s/(.*\..*)\.(.*)\.(.*)/$1$2$3/;
1744         if ( C4::Context->preference('Version') < $kohaversion ) {
1745
1746             # database in need of version update; assume that
1747             # no API should be called while databsae is in
1748             # this condition.
1749             return ( "maintenance", undef );
1750         }
1751     }
1752
1753     # see if we have a valid session cookie already
1754     # however, if a userid parameter is present (i.e., from
1755     # a form submission, assume that any current cookie
1756     # is to be ignored
1757     unless ( $sessionID ) {
1758         return ( "failed", undef );
1759     }
1760     C4::Context::_unset_userenv($sessionID); # remove old userenv first
1761     my $session   = get_session($sessionID);
1762     if ($session) {
1763         my $userid   = $session->param('id');
1764         my $ip       = $session->param('ip');
1765         my $lasttime = $session->param('lasttime');
1766         my $timeout = _timeout_syspref();
1767
1768         if ( !$lasttime || ( $lasttime < time() - $timeout ) ) {
1769             # time out
1770             $session->delete();
1771             $session->flush;
1772             return ("expired", undef);
1773
1774         } elsif ( C4::Context->preference('SessionRestrictionByIP') && $ip ne $remote_addr ) {
1775             # IP address changed
1776             $session->delete();
1777             $session->flush;
1778             return ( "restricted", undef, { old_ip => $ip, new_ip => $remote_addr});
1779
1780         } elsif ( $userid ) {
1781             $session->param( 'lasttime', time() );
1782             my $patron = Koha::Patrons->find({ userid => $userid });
1783             $patron = Koha::Patrons->find({ cardnumber => $userid })
1784               unless $patron;
1785             return ("password_expired", undef ) if $patron->password_expired;
1786             my $flags = defined($flagsrequired) ? haspermission( $userid, $flagsrequired ) : 1;
1787             if ($flags) {
1788                 C4::Context->_new_userenv($sessionID);
1789                 C4::Context->interface($session->param('interface'));
1790                 C4::Context->set_userenv(
1791                     $session->param('number'),       $session->param('id') // '',
1792                     $session->param('cardnumber'),   $session->param('firstname'),
1793                     $session->param('surname'),      $session->param('branch'),
1794                     $session->param('branchname'),   $session->param('flags'),
1795                     $session->param('emailaddress'), $session->param('shibboleth'),
1796                     $session->param('desk_id'),      $session->param('desk_name'),
1797                     $session->param('register_id'),  $session->param('register_name')
1798                 );
1799                 if ( C4::Context->preference('TwoFactorAuthentication') ne 'disabled' ) {
1800                     return ( "additional-auth-needed", $session )
1801                         if $session->param('waiting-for-2FA');
1802
1803                     return ( "setup-additional-auth-needed", $session )
1804                         if $session->param('waiting-for-2FA-setup');
1805                 }
1806
1807                 return ( "ok", $session );
1808             } else {
1809                 $session->delete();
1810                 $session->flush;
1811                 return ( "failed", undef );
1812             }
1813
1814         } else {
1815             C4::Context->_new_userenv($sessionID);
1816             C4::Context->interface($session->param('interface'));
1817             C4::Context->set_userenv( undef, q{} );
1818             return ( "anon", $session );
1819         }
1820     } else {
1821         return ( "expired", undef );
1822     }
1823 }
1824
1825 =head2 get_session
1826
1827   use CGI::Session;
1828   my $session = get_session($sessionID);
1829
1830 Given a session ID, retrieve the CGI::Session object used to store
1831 the session's state.  The session object can be used to store
1832 data that needs to be accessed by different scripts during a
1833 user's session.
1834
1835 If the C<$sessionID> parameter is an empty string, a new session
1836 will be created.
1837
1838 =cut
1839
1840 sub _get_session_params {
1841     my $storage_method = C4::Context->preference('SessionStorage');
1842     if ( $storage_method eq 'mysql' ) {
1843         my $dbh = C4::Context->dbh;
1844         return { dsn => "serializer:yamlxs;driver:MySQL;id:md5", dsn_args => { Handle => $dbh } };
1845     }
1846     elsif ( $storage_method eq 'Pg' ) {
1847         my $dbh = C4::Context->dbh;
1848         return { dsn => "serializer:yamlxs;driver:PostgreSQL;id:md5", dsn_args => { Handle => $dbh } };
1849     }
1850     elsif ( $storage_method eq 'memcached' && Koha::Caches->get_instance->memcached_cache ) {
1851         my $memcached = Koha::Caches->get_instance()->memcached_cache;
1852         return { dsn => "serializer:yamlxs;driver:memcached;id:md5", dsn_args => { Memcached => $memcached } };
1853     }
1854     else {
1855         # catch all defaults to tmp should work on all systems
1856         my $dir = C4::Context::temporary_directory;
1857         my $instance = C4::Context->config( 'database' ); #actually for packages not exactly the instance name, but generally safer to leave it as it is
1858         return { dsn => "serializer:yamlxs;driver:File;id:md5", dsn_args => { Directory => "$dir/cgisess_$instance" } };
1859     }
1860 }
1861
1862 sub get_session {
1863     my $sessionID      = shift;
1864     my $params = _get_session_params();
1865     my $session;
1866     if( $sessionID ) { # find existing
1867         CGI::Session::ErrorHandler->set_error( q{} ); # clear error, cpan issue #111463
1868         $session = CGI::Session->load( $params->{dsn}, $sessionID, $params->{dsn_args} );
1869     } else {
1870         $session = CGI::Session->new( $params->{dsn}, $sessionID, $params->{dsn_args} );
1871         # no need to flush here
1872     }
1873     return $session;
1874 }
1875
1876 =head2 create_basic_session
1877
1878 my $session = create_basic_session({ patron => $patron, interface => $interface });
1879
1880 Creates a session and adds all basic parameters for a session to work
1881
1882 =cut
1883
1884 sub create_basic_session {
1885     my $params    = shift;
1886     my $patron    = $params->{patron};
1887     my $interface = $params->{interface};
1888
1889     $interface = 'intranet' if $interface eq 'staff';
1890
1891     my $session = get_session("");
1892
1893     $session->param( 'number',       $patron->borrowernumber );
1894     $session->param( 'id',           $patron->userid );
1895     $session->param( 'cardnumber',   $patron->cardnumber );
1896     $session->param( 'firstname',    $patron->firstname );
1897     $session->param( 'surname',      $patron->surname );
1898     $session->param( 'branch',       $patron->branchcode );
1899     $session->param( 'branchname',   $patron->library->branchname );
1900     $session->param( 'flags',        $patron->flags );
1901     $session->param( 'emailaddress', $patron->email );
1902     $session->param( 'ip',           $session->remote_addr() );
1903     $session->param( 'lasttime',     time() );
1904     $session->param( 'interface',    $interface);
1905
1906     return $session;
1907 }
1908
1909
1910 # FIXME no_set_userenv may be replaced with force_branchcode_for_userenv
1911 # (or something similar)
1912 # Currently it's only passed from C4::SIP::ILS::Patron::check_password, but
1913 # not having a userenv defined could cause a crash.
1914 sub checkpw {
1915     my ( $userid, $password, $query, $type, $no_set_userenv ) = @_;
1916     $type = 'opac' unless $type;
1917
1918     # Get shibboleth login attribute
1919     my $shib = C4::Context->config('useshibboleth') && shib_ok();
1920     my $shib_login = $shib ? get_login_shib() : undef;
1921
1922     my @return;
1923     my $patron;
1924     if ( defined $userid ){
1925         $patron = Koha::Patrons->find({ userid => $userid });
1926         $patron = Koha::Patrons->find({ cardnumber => $userid }) unless $patron;
1927     }
1928     my $check_internal_as_fallback = 0;
1929     my $passwd_ok = 0;
1930     # Note: checkpw_* routines returns:
1931     # 1 if auth is ok
1932     # 0 if auth is nok
1933     # -1 if user bind failed (LDAP only)
1934
1935     if ( $patron and ( $patron->account_locked )  ) {
1936         # Nothing to check, account is locked
1937     } elsif ($ldap && defined($password)) {
1938         my ( $retval, $retcard, $retuserid ) = checkpw_ldap(@_);    # EXTERNAL AUTH
1939         if ( $retval == 1 ) {
1940             @return = ( $retval, $retcard, $retuserid );
1941             $passwd_ok = 1;
1942         }
1943         $check_internal_as_fallback = 1 if $retval == 0;
1944
1945     } elsif ( $cas && $query && $query->param('ticket') ) {
1946
1947         # In case of a CAS authentication, we use the ticket instead of the password
1948         my $ticket = $query->param('ticket');
1949         $query->delete('ticket');                                   # remove ticket to come back to original URL
1950         my ( $retval, $retcard, $retuserid, $cas_ticket ) = checkpw_cas( $ticket, $query, $type );    # EXTERNAL AUTH
1951         if ( $retval ) {
1952             @return = ( $retval, $retcard, $retuserid, $cas_ticket );
1953         } else {
1954             @return = (0);
1955         }
1956         $passwd_ok = $retval;
1957     }
1958
1959     # If we are in a shibboleth session (shibboleth is enabled, and a shibboleth match attribute is present)
1960     # Check for password to asertain whether we want to be testing against shibboleth or another method this
1961     # time around.
1962     elsif ( $shib && $shib_login && !$password ) {
1963
1964         # In case of a Shibboleth authentication, we expect a shibboleth user attribute
1965         # (defined under shibboleth mapping in koha-conf.xml) to contain the login of the
1966         # shibboleth-authenticated user
1967
1968         # Then, we check if it matches a valid koha user
1969         if ($shib_login) {
1970             my ( $retval, $retcard, $retuserid ) = C4::Auth_with_shibboleth::checkpw_shib($shib_login);    # EXTERNAL AUTH
1971             if ( $retval ) {
1972                 @return = ( $retval, $retcard, $retuserid );
1973             }
1974             $passwd_ok = $retval;
1975         }
1976     } else {
1977         $check_internal_as_fallback = 1;
1978     }
1979
1980     # INTERNAL AUTH
1981     if ( $check_internal_as_fallback ) {
1982         @return = checkpw_internal( $userid, $password, $no_set_userenv);
1983         $passwd_ok = 1 if $return[0] > 0; # 1 or 2
1984     }
1985
1986     if( $patron ) {
1987         if ( $passwd_ok ) {
1988             $patron->update({ login_attempts => 0 });
1989             if( $patron->password_expired ){
1990                 @return = (-2);
1991             }
1992         } elsif( !$patron->account_locked ) {
1993             $patron->update({ login_attempts => $patron->login_attempts + 1 });
1994         }
1995     }
1996
1997     # Optionally log success or failure
1998     if( $patron && $passwd_ok && C4::Context->preference('AuthSuccessLog') ) {
1999         logaction( 'AUTH', 'SUCCESS', $patron->id, "Valid password for $userid", $type );
2000     } elsif( !$passwd_ok && C4::Context->preference('AuthFailureLog') ) {
2001         logaction( 'AUTH', 'FAILURE', $patron ? $patron->id : 0, "Wrong password for $userid", $type );
2002     }
2003
2004     return @return;
2005 }
2006
2007 sub checkpw_internal {
2008     my ( $userid, $password, $no_set_userenv ) = @_;
2009
2010     $password = Encode::encode( 'UTF-8', $password )
2011       if Encode::is_utf8($password);
2012
2013     my $dbh = C4::Context->dbh;
2014     my $sth =
2015       $dbh->prepare(
2016         "select password,cardnumber,borrowernumber,userid,firstname,surname,borrowers.branchcode,branches.branchname,flags from borrowers join branches on borrowers.branchcode=branches.branchcode where userid=?"
2017       );
2018     $sth->execute($userid);
2019     if ( $sth->rows ) {
2020         my ( $stored_hash, $cardnumber, $borrowernumber, $userid, $firstname,
2021             $surname, $branchcode, $branchname, $flags )
2022           = $sth->fetchrow;
2023
2024         if ( checkpw_hash( $password, $stored_hash ) ) {
2025
2026             C4::Context->set_userenv( "$borrowernumber", $userid, $cardnumber,
2027                 $firstname, $surname, $branchcode, $branchname, $flags ) unless $no_set_userenv;
2028             return 1, $cardnumber, $userid;
2029         }
2030     }
2031     $sth =
2032       $dbh->prepare(
2033         "select password,cardnumber,borrowernumber,userid,firstname,surname,borrowers.branchcode,branches.branchname,flags from borrowers join branches on borrowers.branchcode=branches.branchcode where cardnumber=?"
2034       );
2035     $sth->execute($userid);
2036     if ( $sth->rows ) {
2037         my ( $stored_hash, $cardnumber, $borrowernumber, $userid, $firstname,
2038             $surname, $branchcode, $branchname, $flags )
2039           = $sth->fetchrow;
2040
2041         if ( checkpw_hash( $password, $stored_hash ) ) {
2042
2043             C4::Context->set_userenv( $borrowernumber, $userid, $cardnumber,
2044                 $firstname, $surname, $branchcode, $branchname, $flags ) unless $no_set_userenv;
2045             return 1, $cardnumber, $userid;
2046         }
2047     }
2048     return 0;
2049 }
2050
2051 sub checkpw_hash {
2052     my ( $password, $stored_hash ) = @_;
2053
2054     return if $stored_hash eq '!';
2055
2056     # check what encryption algorithm was implemented: Bcrypt - if the hash starts with '$2' it is Bcrypt else md5
2057     my $hash;
2058     if ( substr( $stored_hash, 0, 2 ) eq '$2' ) {
2059         $hash = hash_password( $password, $stored_hash );
2060     } else {
2061         $hash = md5_base64($password);
2062     }
2063     return $hash eq $stored_hash;
2064 }
2065
2066 =head2 getuserflags
2067
2068     my $authflags = getuserflags($flags, $userid, [$dbh]);
2069
2070 Translates integer flags into permissions strings hash.
2071
2072 C<$flags> is the integer userflags value ( borrowers.userflags )
2073 C<$userid> is the members.userid, used for building subpermissions
2074 C<$authflags> is a hashref of permissions
2075
2076 =cut
2077
2078 sub getuserflags {
2079     my $flags  = shift;
2080     my $userid = shift;
2081     my $dbh    = @_ ? shift : C4::Context->dbh;
2082     my $userflags;
2083     {
2084         # I don't want to do this, but if someone logs in as the database
2085         # user, it would be preferable not to spam them to death with
2086         # numeric warnings. So, we make $flags numeric.
2087         no warnings 'numeric';
2088         $flags += 0;
2089     }
2090     my $sth = $dbh->prepare("SELECT bit, flag, defaulton FROM userflags");
2091     $sth->execute;
2092
2093     while ( my ( $bit, $flag, $defaulton ) = $sth->fetchrow ) {
2094         if ( ( $flags & ( 2**$bit ) ) || $defaulton ) {
2095             $userflags->{$flag} = 1;
2096         }
2097         else {
2098             $userflags->{$flag} = 0;
2099         }
2100     }
2101
2102     # get subpermissions and merge with top-level permissions
2103     my $user_subperms = get_user_subpermissions($userid);
2104     foreach my $module ( keys %$user_subperms ) {
2105         next if $userflags->{$module} == 1;    # user already has permission for everything in this module
2106         $userflags->{$module} = $user_subperms->{$module};
2107     }
2108
2109     return $userflags;
2110 }
2111
2112 =head2 get_user_subpermissions
2113
2114   $user_perm_hashref = get_user_subpermissions($userid);
2115
2116 Given the userid (note, not the borrowernumber) of a staff user,
2117 return a hashref of hashrefs of the specific subpermissions
2118 accorded to the user.  An example return is
2119
2120  {
2121     tools => {
2122         export_catalog => 1,
2123         import_patrons => 1,
2124     }
2125  }
2126
2127 The top-level hash-key is a module or function code from
2128 userflags.flag, while the second-level key is a code
2129 from permissions.
2130
2131 The results of this function do not give a complete picture
2132 of the functions that a staff user can access; it is also
2133 necessary to check borrowers.flags.
2134
2135 =cut
2136
2137 sub get_user_subpermissions {
2138     my $userid = shift;
2139
2140     my $dbh = C4::Context->dbh;
2141     my $sth = $dbh->prepare( "SELECT flag, user_permissions.code
2142                              FROM user_permissions
2143                              JOIN permissions USING (module_bit, code)
2144                              JOIN userflags ON (module_bit = bit)
2145                              JOIN borrowers USING (borrowernumber)
2146                              WHERE userid = ?" );
2147     $sth->execute($userid);
2148
2149     my $user_perms = {};
2150     while ( my $perm = $sth->fetchrow_hashref ) {
2151         $user_perms->{ $perm->{'flag'} }->{ $perm->{'code'} } = 1;
2152     }
2153     return $user_perms;
2154 }
2155
2156 =head2 get_all_subpermissions
2157
2158   my $perm_hashref = get_all_subpermissions();
2159
2160 Returns a hashref of hashrefs defining all specific
2161 permissions currently defined.  The return value
2162 has the same structure as that of C<get_user_subpermissions>,
2163 except that the innermost hash value is the description
2164 of the subpermission.
2165
2166 =cut
2167
2168 sub get_all_subpermissions {
2169     my $dbh = C4::Context->dbh;
2170     my $sth = $dbh->prepare( "SELECT flag, code
2171                              FROM permissions
2172                              JOIN userflags ON (module_bit = bit)" );
2173     $sth->execute();
2174
2175     my $all_perms = {};
2176     while ( my $perm = $sth->fetchrow_hashref ) {
2177         $all_perms->{ $perm->{'flag'} }->{ $perm->{'code'} } = 1;
2178     }
2179     return $all_perms;
2180 }
2181
2182 =head2 haspermission
2183
2184   $flagsrequired = '*';                                 # Any permission at all
2185   $flagsrequired = 'a_flag';                            # a_flag must be satisfied (all subpermissions)
2186   $flagsrequired = [ 'a_flag', 'b_flag' ];              # a_flag OR b_flag must be satisfied
2187   $flagsrequired = { 'a_flag => 1, 'b_flag' => 1 };     # a_flag AND b_flag must be satisfied
2188   $flagsrequired = { 'a_flag' => 'sub_a' };             # sub_a of a_flag must be satisfied
2189   $flagsrequired = { 'a_flag' => [ 'sub_a, 'sub_b' ] }; # sub_a OR sub_b of a_flag must be satisfied
2190
2191   $flags = ($userid, $flagsrequired);
2192
2193 C<$userid> the userid of the member
2194 C<$flags> is a query structure similar to that used by SQL::Abstract that
2195 denotes the combination of flags required. It is a required parameter.
2196
2197 The main logic of this method is that things in arrays are OR'ed, and things
2198 in hashes are AND'ed. The `*` character can be used, at any depth, to denote `ANY`
2199
2200 Returns member's flags or 0 if a permission is not met.
2201
2202 =cut
2203
2204 sub _dispatch {
2205     my ($required, $flags) = @_;
2206
2207     my $ref = ref($required);
2208     if ($ref eq '') {
2209         if ($required eq '*') {
2210             return 0 unless ( $flags or ref( $flags ) );
2211         } else {
2212             return 0 unless ( $flags and (!ref( $flags ) || $flags->{$required} ));
2213         }
2214     } elsif ($ref eq 'HASH') {
2215         foreach my $key (keys %{$required}) {
2216             next if $flags == 1;
2217             my $require = $required->{$key};
2218             my $rflags  = $flags->{$key};
2219             return 0 unless _dispatch($require, $rflags);
2220         }
2221     } elsif ($ref eq 'ARRAY') {
2222         my $satisfied = 0;
2223         foreach my $require ( @{$required} ) {
2224             my $rflags =
2225               ( ref($flags) && !ref($require) && ( $require ne '*' ) )
2226               ? $flags->{$require}
2227               : $flags;
2228             $satisfied++ if _dispatch( $require, $rflags );
2229         }
2230         return 0 unless $satisfied;
2231     } else {
2232         croak "Unexpected structure found: $ref";
2233     }
2234
2235     return $flags;
2236 };
2237
2238 sub haspermission {
2239     my ( $userid, $flagsrequired ) = @_;
2240
2241     #Koha::Exceptions::WrongParameter->throw('$flagsrequired should not be undef')
2242     #  unless defined($flagsrequired);
2243
2244     my $sth = C4::Context->dbh->prepare("SELECT flags FROM borrowers WHERE userid=?");
2245     $sth->execute($userid);
2246     my $row = $sth->fetchrow();
2247     my $flags = getuserflags( $row, $userid );
2248
2249     return $flags unless defined($flagsrequired);
2250     return $flags if $flags->{superlibrarian};
2251     return _dispatch($flagsrequired, $flags);
2252
2253     #FIXME - This fcn should return the failed permission so a suitable error msg can be delivered.
2254 }
2255
2256 =head2 in_iprange
2257
2258   $flags = ($iprange);
2259
2260 C<$iprange> A space separated string describing an IP range. Can include single IPs or ranges
2261
2262 Returns 1 if the remote address is in the provided iprange, or 0 otherwise.
2263
2264 =cut
2265
2266 sub in_iprange {
2267     my ($iprange) = @_;
2268     my $result = 1;
2269     my @allowedipranges = $iprange ? split(' ', $iprange) : ();
2270     if (scalar @allowedipranges > 0) {
2271         my @rangelist;
2272         eval { @rangelist = Net::CIDR::range2cidr(@allowedipranges); }; return 0 if $@;
2273         eval { $result = Net::CIDR::cidrlookup($ENV{'REMOTE_ADDR'}, @rangelist) } || Koha::Logger->get->warn('cidrlookup failed for ' . join(' ',@rangelist) );
2274      }
2275      return $result ? 1 : 0;
2276 }
2277
2278 sub getborrowernumber {
2279     my ($userid) = @_;
2280     my $userenv = C4::Context->userenv;
2281     if ( defined($userenv) && ref($userenv) eq 'HASH' && $userenv->{number} ) {
2282         return $userenv->{number};
2283     }
2284     my $dbh = C4::Context->dbh;
2285     for my $field ( 'userid', 'cardnumber' ) {
2286         my $sth =
2287           $dbh->prepare("select borrowernumber from borrowers where $field=?");
2288         $sth->execute($userid);
2289         if ( $sth->rows ) {
2290             my ($bnumber) = $sth->fetchrow;
2291             return $bnumber;
2292         }
2293     }
2294     return 0;
2295 }
2296
2297 =head2 track_login_daily
2298
2299     track_login_daily( $userid );
2300
2301 Wraps the call to $patron->track_login, the method used to update borrowers.lastseen. We only call track_login once a day.
2302
2303 =cut
2304
2305 sub track_login_daily {
2306     my $userid = shift;
2307     return if !$userid || !C4::Context->preference('TrackLastPatronActivity');
2308
2309     my $cache     = Koha::Caches->get_instance();
2310     my $cache_key = "track_login_" . $userid;
2311     my $cached    = $cache->get_from_cache($cache_key);
2312     my $today = dt_from_string()->ymd;
2313     return if $cached && $cached eq $today;
2314
2315     my $patron = Koha::Patrons->find({ userid => $userid });
2316     return unless $patron;
2317     $patron->track_login;
2318     $cache->set_in_cache( $cache_key, $today );
2319 }
2320
2321 END { }    # module clean-up code here (global destructor)
2322 1;
2323 __END__
2324
2325 =head1 SEE ALSO
2326
2327 CGI(3)
2328
2329 C4::Output(3)
2330
2331 Crypt::Eksblowfish::Bcrypt(3)
2332
2333 Digest::MD5(3)
2334
2335 =cut