Bug 28786: Two-factor authentication for staff client - TOTP
[koha-ffzg.git] / t / lib / TestBuilder.pm
1 package t::lib::TestBuilder;
2
3 use Modern::Perl;
4
5 use Koha::Database qw( schema );
6 use C4::Biblio qw( AddBiblio );
7 use Koha::Biblios qw( _type );
8 use Koha::Items qw( _type );
9 use Koha::DateUtils qw( dt_from_string );
10
11 use Bytes::Random::Secure;
12 use Carp qw( carp );
13 use Module::Load qw( load );
14 use String::Random;
15
16 use constant {
17     SIZE_BARCODE => 20, # Not perfect but avoid to fetch the value when creating a new item
18 };
19
20 sub new {
21     my ($class) = @_;
22     my $self = {};
23     bless( $self, $class );
24
25     $self->schema( Koha::Database->new()->schema );
26     $self->schema->storage->sql_maker->quote_char('`');
27
28     $self->{gen_type} = _gen_type();
29     $self->{default_values} = _gen_default_values();
30     return $self;
31 }
32
33 sub schema {
34     my ($self, $schema) = @_;
35
36     if( defined( $schema ) ) {
37         $self->{schema} = $schema;
38     }
39     return $self->{schema};
40 }
41
42 # sub clear has been obsoleted; use delete_all from the schema resultset
43
44 sub delete {
45     my ( $self, $params ) = @_;
46     my $source = $params->{source} || return;
47     my @recs = ref( $params->{records} ) eq 'ARRAY'?
48         @{$params->{records}}: ( $params->{records} // () );
49     # tables without PK are not supported
50     my @pk = $self->schema->source( $source )->primary_columns;
51     return if !@pk;
52     my $rv = 0;
53     foreach my $rec ( @recs ) {
54     # delete only works when you supply full primary key values
55     # $cond does not include searches for undef (not allowed in PK)
56         my $cond = { map { defined $rec->{$_}? ($_, $rec->{$_}): (); } @pk };
57         next if keys %$cond < @pk;
58         $self->schema->resultset( $source )->search( $cond )->delete;
59         # we clear the pk columns in the supplied hash
60         # this indirectly signals at least an attempt to delete
61         map { delete $rec->{$_}; } @pk;
62         $rv++;
63     }
64     return $rv;
65 }
66
67 sub build_object {
68     my ( $self, $params ) = @_;
69
70     my $class = $params->{class};
71     my $value = $params->{value};
72
73     if ( not defined $class ) {
74         carp "Missing class param";
75         return;
76     }
77
78     my @unknowns = grep( !/^(class|value)$/, keys %{ $params });
79     carp "Unknown parameter(s): ", join( ', ', @unknowns ) if scalar @unknowns;
80
81     load $class;
82     my $source = $class->_type;
83
84     my $hashref = $self->build({ source => $source, value => $value });
85     my $object;
86     if ( $class eq 'Koha::Old::Patrons' ) {
87         $object = $class->search({ borrowernumber => $hashref->{borrowernumber} })->next;
88     } elsif ( $class eq 'Koha::Statistics' ) {
89         $object = $class->search({ datetime => $hashref->{datetime} })->next;
90     } else {
91         my @ids;
92         my @pks = $self->schema->source( $class->_type )->primary_columns;
93         foreach my $pk ( @pks ) {
94             push @ids, $hashref->{ $pk };
95         }
96
97         $object = $class->find( @ids );
98     }
99
100     return $object;
101 }
102
103 sub build {
104 # build returns a hash of column values for a created record, or undef
105 # build does NOT update a record, or pass back values of an existing record
106     my ($self, $params) = @_;
107     my $source  = $params->{source};
108     if( !$source ) {
109         carp "Source parameter not specified!";
110         return;
111     }
112     my $value   = $params->{value};
113
114     my @unknowns = grep( !/^(source|value)$/, keys %{ $params });
115     carp "Unknown parameter(s): ", join( ', ', @unknowns ) if scalar @unknowns;
116
117     my $col_values = $self->_buildColumnValues({
118         source  => $source,
119         value   => $value,
120     });
121     return if !$col_values; # did not meet unique constraints?
122
123     # loop thru all fk and create linked records if needed
124     # fills remaining entries in $col_values
125     my $foreign_keys = $self->_getForeignKeys( { source => $source } );
126     for my $fk ( @$foreign_keys ) {
127         # skip when FK points to itself: e.g. borrowers:guarantorid
128         next if $fk->{source} eq $source;
129         my $keys = $fk->{keys};
130         my $tbl = $fk->{source};
131         my $res = $self->_create_links( $tbl, $keys, $col_values, $value );
132         return if !$res; # failed: no need to go further
133         foreach( keys %$res ) { # save new values
134             $col_values->{$_} = $res->{$_};
135         }
136     }
137
138     # store this record and return hashref
139     return $self->_storeColumnValues({
140         source => $source,
141         values => $col_values,
142     });
143 }
144
145 sub build_sample_biblio {
146     my ( $self, $args ) = @_;
147
148     my $title  = $args->{title}  || 'Some boring read';
149     my $author = $args->{author} || 'Some boring author';
150     my $frameworkcode = $args->{frameworkcode} || '';
151     my $itemtype = $args->{itemtype}
152       || $self->build_object( { class => 'Koha::ItemTypes' } )->itemtype;
153
154     my $marcflavour = C4::Context->preference('marcflavour');
155
156     my $record = MARC::Record->new();
157     $record->encoding( 'UTF-8' );
158
159     my ( $tag, $subfield ) = $marcflavour eq 'UNIMARC' ? ( 200, 'a' ) : ( 245, 'a' );
160     $record->append_fields(
161         MARC::Field->new( $tag, ' ', ' ', $subfield => $title ),
162     );
163
164     ( $tag, $subfield ) = $marcflavour eq 'UNIMARC' ? ( 200, 'f' ) : ( 100, 'a' );
165     $record->append_fields(
166         MARC::Field->new( $tag, ' ', ' ', $subfield => $author ),
167     );
168
169     ( $tag, $subfield ) = $marcflavour eq 'UNIMARC' ? ( 995, 'r' ) : ( 942, 'c' );
170     $record->append_fields(
171         MARC::Field->new( $tag, ' ', ' ', $subfield => $itemtype )
172     );
173
174     my ($biblio_id) = C4::Biblio::AddBiblio( $record, $frameworkcode );
175     return Koha::Biblios->find($biblio_id);
176 }
177
178 sub build_sample_item {
179     my ( $self, $args ) = @_;
180
181     my $biblionumber =
182       delete $args->{biblionumber} || $self->build_sample_biblio->biblionumber;
183     my $library = delete $args->{library}
184       || $self->build_object( { class => 'Koha::Libraries' } )->branchcode;
185
186     # If itype is not passed it will be picked from the biblio (see Koha::Item->store)
187
188     my $barcode = delete $args->{barcode}
189       || $self->_gen_text( { info => { size => SIZE_BARCODE } } );
190
191     return Koha::Item->new(
192         {
193             biblionumber  => $biblionumber,
194             homebranch    => $library,
195             holdingbranch => $library,
196             barcode       => $barcode,
197             %$args,
198         }
199     )->store->get_from_storage;
200 }
201
202 # ------------------------------------------------------------------------------
203 # Internal helper routines
204
205 sub _create_links {
206 # returns undef for failure to create linked records
207 # otherwise returns hashref containing new column values for parent record
208     my ( $self, $linked_tbl, $keys, $col_values, $value ) = @_;
209
210     my $fk_value = {};
211     my ( $cnt_scalar, $cnt_null ) = ( 0, 0 );
212
213     # First, collect all values for creating a linked record (if needed)
214     foreach my $fk ( @$keys ) {
215         my ( $col, $destcol ) = ( $fk->{col_name}, $fk->{col_fk_name} );
216         if( ref( $value->{$col} ) eq 'HASH' ) {
217             # add all keys from the FK hash
218             $fk_value = { %{ $value->{$col} }, %$fk_value };
219         }
220         if( exists $col_values->{$col} ) {
221             # add specific value (this does not necessarily exclude some
222             # values from the hash in the preceding if)
223             $fk_value->{ $destcol } = $col_values->{ $col };
224             $cnt_scalar++;
225             $cnt_null++ if !defined( $col_values->{$col} );
226         }
227     }
228
229     # If we saw all FK columns, first run the following checks
230     if( $cnt_scalar == @$keys ) {
231         # if one or more fk cols are null, the FK constraint will not be forced
232         return {} if $cnt_null > 0;
233
234         # does the record exist already?
235         my @pks = $self->schema->source( $linked_tbl )->primary_columns;
236         my %fk_pk_value;
237         for (@pks) {
238             $fk_pk_value{$_} = $fk_value->{$_} if defined $fk_value->{$_};
239         }
240         return {} if !(keys %fk_pk_value);
241         return {} if $self->schema->resultset($linked_tbl)->find( \%fk_pk_value );
242     }
243     # create record with a recursive build call
244     my $row = $self->build({ source => $linked_tbl, value => $fk_value });
245     return if !$row; # failure
246
247     # Finally, only return the new values
248     my $rv = {};
249     foreach my $fk ( @$keys ) {
250         my ( $col, $destcol ) = ( $fk->{col_name}, $fk->{col_fk_name} );
251         next if exists $col_values->{ $col };
252         $rv->{ $col } = $row->{ $destcol };
253     }
254     return $rv; # success
255 }
256
257 sub _formatSource {
258     my ($params) = @_;
259     my $source = $params->{source} || return;
260     $source =~ s|(\w+)$|$1|;
261     return $source;
262 }
263
264 sub _buildColumnValues {
265     my ($self, $params) = @_;
266     my $source = _formatSource( $params ) || return;
267     my $original_value = $params->{value};
268
269     my $col_values = {};
270     my @columns = $self->schema->source($source)->columns;
271     my %unique_constraints = $self->schema->source($source)->unique_constraints();
272
273     my $build_value = 5;
274     # we try max $build_value times if there are unique constraints
275     BUILD_VALUE: while ( $build_value ) {
276         # generate random values for all columns
277         for my $col_name( @columns ) {
278             my $valref = $self->_buildColumnValue({
279                 source      => $source,
280                 column_name => $col_name,
281                 value       => $original_value,
282             });
283             return if !$valref; # failure
284             if( @$valref ) { # could be empty
285                 # there will be only one value, but it could be undef
286                 $col_values->{$col_name} = $valref->[0];
287             }
288         }
289
290         # verify the data would respect each unique constraint
291         # note that this is INCOMPLETE since not all col_values are filled
292         CONSTRAINTS: foreach my $constraint (keys %unique_constraints) {
293
294                 my $condition;
295                 my $constraint_columns = $unique_constraints{$constraint};
296                 # loop through all constraint columns and build the condition
297                 foreach my $constraint_column ( @$constraint_columns ) {
298                     # build the filter
299                     # if one column does not exist or is undef, skip it
300                     # an insert with a null will not trigger the constraint
301                     next CONSTRAINTS
302                         if !exists $col_values->{ $constraint_column } ||
303                         !defined $col_values->{ $constraint_column };
304                     $condition->{ $constraint_column } =
305                             $col_values->{ $constraint_column };
306                 }
307                 my $count = $self->schema
308                                  ->resultset( $source )
309                                  ->search( $condition )
310                                  ->count();
311                 if ( $count > 0 ) {
312                     # no point checking more stuff, exit the loop
313                     $build_value--;
314                     next BUILD_VALUE;
315                 }
316         }
317         last; # you passed all tests
318     }
319     return $col_values if $build_value > 0;
320
321     # if you get here, we have a problem
322     warn "Violation of unique constraint in $source";
323     return;
324 }
325
326 sub _getForeignKeys {
327
328 # Returns the following arrayref
329 #   [ [ source => name, keys => [ col_name => A, col_fk_name => B ] ], ... ]
330 # The array gives source name and keys for each FK constraint
331
332     my ($self, $params) = @_;
333     my $source = $self->schema->source( $params->{source} );
334
335     my ( @foreign_keys, $check_dupl );
336     my @relationships = $source->relationships;
337     for my $rel_name( @relationships ) {
338         my $rel_info = $source->relationship_info($rel_name);
339         if( $rel_info->{attrs}->{is_foreign_key_constraint} ) {
340             $rel_info->{source} =~ s/^.*:://g;
341             my $rel = { source => $rel_info->{source} };
342
343             my @keys;
344             while( my ($col_fk_name, $col_name) = each(%{$rel_info->{cond}}) ) {
345                 $col_name    =~ s|self.(\w+)|$1|;
346                 $col_fk_name =~ s|foreign.(\w+)|$1|;
347                 push @keys, {
348                     col_name    => $col_name,
349                     col_fk_name => $col_fk_name,
350                 };
351             }
352             # check if the combination table and keys is unique
353             # so skip double belongs_to relations (as in Biblioitem)
354             my $tag = $rel->{source}. ':'.
355                 join ',', sort map { $_->{col_name} } @keys;
356             next if $check_dupl->{$tag};
357             $check_dupl->{$tag} = 1;
358             $rel->{keys} = \@keys;
359             push @foreign_keys, $rel;
360         }
361     }
362     return \@foreign_keys;
363 }
364
365 sub _storeColumnValues {
366     my ($self, $params) = @_;
367     my $source      = $params->{source};
368     my $col_values  = $params->{values};
369     my $new_row = $self->schema->resultset( $source )->create( $col_values );
370     return $new_row? { $new_row->get_columns }: {};
371 }
372
373 sub _buildColumnValue {
374 # returns an arrayref if all goes well
375 # an empty arrayref typically means: auto_incr column or fk column
376 # undef means failure
377     my ($self, $params) = @_;
378     my $source    = $params->{source};
379     my $value     = $params->{value};
380     my $col_name  = $params->{column_name};
381
382     my $col_info  = $self->schema->source($source)->column_info($col_name);
383
384     my $retvalue = [];
385     if( $col_info->{is_auto_increment} ) {
386         if( exists $value->{$col_name} ) {
387             warn "Value not allowed for auto_incr $col_name in $source";
388             return;
389         }
390         # otherwise: no need to assign a value
391     } elsif( $col_info->{is_foreign_key} || _should_be_fk($source,$col_name) ) {
392         if( exists $value->{$col_name} ) {
393             if( !defined $value->{$col_name} && !$col_info->{is_nullable} ) {
394                 # This explicit undef is not allowed
395                 warn "Null value for $col_name in $source not allowed";
396                 return;
397             }
398             if( ref( $value->{$col_name} ) ne 'HASH' ) {
399                 push @$retvalue, $value->{$col_name};
400             }
401             # sub build will handle a passed hash value later on
402         }
403     } elsif( ref( $value->{$col_name} ) eq 'HASH' ) {
404         # this is not allowed for a column that is not a FK
405         warn "Hash not allowed for $col_name in $source";
406         return;
407     } elsif( exists $value->{$col_name} ) {
408         if( !defined $value->{$col_name} && !$col_info->{is_nullable} ) {
409             # This explicit undef is not allowed
410             warn "Null value for $col_name in $source not allowed";
411             return;
412         }
413         push @$retvalue, $value->{$col_name};
414     } elsif( exists $self->{default_values}{$source}{$col_name} ) {
415         my $v = $self->{default_values}{$source}{$col_name};
416         $v = &$v() if ref($v) eq 'CODE';
417         push @$retvalue, $v;
418     } else {
419         my $data_type = $col_info->{data_type};
420         $data_type =~ s| |_|;
421         if( my $hdlr = $self->{gen_type}->{$data_type} ) {
422             push @$retvalue, &$hdlr( $self, { info => $col_info } );
423         } else {
424             warn "Unknown type $data_type for $col_name in $source";
425             return;
426         }
427     }
428     return $retvalue;
429 }
430
431 sub _should_be_fk {
432 # This sub is only needed for inconsistencies in the schema
433 # A column is not marked as FK, but a belongs_to relation is defined
434     my ( $source, $column ) = @_;
435     my $inconsistencies = {
436         'Item.biblionumber' => 1, #FIXME: Please remove me when I become FK
437     };
438     return $inconsistencies->{ "$source.$column" };
439 }
440
441 sub _gen_type {
442     return {
443         tinyint   => \&_gen_int,
444         smallint  => \&_gen_int,
445         mediumint => \&_gen_int,
446         integer   => \&_gen_int,
447         bigint    => \&_gen_int,
448
449         float            => \&_gen_real,
450         decimal          => \&_gen_real,
451         double_precision => \&_gen_real,
452
453         timestamp => \&_gen_datetime,
454         datetime  => \&_gen_datetime,
455         date      => \&_gen_date,
456
457         char       => \&_gen_text,
458         varchar    => \&_gen_text,
459         tinytext   => \&_gen_text,
460         text       => \&_gen_text,
461         mediumtext => \&_gen_text,
462         longtext   => \&_gen_text,
463
464         set  => \&_gen_set_enum,
465         enum => \&_gen_set_enum,
466
467         tinyblob   => \&_gen_blob,
468         mediumblob => \&_gen_blob,
469         blob       => \&_gen_blob,
470         longblob   => \&_gen_blob,
471     };
472 };
473
474 sub _gen_int {
475     my ($self, $params) = @_;
476     my $data_type = $params->{info}->{data_type};
477
478     my $max = 1;
479     if( $data_type eq 'tinyint' ) {
480         $max = 127;
481     }
482     elsif( $data_type eq 'smallint' ) {
483         $max = 32767;
484     }
485     elsif( $data_type eq 'mediumint' ) {
486         $max = 8388607;
487     }
488     elsif( $data_type eq 'integer' ) {
489         $max = 2147483647;
490     }
491     elsif( $data_type eq 'bigint' ) {
492         $max = 9223372036854775807;
493     }
494     return int( rand($max+1) );
495 }
496
497 sub _gen_real {
498     my ($self, $params) = @_;
499     my $max = 10 ** 38;
500     if( defined( $params->{info}->{size} ) ) {
501         $max = 10 ** ($params->{info}->{size}->[0] - $params->{info}->{size}->[1]);
502     }
503     $max = 10 ** 5 if $max > 10 ** 5;
504     return sprintf("%.2f", rand($max-0.1));
505 }
506
507 sub _gen_date {
508     my ($self, $params) = @_;
509     return $self->schema->storage->datetime_parser->format_date(dt_from_string)
510 }
511
512 sub _gen_datetime {
513     my ($self, $params) = @_;
514     return $self->schema->storage->datetime_parser->format_datetime(dt_from_string);
515 }
516
517 sub _gen_text {
518     my ($self, $params) = @_;
519     # From perldoc String::Random
520     my $size = $params->{info}{size} // 10;
521     $size -= alt_rand(0.5 * $size);
522     my $regex = $size > 1
523         ? '[A-Za-z][A-Za-z0-9_]{'.($size-1).'}'
524         : '[A-Za-z]';
525     my $random = String::Random->new( rand_gen => \&alt_rand );
526     # rand_gen is only supported from 0.27 onward
527     return $random->randregex($regex);
528 }
529
530 sub alt_rand { #Alternative randomizer
531     my ($max) = @_;
532     my $random = Bytes::Random::Secure->new( NonBlocking => 1 );
533     my $r = $random->irand / 2**32;
534     return int( $r * $max );
535 }
536
537 sub _gen_set_enum {
538     my ($self, $params) = @_;
539     return $params->{info}->{extra}->{list}->[0];
540 }
541
542 sub _gen_blob {
543     my ($self, $params) = @_;;
544     return 'b';
545 }
546
547 sub _gen_default_values {
548     my ($self) = @_;
549     return {
550         Borrower => {
551             login_attempts => 0,
552             gonenoaddress  => undef,
553             lost           => undef,
554             debarred       => undef,
555             borrowernotes  => '',
556             secret         => undef,
557         },
558         Item => {
559             notforloan         => 0,
560             itemlost           => 0,
561             withdrawn          => 0,
562             restricted         => 0,
563             damaged            => 0,
564             materials          => undef,
565             more_subfields_xml => undef,
566         },
567         Category => {
568             enrolmentfee => 0,
569             reservefee   => 0,
570             # Not X, used for statistics
571             category_type => sub { return [ qw( A C S I P ) ]->[int(rand(5))] },
572             min_password_length => undef,
573             require_strong_password => undef,
574         },
575         Branch => {
576             pickup_location => 0,
577         },
578         Reserve => {
579             non_priority => 0,
580         },
581         Itemtype => {
582             rentalcharge => 0,
583             rentalcharge_daily => 0,
584             rentalcharge_hourly => 0,
585             defaultreplacecost => 0,
586             processfee => 0,
587             notforloan => 0,
588         },
589         Aqbookseller => {
590             tax_rate => 0,
591             discount => 0,
592         },
593         AuthHeader => {
594             marcxml => '',
595         },
596         BorrowerAttributeType => {
597             mandatory => 0,
598         },
599         Suggestion => {
600             suggesteddate => dt_from_string()->ymd,
601             STATUS        => 'ASKED'
602         },
603         ReturnClaim => {
604             issue_id => undef, # It should be a FK but we removed it
605                                # We don't want to generate a random value
606         },
607     };
608 }
609
610 =head1 NAME
611
612 t::lib::TestBuilder.pm - Koha module to create test records
613
614 =head1 SYNOPSIS
615
616     use t::lib::TestBuilder;
617     my $builder = t::lib::TestBuilder->new;
618
619     # The following call creates a patron, linked to branch CPL.
620     # Surname is provided, other columns are randomly generated.
621     # Branch CPL is created if it does not exist.
622     my $patron = $builder->build({
623         source => 'Borrower',
624         value  => { surname => 'Jansen', branchcode => 'CPL' },
625     });
626
627 =head1 DESCRIPTION
628
629 This module automatically creates database records for you.
630 If needed, records for foreign keys are created too.
631 Values will be randomly generated if not passed to TestBuilder.
632 Note that you should wrap these actions in a transaction yourself.
633
634 =head1 METHODS
635
636 =head2 new
637
638     my $builder = t::lib::TestBuilder->new;
639
640     Constructor - Returns the object TestBuilder
641
642 =head2 schema
643
644     my $schema = $builder->schema;
645
646     Getter - Returns the schema of DBIx::Class
647
648 =head2 delete
649
650     $builder->delete({
651         source => $source,
652         records => $patron, # OR: records => [ $patron, ... ],
653     });
654
655     Delete individual records, created by builder.
656     Returns the number of delete attempts, or undef.
657
658 =head2 build
659
660     $builder->build({ source  => $source_name, value => $value });
661
662     Create a test record in the table, represented by $source_name.
663     The name is required and must conform to the DBIx::Class schema.
664     Values may be specified by the optional $value hashref. Will be
665     randomized otherwise.
666     If needed, TestBuilder creates linked records for foreign keys.
667     Returns the values of the new record as a hashref, or undef if
668     the record could not be created.
669
670     Note that build also supports recursive hash references inside the
671     value hash for foreign key columns, like:
672         value => {
673             column1 => 'some_value',
674             fk_col2 => {
675                 columnA => 'another_value',
676             }
677         }
678     The hash for fk_col2 here means: create a linked record with build
679     where columnA has this value. In case of a composite FK the hashes
680     are merged.
681
682     Realize that passing primary key values to build may result in undef
683     if a record with that primary key already exists.
684
685 =head2 build_object
686
687 Given a plural Koha::Object-derived class, it creates a random element, and
688 returns the corresponding Koha::Object.
689
690     my $patron = $builder->build_object({ class => 'Koha::Patrons' [, value => { ... }] });
691
692 =head1 AUTHOR
693
694 Yohann Dufour <yohann.dufour@biblibre.com>
695
696 Koha Development Team
697
698 =head1 COPYRIGHT
699
700 Copyright 2014 - Biblibre SARL
701
702 =head1 LICENSE
703
704 This file is part of Koha.
705
706 Koha is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by
707 the Free Software Foundation; either version 3 of the License, or (at your option) any later version.
708
709 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.
710
711 You should have received a copy of the GNU General Public License along with Koha; if not, see <http://www.gnu.org/licenses>.
712
713 =cut
714
715 1;