Current File : /home/opti/optisoftcom/.cpanm/work/1544535406.20768/MongoDB-v2.0.2/t/transactions-spec.t
# Copyright 2018 - present MongoDB, Inc.
#
# Licensed under the Apache License, Version 2.0 (the "License");
# you may not use this file except in compliance with the License.
# You may obtain a copy of the License at
#
# http://www.apache.org/licenses/LICENSE-2.0
#
# Unless required by applicable law or agreed to in writing, software
# distributed under the License is distributed on an "AS IS" BASIS,
# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
# See the License for the specific language governing permissions and
# limitations under the License.
use strict;
use warnings;
use JSON::MaybeXS qw( is_bool decode_json );
use Path::Tiny 0.054; # basename with suffix
use Test::More 0.96;
use Test::Deep;
use Math::BigInt;
use Storable qw( dclone );
use utf8;
use MongoDB;
use MongoDB::_Types qw/
to_IxHash
/;
use MongoDB::Error;
use lib "t/lib";
use if $ENV{MONGOVERBOSE}, qw/Log::Any::Adapter Stderr/;
use MongoDBTest qw/
build_client
get_test_db
server_version
server_type
clear_testdbs
get_unique_collection
skip_unless_mongod
skip_unless_failpoints_available
skip_unless_transactions
/;
skip_unless_mongod();
skip_unless_failpoints_available();
skip_unless_transactions();
my @events;
sub clear_events { @events = () }
sub event_count { scalar @events }
# Must use dclone, as was causing action at a distance for binc on txn number
sub event_cb { push @events, dclone $_[0] }
my $conn = build_client();
my $server_version = server_version($conn);
my $server_type = server_type($conn);
plan skip_all => "Requires MongoDB 4.0"
if $server_version < v4.0.0;
plan skip_all => "deployment does not support transactions"
unless $conn->_topology->_supports_transactions;
# defines which argument hash fields become positional arguments
my %method_args = (
insert_one => [qw( document )],
insert_many => [qw( documents )],
delete_one => [qw( filter )],
delete_many => [qw( filter )],
replace_one => [qw( filter replacement )],
update_one => [qw( filter update )],
update_many => [qw( filter update )],
find => [qw( filter )],
count => [qw( filter )],
bulk_write => [qw( requests )],
find_one_and_update => [qw( filter update )],
find_one_and_replace => [qw( filter replacement )],
find_one_and_delete => [qw( filter )],
run_command => [qw( command readPreference )],
aggregate => [qw( pipeline )],
distinct => [qw( fieldName filter )],
);
my $dir = path("t/data/transactions");
my $iterator = $dir->iterator;
while ( my $path = $iterator->() ) {
next unless $path =~ /\.json$/;
my $plan = eval { decode_json( $path->slurp_utf8 ) };
if ($@) {
die "Error decoding $path: $@";
}
my $test_db_name = $plan->{database_name};
my $test_coll_name = $plan->{collection_name};
subtest $path => sub {
for my $test ( @{ $plan->{tests} } ) {
my $description = $test->{description};
local $TODO = 'does a run_command read_preference count as a user configurable read_preference?' if $path =~ /run-command/ && $description =~ /explicit secondary read preference/;
subtest $description => sub {
my $client = build_client();
# Kills its own session as well
eval { $client->send_admin_command([ killAllSessions => [] ]) };
my $test_db = $client->get_database( $test_db_name );
# We crank wtimeout up to 10 seconds to help reduce
# replication timeouts in testing
my $test_coll = $test_db->get_collection(
$test_coll_name,
{ write_concern => { w => 'majority', wtimeout => 10000 } }
);
$test_coll->drop;
# Drop first to make sure its clear for the next test.
# MongoDB::Collection doesnt have a ->create option so done as
# a seperate step.
$test_db->run_command([ create => $test_coll_name ]);
if ( scalar @{ $plan->{data} } > 0 ) {
$test_coll->insert_many( $plan->{data} );
}
set_failpoint( $client, $test->{failPoint} );
run_test( $test_db_name, $test_coll_name, $test );
clear_failpoint( $client, $test->{failPoint} );
if ( defined $test->{outcome}{collection}{data} ) {
my @outcome = $test_coll->find()->all;
cmp_deeply( \@outcome, $test->{outcome}{collection}{data}, 'outcome as expected' )
}
};
}
};
}
sub set_failpoint {
my ( $client, $failpoint ) = @_;
return unless defined $failpoint;
my $ret = $client->send_admin_command([
configureFailPoint => $failpoint->{configureFailPoint},
mode => $failpoint->{mode},
defined $failpoint->{data}
? ( data => $failpoint->{data} )
: (),
]);
}
sub clear_failpoint {
my ( $client, $failpoint ) = @_;
return unless defined $failpoint;
my $ret = $client->send_admin_command([
configureFailPoint => $failpoint->{configureFailPoint},
mode => 'off',
]);
}
sub to_snake_case {
my $t = shift;
$t =~ s{([A-Z])}{_\L$1}g;
return $t;
}
sub remap_hash_to_snake_case {
my $hash = shift;
return {
map {
my $k = to_snake_case( $_ );
$k => $hash->{ $_ }
} keys %$hash
}
}
# Global so can get values when checking sessions
my %sessions;
sub run_test {
my ( $test_db_name, $test_coll_name, $test ) = @_;
my $client_options = $test->{clientOptions} // {};
$client_options = remap_hash_to_snake_case( $client_options );
# TODO Why is read_preference a read only mutator????....
if ( exists $client_options->{read_preference} ) {
$client_options->{read_pref_mode} = delete $client_options->{read_preference};
}
my $client = build_client(
monitoring_callback => \&event_cb,
# Explicitly disable retry_writes for the test, as they change the
# txnNumber counting used in the test specs.
retry_writes => 0,
%$client_options
);
my $session_options = $test->{sessionOptions} // {};
%sessions = (
session0 => $client->start_session( $session_options->{session0} ),
session1 => $client->start_session( $session_options->{session1} ),
);
$sessions{session0_lsid} = $sessions{session0}->session_id;
$sessions{session1_lsid} = $sessions{session1}->session_id;
# Force handshakes before clearing event monitoring log
$client->topology_status( refresh => 1 );
clear_events();
for my $operation ( @{ $test->{operations} } ) {
my $collection_options = $operation->{collectionOptions} // {};
$collection_options = remap_hash_to_snake_case( $collection_options );
my $op_result = $operation->{result};
eval {
$sessions{ database } = $client->get_database( $test_db_name );
$sessions{ collection } = $sessions{ database }->get_collection( $test_coll_name, $collection_options );
my $cmd = to_snake_case( $operation->{name} );
# TODO count is checked specifically for errors during a transaction so warning here is not useful - we cannot change to count_documents, which is actually allowed in transactions.
local $ENV{PERL_MONGO_NO_DEP_WARNINGS} = 1 if $cmd eq 'count';
if ( $cmd =~ /_transaction$/ ) {
my $op_args = $operation->{arguments} // {};
$sessions{ $operation->{object} }->$cmd( $op_args->{options} );
} else {
my @args = _adjust_arguments( $cmd, $operation->{arguments} );
$args[-1]->{session} = $sessions{ $args[-1]->{session} }
if exists $args[-1]->{session};
$args[-1]->{returnDocument} = lc $args[-1]->{returnDocument}
if exists $args[-1]->{returnDocument};
if ( $cmd eq 'find' ) {
# not every find command actually has a filter
@args = ( undef, $args[0] )
if scalar( @args ) == 1;
}
if ( $cmd eq 'run_command' ) {
$args[0] = to_IxHash( $args[0] );
# move command to the beginning of the hash
my $cmd_arg = $args[0]->DELETE( $operation->{command_name} );
$args[0]->Unshift( $operation->{command_name}, $cmd_arg );
# May not have had a readPreference set
@args = ( $args[0], undef, $args[1] )
if scalar( @args ) == 2;
}
if ( $cmd eq 'distinct' ) {
@args = ( $args[0], undef, $args[1] )
if scalar( @args ) == 2;
}
my $ret = $sessions{ $operation->{object} }->$cmd( @args );
# special case 'find' so commands are actually emitted
my $result = $ret;
$result = [ $ret->all ]
if ( grep { $cmd eq $_ } qw/ find aggregate distinct / );
check_result_outcome( $result, $op_result );
}
};
my $err = $@;
check_error( $err, $op_result );
}
$sessions{session0}->end_session;
$sessions{session1}->end_session;
if ( defined $test->{expectations} ) {
check_event_expectations( _adjust_types( $test->{expectations} ) );
}
%sessions = ();
}
sub check_error {
my ( $err, $exp ) = @_;
my $expecting_error = 0;
if ( ref( $exp ) eq 'HASH' ) {
$expecting_error = grep {/^error/} keys %{ $exp };
}
if ( $err ) {
unless ( $expecting_error ) {
my $diag_msg = 'Not expecting error, got "' . $err->message . '"';
fail $diag_msg;
return;
}
my $err_contains = $exp->{errorContains};
my $err_code_name = $exp->{errorCodeName};
my $err_labels_contains = $exp->{errorLabelsContain};
my $err_labels_omit = $exp->{errorLabelsOmit};
if ( defined $err_contains ) {
$err_contains =~ s/abortTransaction/abort_transaction/;
$err_contains =~ s/commitTransaction/commit_transaction/;
like $err->message, qr/$err_contains/i, 'error contains ' . $err_contains;
}
if ( defined $err_code_name ) {
is $err->result->output->{codeName},
$err_code_name,
'error has name ' . $err_code_name;
}
if ( defined $err_labels_omit ) {
for my $err_label ( @{ $err_labels_omit } ) {
ok ! $err->has_error_label( $err_label ), 'error doesnt have label ' . $err_label;
}
}
if ( defined $err_labels_omit ) {
for my $err_label ( @{ $err_labels_contains } ) {
ok $err->has_error_label( $err_label ), 'error has label ' . $err_label;
}
}
} elsif ( $expecting_error ) {
fail 'Expecting error, but no error found';
}
}
sub check_result_outcome {
my ( $got, $exp ) = @_;
if ( ref( $exp ) eq 'ARRAY' ) {
check_array_result_outcome( $got, $exp );
} else {
check_hash_result_outcome( $got, $exp );
}
}
sub check_array_result_outcome {
my ( $got, $exp ) = @_;
cmp_deeply $got, $exp, 'result as expected';
}
sub check_hash_result_outcome {
my ( $got, $exp ) = @_;
my $ok = 1;
for my $key ( keys %$exp ) {
my $obj_key = to_snake_case( $key );
next if ( $key eq 'upsertedCount' && !$got->can('upserted_count') );
# Some results are just raw results
if ( ref $got eq 'HASH' ) {
$ok &&= cmp_deeply $got->{ $obj_key }, $exp->{ $key }, "$key result correct";
} else {
# if we got something of the wrong type, it won't have the
# right methods and we can note that and skip.
unless ( can_ok($got, $obj_key) ) {
$ok = 0;
next;
}
$ok &&= cmp_deeply $got->$obj_key, $exp->{ $key }, "$key result correct";
}
}
if ( !$ok ) {
diag "GOT:\n", explain($got), "\nEXPECT:\n", explain($exp);
}
}
# Following subs modified from monitoring_spec.t
#
# prepare collection method arguments
# adjusts data structures and extracts leading positional arguments
sub _adjust_arguments {
my ($method, $args) = @_;
$args = _adjust_types($args);
my @fields = @{ $method_args{$method} };
my @field_values = map {
my $val = delete $args->{$_};
# bulk write is special cased to reuse argument extraction
($method eq 'bulk_write' and $_ eq 'requests')
? _adjust_bulk_write_requests($val)
: $val;
} @fields;
return(
(grep { defined } @field_values),
scalar(keys %$args) ? $args : (),
);
}
# prepare bulk write requests for use as argument to ->bulk_write
sub _adjust_bulk_write_requests {
my ($requests) = @_;
return [map {
# Different data structure in bulk writes compared to command_monitoring
my $name = to_snake_case( $_->{name} );
+{ $name => [_adjust_arguments($name, $_->{arguments})] };
} @$requests];
}
# some type transformations
# turns { '$numberLong' => $n } into 0+$n
sub _adjust_types {
my ($value) = @_;
if (ref $value eq 'HASH') {
if (scalar(keys %$value) == 1) {
my ($name, $value) = %$value;
if ($name eq '$numberLong') {
return 0+$value;
}
}
return +{map {
my $key = $_;
($key, _adjust_types($value->{$key}));
} keys %$value};
}
elsif (ref $value eq 'ARRAY') {
return [map { _adjust_types($_) } @$value];
}
else {
return $value;
}
}
# common overrides for event data expectations
sub prepare_data_spec {
my ($spec) = @_;
if ( ! defined $spec ) {
return $spec;
}
elsif (not ref $spec) {
if ($spec eq 'test') {
return any(qw( test test_collection ));
}
if ($spec eq 'test-unacknowledged-bulk-write') {
return code(\&_verify_is_nonempty_str);
}
if ($spec eq 'command-monitoring-tests.test') {
return code(\&_verify_is_nonempty_str);
}
return $spec;
}
elsif (is_bool $spec) {
my $specced = $spec ? 1 : 0;
return code(sub {
my $value = shift;
return(0, 'expected a true boolean value')
if $specced and not $value;
return(0, 'expected a false boolean value')
if $value and not $specced;
return 1;
});
}
elsif (ref $spec eq 'ARRAY') {
return [map {
prepare_data_spec($_)
} @$spec];
}
elsif (ref $spec eq 'HASH') {
return +{map {
($_, prepare_data_spec($spec->{$_}))
} keys %$spec};
}
else {
return $spec;
}
}
sub check_event_expectations {
my ( $expected ) = @_;
# We only care about command_started events; also ignoring sasl* and
# ismaster commands caused by re-negotiation after network error
my @got = grep { $_->{type} eq 'command_started' && $_->{commandName} !~ /sasl|ismaster/ } @events;
for my $exp ( @$expected ) {
my ($exp_type, $exp_spec) = %$exp;
# We only have command_started_event checks
subtest $exp_type => sub {
ok(scalar(@got), 'event available')
or return;
my $event = shift @got;
is($event->{type}.'_event', $exp_type, "is a $exp_type")
or return;
my $event_tester = "check_$exp_type";
main->can($event_tester)->($exp_spec, $event);
};
}
is scalar(@got), 0, 'no outstanding events';
}
sub check_event {
my ($exp, $event) = @_;
for my $key (sort keys %$exp) {
my $check = "check_${key}_field";
main->can($check)->($exp->{$key}, $event);
}
}
#
# per-event type test handlers
#
sub check_command_started_event {
my ($exp, $event) = @_;
check_event($exp, $event);
}
#
# verificationi subs for use with Test::Deep::code
#
sub _verify_is_positive_num {
my $value = shift;
return(0, "error code is not defined")
unless defined $value;
return(0, "error code is not positive")
unless $value > 1;
return 1;
}
sub _verify_is_nonempty_str {
my $value = shift;
return(0, "error message is not defined")
unless defined $value;
return(0, "error message is empty")
unless length $value;
return 1;
}
#
# event field test handlers
#
# $event.database_name
sub check_database_name_field {
my ($exp_name, $event) = @_;
ok defined($event->{databaseName}), "database_name defined";
ok length($event->{databaseName}), "database_name non-empty";
}
# $event.command_name
sub check_command_name_field {
my ($exp_name, $event) = @_;
is $event->{commandName}, $exp_name, "command name";
}
# $event.reply
sub check_reply_field {
my ($exp_reply, $event) = @_;
my $event_reply = $event->{reply};
# special case for $event.reply.cursor.id
if (exists $exp_reply->{cursor}) {
if (exists $exp_reply->{cursor}{id}) {
$exp_reply->{cursor}{id} = code(\&_verify_is_positive_num)
if $exp_reply->{cursor}{id} eq '42';
}
}
# special case for $event.reply.writeErrors
if (exists $exp_reply->{writeErrors}) {
for my $i ( 0 .. $#{ $exp_reply->{writeErrors} } ) {
my $error = $exp_reply->{writeErrors}[$i];
if (exists $error->{code} and $error->{code} eq 42) {
$error->{code} = code(\&_verify_is_positive_num);
}
if (exists $error->{errmsg} and $error->{errmsg} eq '') {
$error->{errmsg} = code(\&_verify_is_nonempty_str);
}
$exp_reply->{writeErrors}[$i] = superhashof( $error );
}
}
# special case for $event.command.cursorsUnknown on killCursors
if ($event->{commandName} eq 'killCursors'
and defined $exp_reply->{cursorsUnknown}
) {
for my $index (0 .. $#{ $exp_reply->{cursorsUnknown} }) {
$exp_reply->{cursorsUnknown}[$index]
= code(\&_verify_is_positive_num)
if $exp_reply->{cursorsUnknown}[$index] eq 42;
}
}
for my $exp_key (sort keys %$exp_reply) {
cmp_deeply
$event_reply->{$exp_key},
prepare_data_spec($exp_reply->{$exp_key}),
"reply field $exp_key" or diag explain $event_reply->{$exp_key};
}
}
# $event.command
sub check_command_field {
my ($exp_command, $event) = @_;
my $event_command = $event->{command};
# ordered defaults to true
delete $exp_command->{ordered};
# special case for $event.command.getMore
if (exists $exp_command->{getMore}) {
$exp_command->{getMore} = code(\&_verify_is_positive_num)
if $exp_command->{getMore} eq '42';
}
# special case for $event.command.writeConcern.wtimeout
if (defined $exp_command->{writeConcern}) {
$exp_command->{writeConcern}{wtimeout} = ignore();
}
# special case for $event.command.cursors on killCursors
if ($event->{commandName} eq 'killCursors'
and defined $exp_command->{cursors}
) {
for my $index (0 .. $#{ $exp_command->{cursors} }) {
$exp_command->{cursors}[$index]
= code(\&_verify_is_positive_num)
if $exp_command->{cursors}[$index] eq 42;
}
}
if ( defined $exp_command->{lsid} ) {
# Stuff correct session id in
$exp_command->{lsid} = $sessions{ $exp_command->{lsid} . '_lsid' };
}
if ( defined $exp_command->{readConcern} ) {
$exp_command->{readConcern}{afterClusterTime} = Isa('BSON::Timestamp')
if ( defined $exp_command->{readConcern}{afterClusterTime} && $exp_command->{readConcern}{afterClusterTime} eq '42' );
}
if ( defined $exp_command->{txnNumber} ) {
$exp_command->{txnNumber} = Math::BigInt->new($exp_command->{txnNumber});
}
for my $exp_key (sort keys %$exp_command) {
my $event_value = $event_command->{$exp_key};
my $exp_value = prepare_data_spec($exp_command->{$exp_key});
my $label = "command field '$exp_key'";
if (
(grep { $exp_key eq $_ } qw( comment maxTimeMS ))
or
($event->{commandName} eq 'getMore' and $exp_key eq 'batchSize')
) {
TODO: {
local $TODO =
"Command field '$exp_key' requires other fixes";
cmp_deeply $event_value, $exp_value, $label;
}
}
elsif ( !defined $exp_value )
{
ok ! exists $event_command->{$exp_key}, $label . ' does not exist';
}
else {
cmp_deeply $event_value, $exp_value, $label;
}
}
}
clear_testdbs;
done_testing;
Mini Shell