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
 103         if( $self->_should_be_cleared($name) ) {
 104             next if $seen->{$name};
 105             push @rv, CGI::Cookie->new(
 106                 # -expires explicitly omitted to create shortlived 'session' cookie
 107                 # -HttpOnly explicitly set to 0: not really needed here for the
 108                 # cleared httponly cookies, while the js cookies should be 0
 109                 -name => $name, -value => q{}, -HttpOnly => 0,
 110                 $self->{_secure} ? ( -secure => 1 ) : (),
 111             );
 112             $seen->{$name} = 1; # prevent duplicates
 113         } elsif( $type eq 'CGI::Cookie' ) { # keep the last occurrence
 114             @rv = @{ $self->replace_in_list( \@rv, $c ) };
 115         }
 116     }
 117     return \@rv;
 118 }
 119
 120 sub _should_be_cleared { # when it is not on the deny list in koha-conf
 121     my ( $self, $name ) = @_;
 122
 123     return if $self->{_remove_unless}->{$name}; # exact match
 124
 125     # Now try the entries as regex
 126     foreach my $k ( keys %{$self->{_remove_unless}} ) {
 127         my $reg = $self->{_remove_unless}->{$k};
 128         # The entry in koha-conf should match the complete string
 129         # So adding a ^ and $
 130         return if $name =~ qr/^${k}$/;
 131     }
 132     return 1;
 133 }
 134
 135 =head2 replace_in_list
 136
 137     $list2 = $mgr->replace_in_list( $list1, $cookie );
 138
 139     Add $cookie to $list1, removing older occurrences in list1.
 140     $list1 is a list of CGI::Cookie objects.
 141     $cookie must be a CGI::Cookie object; if it is not, only
 142     cookie objects in list1 are returned (filtering list1).
 143
 144     Returns an arrayref of CGI::Cookie objects.
 145
 146 =cut
 147
 148 sub replace_in_list {
 149     my ( $self, $list, $cookie ) = @_;
 150     my $name = ref($cookie) eq 'CGI::Cookie' ? $cookie->name : q{};
 151
 152     my @result;
 153     foreach my $c ( @$list ) {
 154         next if ref($c) ne 'CGI::Cookie';
 155         push @result, $c if !$name or $c->name ne $name;
 156     }
 157     push @result, $cookie if $name;
 158     return \@result;
 159 }
 160
 161 =head1 INTERNAL ROUTINES
 162
 163 =cut
 164
 165 1;