C4/Auth.pm

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