Bug 17600: Standardize our EXPORT_OK

[srvgit] / C4 / Auth_with_shibboleth.pm

diff --git a/C4/Auth_with_shibboleth.pm b/C4/Auth_with_shibboleth.pm
index 55cee73..e214a53 100644 (file)
--- a/C4/Auth_with_shibboleth.pm
+++ b/C4/Auth_with_shibboleth.pm
@@ -19,23 +19,21 @@ package C4::Auth_with_shibboleth;
 
 use Modern::Perl;
 
-use C4::Debug;
 use C4::Context;
-use Koha::AuthUtils qw(get_script_name);
+use Koha::AuthUtils qw( get_script_name );
 use Koha::Database;
 use Koha::Patrons;
 use C4::Members::Messaging;
-use Carp;
-use CGI;
-use List::MoreUtils qw(any);
+use Carp qw( carp );
+use List::MoreUtils qw( any );
 
-use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $debug);
+use Koha::Logger;
 
+our (@ISA, @EXPORT_OK);
 BEGIN {
     require Exporter;
-    $debug   = $ENV{DEBUG};
     @ISA     = qw(Exporter);
-    @EXPORT =
+    @EXPORT_OK =
       qw(shib_ok logout_shib login_shib_url checkpw_shib get_login_shib);
 }
 
