C4/Auth_with_Shibboleth.pm

   1 package C4::Auth_with_Shibboleth;
   2
   3 # Copyright 2011 BibLibre
   4 #
   5 # This file is part of Koha.
   6 #
   7 # Koha is free software; you can redistribute it and/or modify it under the
   8 # terms of the GNU General Public License as published by the Free Software
   9 # Foundation; either version 2 of the License, or (at your option) any later
  10 # version.
  11 #
  12 # Koha is distributed in the hope that it will be useful, but WITHOUT ANY
  13 # WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
  14 # A PARTICULAR PURPOSE.  See the GNU General Public License for more details.
  15 #
  16 # You should have received a copy of the GNU General Public License along
  17 # with Koha; if not, write to the Free Software Foundation, Inc.,
  18 # 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
  19
  20 use strict;
  21 use warnings;
  22
  23 use C4::Debug;
  24 use C4::Context;
  25 use C4::Utils qw( :all );
  26 use CGI;
  27
  28 use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $debug);
  29
  30 BEGIN {
  31     require Exporter;
  32     $VERSION = 3.03;                                                                    # set the version for version checking
  33     $debug   = $ENV{DEBUG};
  34     @ISA     = qw(Exporter);
  35     @EXPORT  = qw(logout_shib login_shib_url checkpw_shib get_login_shib);
  36 }
  37 my $context = C4::Context->new() or die 'C4::Context->new failed';
  38 my $protocol = "https://";
  39
  40 # Logout from Shibboleth
  41 sub logout_shib {
  42     my ($query) = @_;
  43     my $uri = $protocol . $ENV{'SERVER_NAME'};
  44     print $query->redirect( $uri . "/Shibboleth.sso/Logout?return=$uri" );
  45 }
  46
  47 # Returns Shibboleth login URL with callback to the requesting URL
  48 sub login_shib_url {
  49
  50     my ($query) = @_;
  51     my $param = $protocol . $ENV{'SERVER_NAME'} . $query->script_name();
  52     my $uri = $protocol . $ENV{'SERVER_NAME'} . "/Shibboleth.sso/Login?target=$param";
  53     return $uri;
  54 }
  55
  56 # Returns shibboleth user login
  57 sub get_login_shib {
  58
  59     # In case of a Shibboleth authentication, we expect a shibboleth user attribute (defined in the shibbolethLoginAttribute)
  60     # to contain the login of the shibboleth-authenticated user
  61
  62     # Shibboleth attributes are mapped into http environmement variables,
  63     # so we're getting the login of the user this way
  64
  65     my $shibbolethLoginAttribute = C4::Context->preference('shibbolethLoginAttribute');
  66     $debug and warn "shibbolethLoginAttribute value: $shibbolethLoginAttribute";
  67     $debug and warn "$shibbolethLoginAttribute value: " . $ENV{$shibbolethLoginAttribute};
  68
  69     return $ENV{$shibbolethLoginAttribute};
  70 }
  71
  72 # Checks for password correctness
  73 # In our case : does the given username matches one of our users ?
  74 sub checkpw_shib {
  75     $debug and warn "checkpw_shib";
  76
  77     my ( $dbh, $userid ) = @_;
  78     my $retnumber;
  79     $debug and warn "User Shibboleth-authenticated as: $userid";
  80
  81     # Does it match one of our users ?
  82     my $sth = $dbh->prepare("select cardnumber from borrowers where userid=?");
  83     $sth->execute($userid);
  84     if ( $sth->rows ) {
  85         $retnumber = $sth->fetchrow;
  86         return ( 1, $retnumber, $userid );
  87     }
  88     $sth = $dbh->prepare("select userid from borrowers where cardnumber=?");
  89     $sth->execute($userid);
  90     if ( $sth->rows ) {
  91         $retnumber = $sth->fetchrow;
  92         return ( 1, $retnumber, $userid );
  93     }
  94
  95     # If we reach this point, the user is not a valid koha user
  96     $debug and warn "User $userid is not a valid Koha user";
  97     return 0;
  98 }
  99
 100 1;