Bug 29957: Introduce Koha::CookieManager

Test plan:
Run t/CookieManager.t

Signed-off-by: Marcel de Rooy <m.de.rooy@rijksmuseum.nl>

Signed-off-by: Nick Clemens <nick@bywatersolutions.com>
Signed-off-by: Martin Renvoize <martin.renvoize@ptfs-europe.com>
Signed-off-by: Fridolin Somers <fridolin.somers@biblibre.com>

Koha/CookieManager.pm

@@ -0,0 +1,151 @@
+package Koha::CookieManager;
+
+# Copyright 2022 Rijksmuseum, Koha Development Team
+#
+# This file is part of Koha.
+#
+# Koha is free software; you can redistribute it and/or modify it
+# under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 3 of the License, or
+# (at your option) any later version.
+#
+# Koha is distributed in the hope that it will be useful, but
+# WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with Koha; if not, see <http://www.gnu.org/licenses>.
+
+use Modern::Perl;
+use CGI::Cookie;
+# use Data::Dumper qw( Dumper );
+# use List::MoreUtils qw( uniq );
+
+use C4::Context;
+
+use constant ALLOW_LIST_VAR => 'removable_cookie';
+
+our $cookies;
+
+=head1 NAME
+
+Koha::CookieManager - Object for unified handling of cookies in Koha
+
+=head1 SYNOPSIS
+
+    use Koha::CookieManager;
+    my $mgr = Koha::CookieManager->new;
+
+    # Replace cookies
+    $cookie_list = $mgr->replace_in_list( [ $cookie1, $cookie2_old ], $cookie2_new );
+
+    # Clear cookies (governed by koha-conf removable_cookie lines)
+    $cookie_list = $mgr->clear_if_allowed( $cookie1, $cookie2, $cookie3_name );
+
+
+=head1 DESCRIPTION
+
+The current object allows you to clear cookies in a list based on the allow
+list in koha-conf.xml. It also offers a method to replace the old version of
+a cookie by a new one.
+
+It could be extended by (gradually) routing cookie creation through it in order
+to consistently fill cookie parameters like httponly, secure and samesite flag,
+etc. And could serve to register all our cookies in a central location.
+
+=head1 METHODS
+
+=head2 new
+
+    my $mgr = Koha::CookieManager->new({}); # parameters for extensions
+
+=cut
+
+sub new {
+    my ( $class, $params ) = @_;
+    my $self = bless $params//{}, $class;
+    my $allowed = C4::Context->config(ALLOW_LIST_VAR) || []; # expecting scalar or arrayref
+    $allowed = [ $allowed ] if ref($allowed) eq q{};
+    $self->{_remove_allowed} = { map { $_ => 1 } @$allowed };
+    $self->{_secure} = C4::Context->https_enabled;
+    return $self;
+}
+
+=head2 clear_if_allowed
+
+    $cookies = $self->clear_if_allowed( $query->cookie, @$cookies );
+
+    Arguments: either cookie names or cookie objects (CGI::Cookie).
+    Note: in the example above $query->cookie is a list of cookie names as returned
+    by the CGI object.
+
+    Returns an arrayref of cookie objects: empty, expired cookies for those passed
+    by name or object that are on the allow list, together with the remaining
+    (untouched) cookie objects not on that list.
+
+=cut
+
+sub clear_if_allowed {
+    my ( $self, @cookies ) = @_;
+    my @rv;
+    my $seen = {};
+    foreach my $c ( @cookies ) {
+        my $name;
+        my $type = ref($c);
+        if( $type eq 'CGI::Cookie' ) {
+            $name = $c->name;
+        } elsif( $type ) { # not expected: ignore
+            next;
+        } else {
+            $name = $c;
+        }
+
+        if( $self->{_remove_allowed}->{$name} ) {
+            next if $seen->{ $name };
+            push @rv, CGI::Cookie->new(
+                # -expires explicitly omitted to create shortlived 'session' cookie
+                # -HttpOnly explicitly set to 0: not really needed here for the
+                # cleared httponly cookies, while the js cookies should be 0
+                -name => $name, -value => q{}, -HttpOnly => 0,
+                $self->{_secure} ? ( -secure => 1 ) : (),
+            );
+            $seen->{ $name } = 1; # prevent duplicates
+        } elsif( $type eq 'CGI::Cookie' ) {
+            push @rv, $c;
+        }
+    }
+    return \@rv;
+}
+
+=head2 replace_in_list
+
+    $list2 = $mgr->replace_in_list( $list1, $cookie );
+
+    Add $cookie to $list1, removing older occurrences in list1.
+    $list1 is a list of CGI::Cookie objects.
+    $cookie must be a CGI::Cookie object; if it is not, only
+    cookie objects in list1 are returned (filtering list1).
+
+    Returns an arrayref of CGI::Cookie objects.
+
+=cut
+
+sub replace_in_list {
+    my ( $self, $list, $cookie ) = @_;
+    my $name = ref($cookie) eq 'CGI::Cookie' ? $cookie->name : q{};
+
+    my @result;
+    foreach my $c ( @$list ) {
+        next if ref($c) ne 'CGI::Cookie';
+        push @result, $c if !$name or $c->name ne $name;
+    }
+    push @result, $cookie if $name;
+    return \@result;
+}
+
+=head1 INTERNAL ROUTINES
+
+=cut
+
+1;

t/CookieManager.t

