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