1#  Copyright 2018 - present MongoDB, Inc.
2#
3#  Licensed under the Apache License, Version 2.0 (the "License");
4#  you may not use this file except in compliance with the License.
5#  You may obtain a copy of the License at
6#
7#  http://www.apache.org/licenses/LICENSE-2.0
8#
9#  Unless required by applicable law or agreed to in writing, software
10#  distributed under the License is distributed on an "AS IS" BASIS,
11#  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
12#  See the License for the specific language governing permissions and
13#  limitations under the License.
14
15use strict;
16use warnings;
17use JSON::MaybeXS;
18use Path::Tiny 0.054; # basename with suffix
19use Test::More 0.88;
20use Test::Deep ':v1';
21use Safe::Isa;
22use JSON::MaybeXS qw( is_bool decode_json );
23use Storable qw( dclone );
24use BSON::Types ':all';
25
26use lib "t/lib";
27
28use MongoDBTest qw/
29    build_client
30    get_test_db
31    clear_testdbs
32    get_unique_collection
33    server_version
34    server_type
35    check_min_server_version
36    skip_unless_mongod
37    skip_unless_sessions
38    skip_unless_failpoints_available
39    to_snake_case
40    remap_hashref_to_snake_case
41    get_features
42    set_failpoint
43    clear_failpoint
44/;
45use MongoDBSpecTest qw/
46    foreach_spec_test
47    skip_unless_run_on
48    maybe_skip_multiple_mongos
49/;
50
51skip_unless_mongod(v3.6.0);
52skip_unless_failpoints_available();
53
54# Increase wtimeout much higher for CI dropping database issues
55my $conn           = build_client( wtimeout => 60000 );
56
57my @events;
58sub clear_events { @events = () }
59
60sub event_cb { push @events, dclone $_[0] }
61
62my $db;
63foreach_spec_test('t/data/retryable-reads', $conn, sub {
64    my ($test, $plan) = @_;
65    maybe_skip_multiple_mongos( $conn, $test->{useMultipleMongoses} );
66
67    TODO: {
68        todo_skip('PERL-589: GridFSBucket download', 1)
69            if $test->{'description'} =~ /DownloadByName|download_by_name/i;
70
71        my $client_options = $test->{'clientOptions'};
72        $client_options = remap_hashref_to_snake_case( $client_options );
73        $client_options->{'monitoring_callback'} = \&event_cb;
74        my $client = build_client(%$client_options);
75
76        $db->drop if defined $db;
77        ok($db = get_test_db($conn), 'got test db');
78        ok($db = $client->get_database($db->name), 'got client test db');
79        $db->run_command([ create => $plan->{'database_name'} ]);
80        my ($coll, $gridfs);
81        if (exists $plan->{'collection_name'}) {
82            ok($coll = $db->get_collection($plan->{'collection_name'}),
83               'got collection');
84            $coll->drop;
85            $coll->insert_many($plan->{'data'});
86        }
87        elsif (exists $plan->{'bucket_name'}) {
88            ok($gridfs = $db->gfs({ bucket_name => $plan->{'bucket_name'} }),
89               'got bucket');
90            $gridfs->drop;
91
92            my $files = $db->get_collection('fs.files');
93            $files->drop;
94            my $files_data = $plan->{'data'}{'fs.files'};
95            $files_data->[0]{'_id'} = bson_oid($files_data->[0]{'_id'}{'$oid'})
96                unless $files_data->[0]{'_id'}->$_isa('BSON::OID');
97            $files->insert_many($files_data);
98
99            my $chunks = $db->get_collection('fs.chunks');
100            $chunks->drop;
101            my $chunks_data = $plan->{'data'}{'fs.chunks'};
102            $chunks_data->[0]{'_id'} = bson_oid($chunks_data->[0]{'_id'}{'$oid'})
103                unless $chunks_data->[0]{'_id'}->$_isa('BSON::OID');
104            $chunks->insert_many($chunks_data);
105        }
106
107        set_failpoint( $client, $test->{'failPoint'} );
108        clear_events();
109        foreach my $op (@{ $test->{'operations'} || [] }) {
110            my $method = $op->{'name'};
111            $method =~ s{([A-Z])}{_\L$1}g;
112            my $func_name = 'do_' . $method;
113            my $ret = eval {
114                main->$func_name( $coll || $gridfs, $op->{'arguments'}, $op->{'object'} )
115            };
116            my $err = $@;
117            if ($op->{'error'}) {
118                ok $err, 'Exception occured';
119            }
120            elsif ($err && $err !~ /failpoint/) {
121                return fail($err);
122            }
123            elsif ($op->{'result'}) {
124                cmp_deeply($ret, $op->{'result'}, "checking result for $method")
125                    or diag explain $ret;
126            }
127        }
128
129        check_event_expectations(
130            _adjust_types($test->{'expectations'}),
131        );
132
133        clear_failpoint( $client, $test->{'failPoint'} );
134    }
135});
136
137sub _adjust_types {
138    my ($value) = @_;
139    if (ref $value eq 'HASH') {
140        if (scalar(keys %$value) == 1) {
141            my ($name, $value) = %$value;
142            if ($name eq '$numberLong') {
143                return 0+$value;
144            }
145            if ($name eq '$oid') {
146                my $id = bson_oid($value);
147                ok($id->hex, 'check hex value of $oid');
148                return $id;
149            }
150        }
151        return +{map {
152            my $key = $_;
153            ($key, _adjust_types($value->{$key}));
154        } keys %$value};
155    }
156    elsif (ref $value eq 'ARRAY') {
157        return [map { _adjust_types($_) } @$value];
158    }
159    else {
160        return $value;
161    }
162}
163
164sub prepare_data_spec {
165    my ($spec) = @_;
166    if (is_bool $spec) {
167        my $specced = $spec ? 1 : 0;
168        return code(sub {
169            my $value = shift;
170            return(0, 'expected a true boolean value')
171                if $specced and not $value;
172            return(0, 'expected a false boolean value')
173                if $value and not $specced;
174            return 1;
175        });
176    }
177    elsif (ref $spec eq 'ARRAY') {
178        return [map {
179            prepare_data_spec($_)
180        } @$spec];
181    }
182    elsif (ref $spec eq 'HASH') {
183        return +{map {
184            ($_, prepare_data_spec($spec->{$_}))
185        } keys %$spec};
186    }
187    else {
188        return $spec;
189    }
190}
191
192sub check_event_expectations {
193    my ($expected) = @_;
194    my @got =
195        grep { $_->{'commandName'} !~ /configureFailPoint|sasl|ismaster|kill|getMore|insert/ }
196        grep { ($_->{'type'}||q{}) eq 'command_started' }
197        @events;
198    for my $exp ( @$expected ) {
199        my ($exp_type, $exp_spec) = %$exp;
200        subtest $exp_type => sub {
201            ok(scalar(@got), 'event available')
202                or return;
203            my $event = shift @got;
204            is($event->{type}.'_event', $exp_type, "is a $exp_type")
205                or return;
206            my $event_tester = "check_$exp_type";
207            main->can($event_tester)->($exp_spec, $event);
208        };
209    }
210    is(scalar(@got), 0, 'no outstanding events');
211}
212
213sub check_event {
214    my ($exp, $event) = @_;
215    for my $key (sort keys %$exp) {
216        my $check = "check_${key}_field";
217        main->can($check)->($exp->{$key}, $event);
218    }
219}
220
221sub check_command_started_event {
222    my ($exp, $event) = @_;
223    check_event($exp, $event);
224}
225
226sub check_command_succeeded_event {
227    my ($exp, $event) = @_;
228    check_event($exp, $event);
229}
230
231sub check_command_failed_event {
232    my ($exp, $event) = @_;
233    check_event($exp, $event);
234}
235
236sub check_database_name_field {
237    my ($exp_name, $event) = @_;
238    ok defined($event->{databaseName}), "database_name defined";
239    ok length($event->{databaseName}), "database_name non-empty";
240}
241
242sub check_command_name_field {
243    my ($exp_name, $event) = @_;
244    is $event->{commandName}, $exp_name, "command name";
245}
246
247sub check_command_field {
248    my ($exp_command, $event) = @_;
249    my $event_command = $event->{command};
250    for my $exp_key (sort keys %$exp_command) {
251        my $exp_value = prepare_data_spec($exp_command->{$exp_key});
252        if ($exp_key =~ /listIndexNames/) {
253            $exp_key = 'listIndexes';
254        }
255        my $event_value = $event_command->{$exp_key};
256        my $label = "command field '$exp_key'";
257        if ( ref $event_value eq 'HASH' ) {
258            if (exists $event_value->{'_id'} || exists $event_value->{'files_id'}) {
259                my $got_id = $event_value->{'_id'} || $event_value->{'files_id'};
260                my $exp_id = $exp_value->{'_id'} || $exp_value->{'files_id'};
261                if ( $got_id->$_isa('BSON::OID') ) {
262                    is($got_id->hex, $exp_id->hex, 'check hex value');
263                }
264            }
265        }
266        cmp_deeply $event_value, $exp_value, $label
267            or diag explain $event_command;
268    }
269}
270
271sub do_aggregate {
272    my ($main, $coll, $args) = @_;
273    return [ $coll->aggregate($args->{'pipeline'})->all ];
274}
275
276sub do_watch {
277    my ($main, $coll, $args, $on) = @_;
278    my $obj_map = {
279        collection => sub { $coll },
280        client => sub { $coll->client },
281        database => sub { $coll->database },
282    };
283    return $obj_map->{$on}->()->watch;
284}
285
286sub do_distinct {
287    my ($main, $coll, $args) = @_;
288    return [
289        $coll->distinct($args->{'fieldName'}, $args->{'filter'})->all
290    ];
291}
292
293sub do_find {
294    my ($main, $coll, $args) = @_;
295    my $cursor = $coll->find($args->{'filter'}, {
296        map { $_ => $args->{$_} } qw(sort limit)
297    });
298    return [ $cursor->all ];
299}
300
301sub do_find_one {
302    my ($main, $coll, $args) = @_;
303    return $coll->find_one($args->{'filter'});
304}
305
306sub do_estimated_document_count {
307    my ($main, $coll, $args) = @_;
308    return $coll->estimated_document_count;
309}
310
311sub do_count_documents {
312    my ($main, $coll, $args) = @_;
313    return $coll->count_documents($args->{'filter'});
314}
315
316sub do_count {
317    my ($main, $coll, $args) = @_;
318    return $coll->count_documents($args->{'filter'});
319}
320
321sub do_list_collection_names {
322    my ($main, $coll, $args) = @_;
323    return [ $coll->database->collection_names ];
324}
325
326sub do_list_collection_objects {
327    my ($main, $coll, $args) = @_;
328    return $main->do_list_collections($coll, $args);
329}
330
331sub do_list_collections {
332    my ($main, $coll, $args) = @_;
333    return [ $coll->database->list_collections->all ];
334}
335
336sub do_list_database_objects {
337    my ($main, $coll, $args) = @_;
338    return $main->do_list_databases($coll, $args);
339}
340
341sub do_list_database_names {
342    my ($main, $coll, $args) = @_;
343    return [ $coll->client->database_names ];
344}
345
346sub do_list_databases {
347    my ($main, $coll, $args) = @_;
348    return [ $coll->client->list_databases ];
349}
350
351sub do_list_index_names {
352    my ($main, $coll, $args) = @_;
353    return [ map { $_->{'name'} } @{$main->do_list_indexes($coll, $args)} ];
354}
355
356sub do_list_indexes {
357    my ($main, $coll, $args) = @_;
358    $coll->insert_one({});
359    return [ $coll->indexes->list->all ];
360}
361
362sub do_download {
363    my ($main, $gridfs, $args) = @_;
364    my $stream = $gridfs->open_download_stream(
365        bson_oid($args->{'id'}{'$oid'})
366    );
367    my $data = do { local $/; $stream->readline };
368    $stream->close;
369    return $data;
370}
371
372clear_testdbs;
373
374done_testing;
375