@@ -0,0 +1,122 @@
+#!/usr/bin/perl
+#
+# Copyright 2022 Rijksmuseum, Koha Development Team
+#
+# This file is part of Koha.
+#
+# Koha is free software; you can redistribute it and/or modify it
+# under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 3 of the License, or
+# (at your option) any later version.
+#
+# Koha is distributed in the hope that it will be useful, but
+# WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with Koha; if not, see <http://www.gnu.org/licenses>.
+
+use Modern::Perl;
+use CGI;
+use Data::Dumper qw(Dumper);
+use Test::More tests => 3;
+
+use t::lib::Mocks;
+
+use C4::Context;
+use Koha::CookieManager;
+
+subtest 'new' => sub {
+    plan tests => 3;
+
+    t::lib::Mocks::mock_config( Koha::CookieManager::ALLOW_LIST_VAR, 'just_one' );
+    my $cmgr = Koha::CookieManager->new;
+    is( scalar keys %{$cmgr->{_remove_allowed}}, 1, 'one entry' );
+    is( exists $cmgr->{_secure}, 1, 'secure key found' );
+
+    t::lib::Mocks::mock_config( Koha::CookieManager::ALLOW_LIST_VAR, [ 'two', 'entries' ] );
+    $cmgr = Koha::CookieManager->new;
+    is( scalar keys %{$cmgr->{_remove_allowed}}, 2, 'two entries' );
+};
+
+subtest 'clear_if_allowed' => sub {
+    plan tests => 13;
+
+    t::lib::Mocks::mock_config( Koha::CookieManager::ALLOW_LIST_VAR, [ 'aap', 'noot', 'mies' ] );
+
+    my $q = CGI->new;
+    my $cmgr = Koha::CookieManager->new;
+
+    my $cookie1 = $q->cookie(
+        -name => 'aap',
+        -value => 'aap',
+        -expires => '+1d',
+        -HttpOnly => 1,
+        -secure => 1,
+    );
+    my $cookie2 = $q->cookie(
+        -name => 'noot',
+        -value => 'noot',
+        -expires => '+1d',
+        -HttpOnly => 1,
+        -secure => 1,
+    );
+    my $cookie3 = $q->cookie( -name => 'wim', -value => q{wim}, -HttpOnly => 1 );
+    my $cookie4 = $q->cookie( -name => 'aap', -value => q{aap2} );
+    my $list = [ $cookie1, $cookie2, $cookie3, $cookie4, 'mies', 'zus' ]; # 4 cookies, 2 names
+
+    # No results expected
+    is( @{$cmgr->clear_if_allowed}, 0, 'Empty list' );
+    is( @{$cmgr->clear_if_allowed( 'scalar', [], $q )}, 0, 'Empty list for invalid arguments' );
+
+    # Pass list, expect 4 cookies (3 cleared)
+    my @rv = @{$cmgr->clear_if_allowed( @$list )};
+    is( @rv, 4, 'Four expected' );
+    is( $rv[0]->name, 'aap', 'First cookie' );
+    is( $rv[1]->name, 'noot', '2nd cookie' );
+    is( $rv[2]->name, 'wim', '3rd cookie' );
+    is( $rv[3]->name, 'mies', '4th cookie' );
+    is( $rv[0]->value, q{}, 'aap should be empty' );
+    is( $rv[1]->value, q{}, 'noot should be empty' );
+    is( $rv[2]->value, 'wim', 'wim not empty' );
+    is( $rv[3]->value, q{}, 'mies empty' );
+    is( $rv[0]->httponly, 0, 'cleared aap isnt httponly' );
+    is( $rv[2]->httponly, 1, 'wim still httponly' );
+};
+
+subtest 'replace_in_list' => sub {
+    plan tests => 13;
+
+    my $q = CGI->new;
+    my $cmgr = Koha::CookieManager->new;
+
+    my $cookie1 = $q->cookie( -name => 'c1', -value => q{c1} );
+    my $cookie2 = $q->cookie( -name => 'c2', -value => q{c2} );
+    my $cookie3 = $q->cookie( -name => 'c3', -value => q{c3} );
+    my $cookie4 = $q->cookie( -name => 'c2', -value => q{c4} ); # name c2 !
+
+    # Unusual arguments (show that $cmgr handles the cookie mocks in Auth.t)
+    my $res = $cmgr->replace_in_list( [ 1, 2, 3 ], 4 );
+    is( @$res, 0, 'No cookies' );
+    $res = $cmgr->replace_in_list( [ 1, 2, 3 ], $cookie1 );
+    is( @$res, 1, 'One cookie added' );
+    is( $res->[0]->name, 'c1', '1st cookie' );
+    $res = $cmgr->replace_in_list( [ $cookie2, 2, 3 ], 4 ); # filter 2,3 and ignore 4
+    is( @$res, 1, 'One cookie found' );
+    is( $res->[0]->name, 'c2', 'c2 found' );
+
+    # Pass c1 c2, add c3
+    $res = $cmgr->replace_in_list( [ $cookie1, $cookie2 ], $cookie3 );
+    is( @$res, 3, 'Returns three' );
+    is( $res->[2]->name, 'c3', '3rd cookie' );
+    is( $res->[2]->value, 'c3', 'value c3' );
+
+    # Pass c1 c2 c3 and replace c2
+    $res = $cmgr->replace_in_list( [ $cookie1, $cookie2, $cookie3 ], $cookie4 );
+    is( @$res, 3, 'Returns three' );
+    is( $res->[0]->name, 'c1', '1st cookie' );
+    is( $res->[1]->name, 'c3', '2nd cookie' );
+    is( $res->[2]->name, 'c2', '3rd cookie' );
+    is( $res->[2]->value, 'c4', 'value replaced' );
+};