C4/Auth.pm

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