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

(-)a/Koha/CookieManager.pm (+151 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 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;
(-)a/t/CookieManager.t (-1 / +122 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 => 13;
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}, -HttpOnly => 1 );
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
    is( $rv[0]->httponly, 0, 'cleared aap isnt httponly' );
85
    is( $rv[2]->httponly, 1, 'wim still httponly' );
86
};
87
88
subtest 'replace_in_list' => sub {
89
    plan tests => 13;
90
91
    my $q = CGI->new;
92
    my $cmgr = Koha::CookieManager->new;
93
94
    my $cookie1 = $q->cookie( -name => 'c1', -value => q{c1} );
95
    my $cookie2 = $q->cookie( -name => 'c2', -value => q{c2} );
96
    my $cookie3 = $q->cookie( -name => 'c3', -value => q{c3} );
97
    my $cookie4 = $q->cookie( -name => 'c2', -value => q{c4} ); # name c2 !
98
99
    # Unusual arguments (show that $cmgr handles the cookie mocks in Auth.t)
100
    my $res = $cmgr->replace_in_list( [ 1, 2, 3 ], 4 );
101
    is( @$res, 0, 'No cookies' );
102
    $res = $cmgr->replace_in_list( [ 1, 2, 3 ], $cookie1 );
103
    is( @$res, 1, 'One cookie added' );
104
    is( $res->[0]->name, 'c1', '1st cookie' );
105
    $res = $cmgr->replace_in_list( [ $cookie2, 2, 3 ], 4 ); # filter 2,3 and ignore 4
106
    is( @$res, 1, 'One cookie found' );
107
    is( $res->[0]->name, 'c2', 'c2 found' );
108
109
    # Pass c1 c2, add c3
110
    $res = $cmgr->replace_in_list( [ $cookie1, $cookie2 ], $cookie3 );
111
    is( @$res, 3, 'Returns three' );
112
    is( $res->[2]->name, 'c3', '3rd cookie' );
113
    is( $res->[2]->value, 'c3', 'value c3' );
114
115
    # Pass c1 c2 c3 and replace c2
116
    $res = $cmgr->replace_in_list( [ $cookie1, $cookie2, $cookie3 ], $cookie4 );
117
    is( @$res, 3, 'Returns three' );
118
    is( $res->[0]->name, 'c1', '1st cookie' );
119
    is( $res->[1]->name, 'c3', '2nd cookie' );
120
    is( $res->[2]->name, 'c2', '3rd cookie' );
121
    is( $res->[2]->value, 'c4', 'value replaced' );
122
};

Return to bug 29957