3 # This file is part of Koha.
5 # Koha is free software; you can redistribute it and/or modify it under the
6 # terms of the GNU General Public License as published by the Free Software
7 # Foundation; either version 3 of the License, or (at your option) any later
10 # Koha is distributed in the hope that it will be useful, but WITHOUT ANY
11 # WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
12 # A PARTICULAR PURPOSE. See the GNU General Public License for more details.
14 # You should have received a copy of the GNU General Public License along
15 # with Koha; if not, see <http://www.gnu.org/licenses>.
18 use Test
::More tests
=> 5;
22 use C4
::Auth qw
/checkpw/;
26 use t
::lib
::Mocks qw
/mock_preference/; # to mock CronjobLog
27 use t
::lib
::TestBuilder
;
29 # Make sure we can rollback.
30 our $schema = Koha
::Database
->new->schema;
31 $schema->storage->txn_begin;
32 our $dbh = C4
::Context
->dbh;
34 subtest
'Existing tests' => sub {
39 # FIXME: are we sure there is an member number 1?
40 logaction
("MEMBERS","MODIFY",1,"test operation");
46 ok
($success, "logaction seemed to work");
49 # FIXME: US formatted date hardcoded into test for now
50 $success = scalar(@
{GetLogs
("","","",undef,undef,"","")});
55 ok
($success, "GetLogs returns results for an open search");
58 # FIXME: US formatted date hardcoded into test for now
59 my $date = output_pref
( { dt
=> dt_from_string
, dateonly
=> 1, dateformat
=> 'iso' } );
60 $success = scalar(@
{GetLogs
( $date, $date, "", undef, undef, "", "") } );
65 ok
($success, "GetLogs accepts dates in an All-matching search");
68 $success = scalar(@
{GetLogs
("","","",["MEMBERS"],["MODIFY"],1,"")});
73 ok
($success, "GetLogs seemed to find ".$success." like our test record in a tighter search");
75 # We want numbers to be the same between runs.
76 $dbh->do("DELETE FROM action_logs;");
78 t
::lib
::Mocks
::mock_preference
('CronjobLog',0);
80 my $cronJobCount = $dbh->selectrow_array("SELECT COUNT(*) FROM action_logs WHERE module='CRONJOBS';",{});
81 is
($cronJobCount,0,"Cronjob not logged as expected.");
83 t
::lib
::Mocks
::mock_preference
('CronjobLog',1);
85 $cronJobCount = $dbh->selectrow_array("SELECT COUNT(*) FROM action_logs WHERE module='CRONJOBS';",{});
86 is
($cronJobCount,1,"Cronjob logged as expected.");
89 subtest
"GetLogs should return all logs if dates are not set" => sub {
91 my $today = dt_from_string
->add(minutes
=> -1);
92 my $yesterday = dt_from_string
->add( days
=> -1 );
94 INSERT INTO action_logs
(timestamp
, user
, module
, action
, object
, info
)
96 (?
, 42, 'CATALOGUING', 'MODIFY', 4242, 'Record 42 has been modified by patron 4242 yesterday'),
97 (?
, 43, 'CATALOGUING', 'MODIFY', 4242, 'Record 43 has been modified by patron 4242 today')
98 |, undef, output_pref
({dt
=>$yesterday, dateformat
=> 'iso'}), output_pref
({dt
=> $today, dateformat
=> 'iso'}));
99 my $logs = GetLogs
( undef, undef, undef, ['CATALOGUING'], ['MODIFY'], 4242 );
100 is
( scalar(@
$logs), 2, 'GetLogs should return all logs regardless the dates' );
101 $logs = GetLogs
( output_pref
($today), undef, undef, ['CATALOGUING'], ['MODIFY'], 4242 );
102 is
( scalar(@
$logs), 1, 'GetLogs should return the logs for today' );
105 subtest
'logaction(): interface is correctly logged' => sub {
109 # No interface passed, using C4::Context->interface
110 $dbh->do("DELETE FROM action_logs;");
111 C4
::Context
->interface( 'commandline' );
112 logaction
( "MEMBERS", "MODIFY", 1, "test operation");
113 my $logs = GetLogs
();
114 is
( @
{$logs}[0]->{ interface
}, 'commandline', 'Interface correctly deduced (commandline)');
116 # No interface passed, using C4::Context->interface
117 $dbh->do("DELETE FROM action_logs;");
118 C4
::Context
->interface( 'opac' );
119 logaction
( "MEMBERS", "MODIFY", 1, "test operation");
121 is
( @
{$logs}[0]->{ interface
}, 'opac', 'Interface correctly deduced (opac)');
123 # Explicit interfaces
124 $dbh->do("DELETE FROM action_logs;");
125 C4
::Context
->interface( 'intranet' );
126 logaction
( "MEMBERS", "MODIFY", 1, 'test info', 'intranet');
128 is
( @
{$logs}[0]->{ interface
}, 'intranet', 'Passed interface is respected (intranet)');
130 # Explicit interfaces
131 $dbh->do("DELETE FROM action_logs;");
132 C4
::Context
->interface( 'sip' );
133 logaction
( "MEMBERS", "MODIFY", 1, 'test info', 'sip');
135 is
( @
{$logs}[0]->{ interface
}, 'sip', 'Passed interface is respected (sip)');
138 subtest
'GetLogs() respects interface filters' => sub {
142 $dbh->do("DELETE FROM action_logs;");
144 logaction
( 'MEMBERS', 'MODIFY', 1, 'opac info', 'opac');
145 logaction
( 'MEMBERS', 'MODIFY', 1, 'sip info', 'sip');
146 logaction
( 'MEMBERS', 'MODIFY', 1, 'intranet info', 'intranet');
147 logaction
( 'MEMBERS', 'MODIFY', 1, 'commandline info', 'commandline');
149 my $logs = scalar @
{ GetLogs
() };
150 is
( $logs, 4, 'If no filter on interfaces is passed, all logs are returned');
152 $logs = GetLogs
(undef,undef,undef,undef,undef,undef,undef,['opac']);
153 is
( @
{$logs}[0]->{ interface
}, 'opac', 'Interface correctly filtered (opac)');
155 $logs = GetLogs
(undef,undef,undef,undef,undef,undef,undef,['sip']);
156 is
( @
{$logs}[0]->{ interface
}, 'sip', 'Interface correctly filtered (sip)');
158 $logs = GetLogs
(undef,undef,undef,undef,undef,undef,undef,['intranet']);
159 is
( @
{$logs}[0]->{ interface
}, 'intranet', 'Interface correctly filtered (intranet)');
161 $logs = GetLogs
(undef,undef,undef,undef,undef,undef,undef,['commandline']);
162 is
( @
{$logs}[0]->{ interface
}, 'commandline', 'Interface correctly filtered (commandline)');
165 subtest
'GDPR logging' => sub {
168 my $builder = t
::lib
::TestBuilder
->new;
169 my $patron = $builder->build_object( { class => 'Koha::Patrons' } );
171 t
::lib
::Mocks
::mock_userenv
({ patron
=> $patron });
172 logaction
( 'AUTH', 'FAILURE', $patron->id, '', 'opac' );
173 my $logs = GetLogs
( undef, undef, $patron->id, ['AUTH'], ['FAILURE'], $patron->id );
174 is
( @
$logs, 1, 'We should find one auth failure' );
176 t
::lib
::Mocks
::mock_preference
('AuthFailureLog', 1);
177 my $strong_password = 'N0tStr0ngAnyM0reN0w:)';
178 $patron->set_password({ password
=> $strong_password });
179 my @ret = checkpw
( $dbh, $patron->userid, 'WrongPassword', undef, undef, 1);
180 is
( $ret[0], 0, 'Authentication failed' );
181 # Look for auth failure but NOT on patron id, pass userid in info parameter
182 $logs = GetLogs
( undef, undef, 0, ['AUTH'], ['FAILURE'], undef, $patron->userid );
183 is
( @
$logs, 1, 'We should find one auth failure with this userid' );
184 t
::lib
::Mocks
::mock_preference
('AuthFailureLog', 0);
185 @ret = checkpw
( $dbh, $patron->userid, 'WrongPassword', undef, undef, 1);
186 $logs = GetLogs
( undef, undef, 0, ['AUTH'], ['FAILURE'], undef, $patron->userid );
187 is
( @
$logs, 1, 'Still only one failure with this userid' );
188 t
::lib
::Mocks
::mock_preference
('AuthSuccessLog', 1);
189 @ret = checkpw
( $dbh, $patron->userid, $strong_password, undef, undef, 1);
190 is
( $ret[0], 1, 'Authentication succeeded' );
191 # Now we can look for patron id
192 $logs = GetLogs
( undef, undef, $patron->id, ['AUTH'], ['SUCCESS'], $patron->id );
193 is
( @
$logs, 1, 'We expect only one auth success line for this patron' );
196 $schema->storage->txn_rollback;