Koha/CookieManager.pm

   1 package Koha::CookieManager;
   2
   3 # Copyright 2022 Rijksmuseum, Koha Development Team
   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 Modern::Perl;
  21 use CGI::Cookie;
  22 # use Data::Dumper qw( Dumper );
  23 # use List::MoreUtils qw( uniq );
  24
  25 use C4::Context;
  26
  27 use constant DENY_LIST_VAR => 'do_not_remove_cookie';
  28
  29 our $cookies;
  30
  31 =head1 NAME
  32
  33 Koha::CookieManager - Object for unified handling of cookies in Koha
  34
  35 =head1 SYNOPSIS
  36
  37     use Koha::CookieManager;
  38     my $mgr = Koha::CookieManager->new;
  39
  40     # Replace cookies
  41     $cookie_list = $mgr->replace_in_list( [ $cookie1, $cookie2_old ], $cookie2_new );
  42
  43     # Clear cookies (governed by deny list entries in koha-conf)
  44     $cookie_list = $mgr->clear_unless( $cookie1, $cookie2, $cookie3_name );
  45
  46 =head1 DESCRIPTION
  47
  48 The current object allows you to clear cookies in a list based on the deny list
  49 in koha-conf.xml. It also offers a method to replace the old version of a cookie
  50 by a new one.
  51
  52 It could be extended by (gradually) routing cookie creation through it in order
  53 to consistently fill cookie parameters like httponly, secure and samesite flag,
  54 etc. And could serve to register all our cookies in a central location.
  55
  56 =head1 METHODS
  57
  58 =head2 new
  59
  60     my $mgr = Koha::CookieManager->new({}); # parameters for extensions
  61
  62 =cut
  63
  64 sub new {
  65     my ( $class, $params ) = @_;
  66     my $self = bless $params//{}, $class;
  67     my $denied = C4::Context->config(DENY_LIST_VAR) || []; # expecting scalar or arrayref
  68     $denied = [ $denied ] if ref($denied) eq q{};
  69     $self->{_remove_unless} = { map { $_ => 1 } @$denied };
  70     $self->{_secure} = C4::Context->https_enabled;
  71     return $self;
  72 }
  73
  74 =head2 clear_unless
  75
  76     $cookies = $self->clear_unless( $query->cookie, @$cookies );
  77
  78     Arguments: either cookie names or cookie objects (CGI::Cookie).
  79     Note: in the example above $query->cookie is a list of cookie names as returned
  80     by the CGI object.
  81
  82     Returns an arrayref of cookie objects: empty, expired cookies for those passed
  83     by name or objects that are not on the deny list, together with the remaining
  84     (untouched) cookie objects that are on the deny list.
  85
  86 =cut
  87
  88 sub clear_unless {
  89     my ( $self, @cookies ) = @_;
  90     my @rv;
  91     my $seen = {};
  92     foreach my $c ( @cookies ) {
  93         my $name;
  94         my $type = ref($c);
  95         if( $type eq 'CGI::Cookie' ) {
  96             $name = $c->name;
  97         } elsif( $type ) { # not expected: ignore
  98             next;
  99         } else {
 100             $name = $c;
 101         }
 102         next if !$name;
 103
 104         if( $self->_should_be_cleared($name) ) {
 105             next if $seen->{$name};
 106             push @rv, CGI::Cookie->new(
 107                 # -expires explicitly omitted to create shortlived 'session' cookie
 108                 # -HttpOnly explicitly set to 0: not really needed here for the
 109                 # cleared httponly cookies, while the js cookies should be 0
 110                 -name => $name, -value => q{}, -HttpOnly => 0,
 111                 $self->{_secure} ? ( -secure => 1 ) : (),
 112             );
 113             $seen->{$name} = 1; # prevent duplicates
 114         } elsif( $type eq 'CGI::Cookie' ) { # keep the last occurrence
 115             @rv = @{ $self->replace_in_list( \@rv, $c ) };
 116         }
 117     }
 118     return \@rv;
 119 }
 120
 121 sub _should_be_cleared { # when it is not on the deny list in koha-conf
 122     my ( $self, $name ) = @_;
 123
 124     return if $self->{_remove_unless}->{$name}; # exact match
 125
 126     # Now try the entries as regex
 127     foreach my $k ( keys %{$self->{_remove_unless}} ) {
 128         my $reg = $self->{_remove_unless}->{$k};
 129         # The entry in koha-conf should match the complete string
 130         # So adding a ^ and $
 131         return if $name =~ qr/^${k}$/;
 132     }
 133     return 1;
 134 }
 135
 136 =head2 replace_in_list
 137
 138     $list2 = $mgr->replace_in_list( $list1, $cookie );
 139
 140     Add $cookie to $list1, removing older occurrences in list1.
 141     $list1 is a list of CGI::Cookie objects.
 142     $cookie must be a CGI::Cookie object; if it is not, only
 143     cookie objects in list1 are returned (filtering list1).
 144
 145     Returns an arrayref of CGI::Cookie objects.
 146
 147 =cut
 148
 149 sub replace_in_list {
 150     my ( $self, $list, $cookie ) = @_;
 151     my $name = ref($cookie) eq 'CGI::Cookie' ? $cookie->name : q{};
 152
 153     my @result;
 154     foreach my $c ( @$list ) {
 155         next if ref($c) ne 'CGI::Cookie';
 156         push @result, $c if !$name or $c->name ne $name;
 157     }
 158     push @result, $cookie if $name;
 159     return \@result;
 160 }
 161
 162 =head1 INTERNAL ROUTINES
 163
 164 =cut
 165
 166 1;