View | Details | Raw Unified | Return to bug 29957
Collapse All | Expand All

(-)a/Koha/CookieManager.pm (+131 lines)
Line 0 Link Here
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 handling cookies in Koha
34
35
=head1 SYNOPSIS
36
37
    use Koha::CookieManager;
38
39
=head1 DESCRIPTION
40
41
TODO Add a nice description
42
43
=head1 METHODS
44
45
=head2 new
46
47
=cut
48
49
sub new {
50
    my ( $class, $params ) = @_;
51
    my $self = bless $params//{}, $class;
52
    my $allowed = C4::Context->config(ALLOW_LIST_VAR); # expecting scalar or arrayref
53
    $allowed = [ $allowed ] if ref($allowed) eq q{};
54
    $self->{_remove_allowed} = { map { $_ => 1 } @$allowed };
55
    $self->{_secure} = C4::Context->https_enabled;
56
    return $self;
57
}
58
59
=head2 clear_if_allowed
60
61
    $cookies = $self->clear_if_allowed( $query->cookie, @$cookies );
62
63
    Arguments: either cookie names or cookie objects (CGI::Cookie).
64
    Note: in the example above $query->cookie is a list of cookie names.
65
66
    Returns an arrayref of cookie objects: empty, expired cookies for those passed
67
    by name or object that are on the allow list, together with the remaining
68
    (untouched) cookie objects not on that list.
69
70
=cut
71
72
sub clear_if_allowed {
73
    my ( $self, @cookies ) = @_;
74
    my @rv;
75
    my $seen = {};
76
    foreach my $c ( @cookies ) {
77
        my $name;
78
        my $type = ref($c);
79
        if( $type eq 'CGI::Cookie' ) {
80
            $name = $c->name;
81
        } elsif( $type ) { # not expected: ignore
82
            next;
83
        } else {
84
            $name = $c;
85
        }
86
87
        if( $self->{_remove_allowed}->{$name} ) {
88
            next if $seen->{ $name };
89
            push @rv, CGI::Cookie->new(
90
                # -expires explicitly omitted to create shortlived 'session' cookie
91
                -name => $name, -value => q{}, -HttpOnly => 1,
92
                $self->{_secure} ? ( -secure => 1 ) : (),
93
            );
94
            $seen->{ $name } = 1; # prevent duplicates
95
        } elsif( $type eq 'CGI::Cookie' ) {
96
            push @rv, $c;
97
        }
98
    }
99
    return \@rv;
100
}
101
102
=head2 replace_in_list
103
104
    $list2 = $mgr->replace_in_list( $list1, $cookie );
105
106
    Add $cookie to $list1, remove older occurrences in list1.
107
    $list1 is a list of CGI::Cookie objects.
108
    $cookie must be a CGI::Cookie object; if it is not, only
109
    cookie objects in list1 are returned (filtering list1).
110
111
    Returns an arrayref of CGI::Cookie objects.
