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 ALLOW_LIST_VAR => 'removable_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 koha-conf removable_cookie lines)
  44     $cookie_list = $mgr->clear_if_allowed( $cookie1, $cookie2, $cookie3_name );
  45
  46
  47 =head1 DESCRIPTION
  48
  49 The current object allows you to clear cookies in a list based on the allow
  50 list in koha-conf.xml. It also offers a method to replace the old version of
  51 a cookie by a new one.
  52
  53 It could be extended by (gradually) routing cookie creation through it in order
  54 to consistently fill cookie parameters like httponly, secure and samesite flag,
  55 etc. And could serve to register all our cookies in a central location.
  56
  57 =head1 METHODS
  58
  59 =head2 new
  60
  61     my $mgr = Koha::CookieManager->new({}); # parameters for extensions
  62
  63 =cut
  64
  65 sub new {
  66     my ( $class, $params ) = @_;
  67     my $self = bless $params//{}, $class;
  68     my $allowed = C4::Context->config(ALLOW_LIST_VAR) || []; # expecting scalar or arrayref
  69     $allowed = [ $allowed ] if ref($allowed) eq q{};
  70     $self->{_remove_allowed} = { map { $_ => 1 } @$allowed };
  71     $self->{_secure} = C4::Context->https_enabled;
  72     return $self;
  73 }
  74
  75 =head2 clear_if_allowed
  76
  77     $cookies = $self->clear_if_allowed( $query->cookie, @$cookies );
  78
  79     Arguments: either cookie names or cookie objects (CGI::Cookie).
  80     Note: in the example above $query->cookie is a list of cookie names as returned
  81     by the CGI object.
  82
  83     Returns an arrayref of cookie objects: empty, expired cookies for those passed
  84     by name or object that are on the allow list, together with the remaining
  85     (untouched) cookie objects not on that list.
  86
  87 =cut
  88
  89 sub clear_if_allowed {
  90     my ( $self, @cookies ) = @_;
  91     my @rv;
  92     my $seen = {};
  93     foreach my $c ( @cookies ) {
  94         my $name;
  95         my $type = ref($c);
  96         if( $type eq 'CGI::Cookie' ) {
  97             $name = $c->name;
  98         } elsif( $type ) { # not expected: ignore
  99             next;
 100         } else {
 101             $name = $c;
 102         }
 103
 104         if( $self->{_remove_allowed}->{$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' ) {
 115             push @rv, $c;
 116         }
 117     }
 118     return \@rv;
 119 }
 120
 121 =head2 replace_in_list
 122
 123     $list2 = $mgr->replace_in_list( $list1, $cookie );
 124
 125     Add $cookie to $list1, removing older occurrences in list1.
 126     $list1 is a list of CGI::Cookie objects.
 127     $cookie must be a CGI::Cookie object; if it is not, only
 128     cookie objects in list1 are returned (filtering list1).
 129
 130     Returns an arrayref of CGI::Cookie objects.
 131
 132 =cut
 133
 134 sub replace_in_list {
 135     my ( $self, $list, $cookie ) = @_;
 136     my $name = ref($cookie) eq 'CGI::Cookie' ? $cookie->name : q{};
 137
 138     my @result;
 139     foreach my $c ( @$list ) {
 140         next if ref($c) ne 'CGI::Cookie';
 141         push @result, $c if !$name or $c->name ne $name;
 142     }
 143     push @result, $cookie if $name;
 144     return \@result;
 145 }
 146
 147 =head1 INTERNAL ROUTINES
 148
 149 =cut
 150
 151 1;