@@ -54,18 +52,17 @@ sub shib_ok {
 sub logout_shib {
     my ($query) = @_;
     my $uri = _get_uri();
-    print $query->redirect( $uri . "/Shibboleth.sso/Logout?return=$uri" );
+    my $return = _get_return($query);
+    print $query->redirect( $uri . "/Shibboleth.sso/Logout?return=$return" );
 }
 
 # Returns Shibboleth login URL with callback to the requesting URL
 sub login_shib_url {
     my ($query) = @_;
 
-    my $param = _get_uri() . get_script_name();
-    if ( $query->query_string() ) {
-        $param = $param . '?' . $query->query_string();
-    }
-    my $uri = _get_uri() . "/Shibboleth.sso/Login?target=$param";
+    my $target = _get_return($query);
+    my $uri = _get_uri() . "/Shibboleth.sso/Login?target=" . $target;
+
     return $uri;
 }
 
@@ -85,10 +82,8 @@ sub get_login_shib {
     my $matchAttribute = $config->{mapping}->{ $config->{matchpoint} }->{is};
 
     if ( any { /(^psgi\.|^plack\.)/i } keys %ENV ) {
-      $debug and warn $matchAttribute . " value: " . $ENV{"HTTP_".uc($matchAttribute)};
       return $ENV{"HTTP_".uc($matchAttribute)} || '';
     } else {
-      $debug and warn $matchAttribute . " value: " . $ENV{$matchAttribute};
       return $ENV{$matchAttribute} || '';
     }
 }
@@ -96,16 +91,19 @@ sub get_login_shib {
 # Checks for password correctness
 # In our case : does the given attribute match one of our users ?
 sub checkpw_shib {
-    $debug and warn "checkpw_shib";
 
     my ( $match ) = @_;
     my $config = _get_shib_config();
-    $debug and warn "User Shibboleth-authenticated as: $match";
 
     # Does the given shibboleth attribute value ($match) match a valid koha user ?
-    my $borrower =
-      Koha::Database->new()->schema()->resultset('Borrower')
-      ->find( { $config->{matchpoint} => $match } );
+    my $borrowers = Koha::Patrons->search( { $config->{matchpoint} => $match } );
+    if ( $borrowers->count > 1 ){
+        # If we have more than 1 borrower the matchpoint is not unique
+        # we cannot know which patron is the correct one, so we should fail
+        Koha::Logger->get->warn("There are several users with $config->{matchpoint} of $match, matchpoints must be unique");
+        return 0;
+    }
+    my $borrower = $borrowers->next;
     if ( defined($borrower) ) {
         if ($config->{'sync'}) {
             _sync($borrower->borrowernumber, $config, $match);
@@ -117,7 +115,7 @@ sub checkpw_shib {
         return _autocreate( $config, $match );
     } else {
         # If we reach this point, the user is not a valid koha user
-         $debug and warn "User with $config->{matchpoint} of $match is not a valid Koha user";
+        Koha::Logger->get->info("There are several users with $config->{matchpoint} of $match, matchpoints must be unique");
         return 0;
     }
 }
@@ -128,7 +126,7 @@ sub _autocreate {
     my %borrower = ( $config->{matchpoint} => $match );
 
     while ( my ( $key, $entry ) = each %{$config->{'mapping'}} ) {
-        if ( any { /(^psgi|^plack)/i } keys %ENV ) {
+        if ( any { /(^psgi\.|^plack\.)/i } keys %ENV ) {
             $borrower{$key} = ( $entry->{'is'} && $ENV{"HTTP_" . uc($entry->{'is'}) } ) || $entry->{'content'} || '';
         } else {
             $borrower{$key} = ( $entry->{'is'} && $ENV{ $entry->{'is'} } ) || $entry->{'content'} || '';
@@ -146,7 +144,7 @@ sub _sync {
     my %borrower;
     $borrower{'borrowernumber'} = $borrowernumber;
     while ( my ( $key, $entry ) = each %{$config->{'mapping'}} ) {
-        if ( any { /(^psgi|^plack)/i } keys %ENV ) {
+        if ( any { /(^psgi\.|^plack\.)/i } keys %ENV ) {
             $borrower{$key} = ( $entry->{'is'} && $ENV{"HTTP_" . uc($entry->{'is'}) } ) || $entry->{'content'} || '';
         } else {
             $borrower{$key} = ( $entry->{'is'} && $ENV{ $entry->{'is'} } ) || $entry->{'content'} || '';
@@ -160,28 +158,20 @@ sub _get_uri {
 
     my $protocol = "https://";
     my $interface = C4::Context->interface;
-    $debug and warn "shibboleth interface: " . $interface;
 
-    my $uri;
-    if ( $interface eq 'intranet' ) {
+    my $uri =
+      $interface eq 'intranet'
+      ? C4::Context->preference('staffClientBaseURL')
+      : C4::Context->preference('OPACBaseURL');
 
-        $uri = C4::Context->preference('staffClientBaseURL') // '';
-        if ($uri eq '') {
-            $debug and warn 'staffClientBaseURL not set!';
-        }
-    } else {
-        $uri = C4::Context->preference('OPACBaseURL') // '';
-        if ($uri eq '') {
-            $debug and warn 'OPACBaseURL not set!';
-        }
-    }
+    $uri or Koha::Logger->get->warn("Syspref staffClientBaseURL or OPACBaseURL not set!"); # FIXME We should die here
+
+    $uri ||= "";
 
     if ($uri =~ /(.*):\/\/(.*)/) {
         my $oldprotocol = $1;
         if ($oldprotocol ne 'https') {
-            $debug
-                and warn
-                  'Shibboleth requires OPACBaseURL/staffClientBaseURL to use the https protocol!';
+            Koha::Logger->get->warn('Shibboleth requires OPACBaseURL/staffClientBaseURL to use the https protocol!');
         }
         $uri = $2;
     }
@@ -189,22 +179,41 @@ sub _get_uri {
     return $return;
 }
 
+sub _get_return {
+    my ($query) = @_;
+
+    my $uri_base_part = _get_uri() . get_script_name();
+
+    my $uri_params_part = '';
+    foreach my $param ( sort $query->url_param() ) {
+        # url_param() always returns parameters that were deleted by delete()
+        # This additional check ensure that parameter was not deleted.
+        my $uriPiece = $query->param($param);
+        if ($uriPiece) {
+            $uri_params_part .= '&' if $uri_params_part;
+            $uri_params_part .= $param . '=';
+            $uri_params_part .= $uriPiece;
+        }
+    }
+    $uri_base_part .= '%3F' if $uri_params_part;
+
+    return $uri_base_part . URI::Escape::uri_escape_utf8($uri_params_part);
+}
+
 sub _get_shib_config {
     my $config = C4::Context->config('shibboleth');
 
     if ( !$config ) {
-        carp 'shibboleth config not defined' if $debug;
+        Koha::Logger->get->warn('shibboleth config not defined');
         return 0;
     }
 
     if ( $config->{matchpoint}
         && defined( $config->{mapping}->{ $config->{matchpoint} }->{is} ) )
     {
-        if ($debug) {
-            warn "koha borrower field to match: " . $config->{matchpoint};
-            warn "shibboleth attribute to match: "
-              . $config->{mapping}->{ $config->{matchpoint} }->{is};
-        }
+        my $logger = Koha::Logger->get;
+        $logger->debug("koha borrower field to match: " . $config->{matchpoint});
+        $logger->debug("shibboleth attribute to match: " . $config->{mapping}->{ $config->{matchpoint} }->{is});
         return $config;
     }
     else {