112
113
=cut
114
115
sub replace_in_list {
116
    my ( $self, $list, $cookie ) = @_;
117
    my $name = ref($cookie) eq 'CGI::Cookie' ? $cookie->name : q{};
118
119
    my @result;
120
    foreach my $c ( @$list ) {
121
        next if ref($c) ne 'CGI::Cookie';
122
        push @result, $c if !$name or $c->name ne $name;
123
    }
124
    return $name ? [ @result, $cookie ] : \@result;
125
}
126
127
=head1 INTERNAL ROUTINES
128
129
=cut
130
131
1;
(-)a/t/CookieManager.t (-1 / +120 lines)
Line 0 Link Here
0
- 
1
#!/usr/bin/perl
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;
22
use Data::Dumper qw(Dumper);
23
use Test::More tests => 3;
24
25
use t::lib::Mocks;
26
27
use C4::Context;
28
use Koha::CookieManager;
29
30
subtest 'new' => sub {
31
    plan tests => 3;
32
33
    t::lib::Mocks::mock_config( Koha::CookieManager::ALLOW_LIST_VAR, 'just_one' );
34
    my $cmgr = Koha::CookieManager->new;
35
    is( scalar keys %{$cmgr->{_remove_allowed}}, 1, 'one entry' );
36
    is( exists $cmgr->{_secure}, 1, 'secure key found' );
37
38
    t::lib::Mocks::mock_config( Koha::CookieManager::ALLOW_LIST_VAR, [ 'two', 'entries' ] );
39
    $cmgr = Koha::CookieManager->new;
40
    is( scalar keys %{$cmgr->{_remove_allowed}}, 2, 'two entries' );
41
};
42
43
subtest 'clear_if_allowed' => sub {
44
    plan tests => 11;
45
46
    t::lib::Mocks::mock_config( Koha::CookieManager::ALLOW_LIST_VAR, [ 'aap', 'noot', 'mies' ] );
47
48
    my $q = CGI->new;
49
    my $cmgr = Koha::CookieManager->new;
50
51
    my $cookie1 = $q->cookie(
52
        -name => 'aap',
53
        -value => 'aap',
54
        -expires => '+1d',
55
        -HttpOnly => 1,
56
        -secure => 1,
57
    );
58
    my $cookie2 = $q->cookie(
59
        -name => 'noot',
60
        -value => 'noot',
61
        -expires => '+1d',
62
        -HttpOnly => 1,
63
        -secure => 1,
64
    );
65
    my $cookie3 = $q->cookie( -name => 'wim', -value => q{wim} );
66
    my $cookie4 = $q->cookie( -name => 'aap', -value => q{aap2} );
67
    my $list = [ $cookie1, $cookie2, $cookie3, $cookie4, 'mies', 'zus' ]; # 4 cookies, 2 names
68
69
    # No results expected
70
    is( @{$cmgr->clear_if_allowed}, 0, 'Empty list' );
71
    is( @{$cmgr->clear_if_allowed( 'scalar', [], $q )}, 0, 'Empty list for invalid arguments' );
72
73
    # Pass list, expect 4 cookies (3 cleared)
74
    my @rv = @{$cmgr->clear_if_allowed( @$list )};
75
    is( @rv, 4, 'Four expected' );
76
    is( $rv[0]->name, 'aap', 'First cookie' );
77
    is( $rv[1]->name, 'noot', '2nd cookie' );
78
    is( $rv[2]->name, 'wim', '3rd cookie' );
79
    is( $rv[3]->name, 'mies', '4th cookie' );
80
    is( $rv[0]->value, q{}, 'aap should be empty' );
81
    is( $rv[1]->value, q{}, 'noot should be empty' );
82
    is( $rv[2]->value, 'wim', 'wim not empty' );
83
    is( $rv[3]->value, q{}, 'mies empty' );
84
};
85
86
subtest 'replace_in_list' => sub {
87
    plan tests => 13;
88
89
    my $q = CGI->new;
90
    my $cmgr = Koha::CookieManager->new;
91
92
    my $cookie1 = $q->cookie( -name => 'c1', -value => q{c1} );
93
    my $cookie2 = $q->cookie( -name => 'c2', -value => q{c2} );
94
    my $cookie3 = $q->cookie( -name => 'c3', -value => q{c3} );
95
    my $cookie4 = $q->cookie( -name => 'c2', -value => q{c4} ); # name c2 !
96
97
    # Unusual arguments (show that $cmgr handles the cookie mocks in Auth.t)
98
    my $res = $cmgr->replace_in_list( [ 1, 2, 3 ], 4 );
99
    is( @$res, 0, 'No cookies' );
100
    $res = $cmgr->replace_in_list( [ 1, 2, 3 ], $cookie1 );
101
    is( @$res, 1, 'One cookie added' );
102
    is( $res->[0]->name, 'c1', '1st cookie' );
103
    $res = $cmgr->replace_in_list( [ $cookie2, 2, 3 ], 4 ); # filter 2,3 and ignore 4
104
    is( @$res, 1, 'One cookie found' );
105
    is( $res->[0]->name, 'c2', 'c2 found' );
106
107
    # Pass c1 c2, add c3
108
    $res = $cmgr->replace_in_list( [ $cookie1, $cookie2 ], $cookie3 );
109
    is( @$res, 3, 'Returns three' );
110
    is( $res->[2]->name, 'c3', '3rd cookie' );
111
    is( $res->[2]->value, 'c3', 'value c3' );
112
113
    # Pass c1 c2 c3 and replace c2
114
    $res = $cmgr->replace_in_list( [ $cookie1, $cookie2, $cookie3 ], $cookie4 );
115
    is( @$res, 3, 'Returns three' );
116
    is( $res->[0]->name, 'c1', '1st cookie' );
117
    is( $res->[1]->name, 'c3', '2nd cookie' );
118
    is( $res->[2]->name, 'c2', '3rd cookie' );
119
    is( $res->[2]->value, 'c4', 'value replaced' );
120
};

Return to bug 29957