From 1944cffdad44cb91ae36b93e458040101bc90f16 Mon Sep 17 00:00:00 2001 From: Thomas Bloor Date: Tue, 3 Apr 2018 18:58:14 +0100 Subject: [PATCH 01/11] PERL-793 Causal Consistency support on Read Concerns for sessions --- lib/MongoDB/ClientSession.pm | 51 +++++++++++++++++++++++++++-- lib/MongoDB/Cursor.pm | 1 + lib/MongoDB/Op/_Aggregate.pm | 2 +- lib/MongoDB/Op/_Command.pm | 3 ++ lib/MongoDB/Op/_Count.pm | 2 +- lib/MongoDB/Op/_Distinct.pm | 2 +- lib/MongoDB/Op/_Explain.pm | 3 +- lib/MongoDB/Op/_ParallelScan.pm | 2 +- lib/MongoDB/Op/_Query.pm | 2 +- lib/MongoDB/ReadConcern.pm | 29 +++++++++------- lib/MongoDB/Role/_SessionSupport.pm | 44 +++++++++++++++++-------- lib/MongoDB/_Types.pm | 3 ++ 12 files changed, 111 insertions(+), 33 deletions(-) diff --git a/lib/MongoDB/ClientSession.pm b/lib/MongoDB/ClientSession.pm index 39e7086f..cfff207f 100644 --- a/lib/MongoDB/ClientSession.pm +++ b/lib/MongoDB/ClientSession.pm @@ -25,6 +25,7 @@ use MongoDB::Error; use Moo; use MongoDB::_Types qw( Document + MongoDBTimestamp ); use Types::Standard qw( Bool @@ -74,7 +75,10 @@ has options => ( # Shallow copy to prevent action at a distance. # Upgrade to use Storable::dclone if a more complex option is required coerce => sub { - $_[0] = { %{ $_[0] } }; + $_[0] = { + causalConsistency => 1, + %{ $_[0] } + }; }, ); @@ -86,6 +90,21 @@ has _server_session => ( clearer => '__clear_server_session', ); +=attr operation_time + +The last operation time. This is updated when an operation is performed during +this session, or when L is called. Used for causal +consistency. + +=cut + +has operation_time => ( + is => 'rwp', + isa => Maybe[MongoDBTimestamp], + init_arg => undef, + default => undef, +); + =method session_id The session id for this particular session. This should be considered @@ -119,7 +138,7 @@ sub get_latest_cluster_time { if ( defined $self->client->_cluster_time ) { # Both must be defined here so can just compare if ( $self->cluster_time->{'clusterTime'} - > $self->client->_cluster_time->{'clusterTime'} ) { + > $self->client->_cluster_time->{'clusterTime'} ) { return $self->cluster_time; } else { return $self->client->_cluster_time; @@ -160,6 +179,34 @@ sub advance_cluster_time { return; } +=method advance_operation_time + + $session->advance_operation_time( $operation_time ); + +Update the L for this session. If the value provided is more +recent than the sessions current operation time, then the session will be +updated to this provided value. + +Setting C with a manually crafted value may cause a server +error. It is reccomended to only use an C retreived from +another session or directly from a database call. + +=cut + +sub advance_operation_time { + my ( $self, $operation_time ) = @_; + + # Just dont update operation_time if they've denied this, as it'l stop + # everywhere else that updates based on this value from the session + return unless $self->options->{causalConsistency}; + + if ( !defined( $self->operation_time ) + || ( $operation_time > $self->operation_time ) ) { + $self->_set_operation_time( $operation_time ); + } + return; +} + =method end_session $session->end_session; diff --git a/lib/MongoDB/Cursor.pm b/lib/MongoDB/Cursor.pm index ba6d6bd2..f1335472 100644 --- a/lib/MongoDB/Cursor.pm +++ b/lib/MongoDB/Cursor.pm @@ -443,6 +443,7 @@ sub explain { query => $self->_query, read_preference => $self->_query->read_preference, read_concern => $self->_query->read_concern, + session => $self->_query->session, monitoring_callback => $self->client->monitoring_callback, ); diff --git a/lib/MongoDB/Op/_Aggregate.pm b/lib/MongoDB/Op/_Aggregate.pm index 8d406d38..f80b10a4 100644 --- a/lib/MongoDB/Op/_Aggregate.pm +++ b/lib/MongoDB/Op/_Aggregate.pm @@ -137,7 +137,7 @@ sub execute { pipeline => $self->pipeline, %$options, ( - !$has_out && $link->accepts_wire_version(4) ? @{ $self->read_concern->as_args } : () + !$has_out && $link->accepts_wire_version(4) ? @{ $self->read_concern->as_args( $self->session ) } : () ), ( $has_out && $link->accepts_wire_version(5) ? @{ $self->write_concern->as_args } : () diff --git a/lib/MongoDB/Op/_Command.pm b/lib/MongoDB/Op/_Command.pm index 43c2157e..ab5beb5d 100644 --- a/lib/MongoDB/Op/_Command.pm +++ b/lib/MongoDB/Op/_Command.pm @@ -107,6 +107,9 @@ sub execute { address => $link->address, ); + # Must happen even on an error (ie. the command fails) + $self->_update_operation_time( $res ); + $res->assert; $self->_update_session_and_cluster_time($res); diff --git a/lib/MongoDB/Op/_Count.pm b/lib/MongoDB/Op/_Count.pm index 1f27a70d..52882a6f 100644 --- a/lib/MongoDB/Op/_Count.pm +++ b/lib/MongoDB/Op/_Count.pm @@ -63,7 +63,7 @@ sub execute { query => $self->filter, ($link->accepts_wire_version(4) ? - @{ $self->read_concern->as_args } : () ), + @{ $self->read_concern->as_args( $self->session ) } : () ), %{ $self->options }, ]; diff --git a/lib/MongoDB/Op/_Distinct.pm b/lib/MongoDB/Op/_Distinct.pm index b3da4239..ab667140 100644 --- a/lib/MongoDB/Op/_Distinct.pm +++ b/lib/MongoDB/Op/_Distinct.pm @@ -88,7 +88,7 @@ sub execute { key => $self->fieldname, query => $filter, ($link->accepts_wire_version(4) ? - @{ $self->read_concern->as_args } : ()), + @{ $self->read_concern->as_args( $self->session ) } : ()), %$options ); diff --git a/lib/MongoDB/Op/_Explain.pm b/lib/MongoDB/Op/_Explain.pm index 56311729..0cf31cd5 100644 --- a/lib/MongoDB/Op/_Explain.pm +++ b/lib/MongoDB/Op/_Explain.pm @@ -74,11 +74,12 @@ sub _command_explain { db_name => $self->db_name, query => [ explain => $cmd, - @{ $self->read_concern->as_args } + @{ $self->read_concern->as_args( $self->session ) } ], query_flags => {}, read_preference => $self->read_preference, bson_codec => $self->bson_codec, + session => $self->session, monitoring_callback => $self->monitoring_callback, ); my $res = $op->execute( $link, $topology ); diff --git a/lib/MongoDB/Op/_ParallelScan.pm b/lib/MongoDB/Op/_ParallelScan.pm index 8302182b..667a83bb 100644 --- a/lib/MongoDB/Op/_ParallelScan.pm +++ b/lib/MongoDB/Op/_ParallelScan.pm @@ -60,7 +60,7 @@ sub execute { parallelCollectionScan => $self->coll_name, numCursors => $self->num_cursors, ($link->accepts_wire_version(4) ? - @{ $self->read_concern->as_args } : () ), + @{ $self->read_concern->as_args( $self->session ) } : () ), %{$self->options}, ]; diff --git a/lib/MongoDB/Op/_Query.pm b/lib/MongoDB/Op/_Query.pm index 440af1bf..20eaa461 100644 --- a/lib/MongoDB/Op/_Query.pm +++ b/lib/MongoDB/Op/_Query.pm @@ -263,7 +263,7 @@ sub _as_command { tailable => $tailable, awaitData => $await_data, singleBatch => ( $single_batch ? $TRUE : $FALSE ), - @{ $self->{read_concern}->as_args }, + @{ $self->{read_concern}->as_args( $self->session ) }, ( $limit ? ( limit => $limit ) : () ), ( $batch_size ? ( batchSize => $batch_size ) : () ), diff --git a/lib/MongoDB/ReadConcern.pm b/lib/MongoDB/ReadConcern.pm index 64cb0931..995a6ac5 100644 --- a/lib/MongoDB/ReadConcern.pm +++ b/lib/MongoDB/ReadConcern.pm @@ -58,13 +58,6 @@ has level => ( predicate => 'has_level', ); -has _as_args => ( - is => 'lazy', - isa => ArrayRef, - reader => 'as_args', - builder => '_build_as_args', -); - sub BUILD { my $self = shift; if ( defined $self->{level} ) { @@ -72,16 +65,30 @@ sub BUILD { } } -sub _build_as_args { - my ($self) = @_; +# public interface for compatibility, but undocumented +sub as_args { + my ( $self, $session ) = @_; + # if session is defined and operation_time is not, then either the + # operation_time was not sent on the response from the server for this + # session or the session has causal consistency disabled. if ( $self->{level} ) { return [ - readConcern => { level => $self->{level} } + readConcern => { + level => $self->{level}, + ( defined $session && defined $session->operation_time + ? ( afterClusterTime => $session->operation_time ) + : () ), + } ]; } else { - return []; + return [ + ( defined $session && defined $session->operation_time + ? ( readConcern => { afterClusterTime => $session->operation_time } ) + : () + ) + ]; } } diff --git a/lib/MongoDB/Role/_SessionSupport.pm b/lib/MongoDB/Role/_SessionSupport.pm index 0c9435c8..571570a0 100644 --- a/lib/MongoDB/Role/_SessionSupport.pm +++ b/lib/MongoDB/Role/_SessionSupport.pm @@ -47,12 +47,12 @@ sub _apply_session_and_cluster_time { my $cluster_time = $self->session->get_latest_cluster_time; # No cluster time in either session or client - return unless defined $cluster_time; - - if ( $link->server->is_master->{maxWireVersion} >= 6 ) { - # Gossip the clusterTime - $$query_ref = to_IxHash( $$query_ref ); - ($$query_ref)->Push( '$clusterTime' => $cluster_time ); + if ( defined $cluster_time ) { + if ( $link->server->is_master->{maxWireVersion} >= 6 ) { + # Gossip the clusterTime + $$query_ref = to_IxHash( $$query_ref ); + ($$query_ref)->Push( '$clusterTime' => $cluster_time ); + } } return; @@ -69,19 +69,35 @@ sub _update_session_and_cluster_time { # No point continuing as theres nothing to do even if clusterTime is returned return unless defined $self->session; - my $cluster_time; - if ( $response->$_isa( 'MongoDB::CommandResult' ) ) { - $cluster_time = $response->output->{'$clusterTime'}; - } else { - $cluster_time = $response->{'$clusterTime'}; + my $cluster_time = $self->__extract_from( $response, '$clusterTime' ); + + if ( defined $cluster_time ) { + $self->session->client->_update_cluster_time( $cluster_time ); + $self->session->advance_cluster_time( $cluster_time ); } - return unless defined $cluster_time; + return; +} + +sub _update_operation_time { + my ( $self, $response ) = @_; + + return unless defined $self->session; - $self->session->client->_update_cluster_time( $cluster_time ); - $self->session->advance_cluster_time( $cluster_time ); + my $operation_time = $self->__extract_from( $response, 'operationTime' ); + $self->session->advance_operation_time( $operation_time ) if defined $operation_time; return; } +sub __extract_from { + my ( $self, $response, $key ) = @_; + + if ( $response->$_isa( 'MongoDB::CommandResult' ) ) { + return $response->output->{ $key }; + } else { + return $response->{ $key }; + } +} + 1; diff --git a/lib/MongoDB/_Types.pm b/lib/MongoDB/_Types.pm index 5051a56d..4b2f730d 100644 --- a/lib/MongoDB/_Types.pm +++ b/lib/MongoDB/_Types.pm @@ -48,6 +48,7 @@ use Type::Library MaybeHashRef MongoDBCollection MongoDBDatabase + MongoDBTimestamp NonEmptyStr NonNegNum OID @@ -128,6 +129,8 @@ class_type MongoDBCollection, { class => 'MongoDB::Collection' }; class_type MongoDBDatabase, { class => 'MongoDB::Database' }; +class_type MongoDBTimestamp, { class => 'MongoDB::Timestamp' }; + declare NonEmptyStr, as Str, where { defined $_ && length $_ }; declare NonNegNum, as Num, From bd0a01a60e1a561c0ea16bed39847af0de7ff502 Mon Sep 17 00:00:00 2001 From: Thomas Bloor Date: Tue, 3 Apr 2018 19:36:38 +0100 Subject: [PATCH 02/11] PERL-793 first 3 subtests for causal consistency --- devel/t-dynamic/PERL-793-causal_consistency.t | 119 ++++++++++++++++++ 1 file changed, 119 insertions(+) create mode 100644 devel/t-dynamic/PERL-793-causal_consistency.t diff --git a/devel/t-dynamic/PERL-793-causal_consistency.t b/devel/t-dynamic/PERL-793-causal_consistency.t new file mode 100644 index 00000000..ef12d2aa --- /dev/null +++ b/devel/t-dynamic/PERL-793-causal_consistency.t @@ -0,0 +1,119 @@ +# +# Copyright 2015 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 Test::More 0.96; +use Test::Fatal; +use Test::Deep qw/!blessed/; +use UUID::Tiny ':std'; # Use newer interface + +use utf8; +use Tie::IxHash; + +use MongoDB; +use MongoDB::Error; + +use lib "t/lib"; +use lib "devel/lib"; + +use if $ENV{MONGOVERBOSE}, qw/Log::Any::Adapter Stderr/; + +use MongoDBTest::Orchestrator; + +use MongoDBTest qw/ + build_client + get_test_db + server_version + server_type + clear_testdbs + get_unique_collection +/; + +use Test::Role::BSONDebug; +Role::Tiny->apply_roles_to_package( + 'MongoDB::BSON', 'Test::Role::BSONDebug', +); + +my $orc = +MongoDBTest::Orchestrator->new( + config_file => "devel/config/replicaset-single-3.6.yml" ); +$orc->start; + +$ENV{MONGOD} = $orc->as_uri; + +print $ENV{MONGOD}; + +my $conn = build_client(); +my $testdb = get_test_db($conn); +my $server_version = server_version($conn); +my $server_type = server_type($conn); +my $coll = $testdb->get_collection('test_collection'); + +plan skip_all => "Requires MongoDB 3.6" + if $server_version < v3.6.0; + +Test::Role::BSONDebug::CLEAR_ENCODE_ONE_QUEUE; +Test::Role::BSONDebug::CLEAR_DECODE_ONE_QUEUE; + +subtest 'session operation_time undef on init' => sub { + my $session = $conn->start_session; + is $session->operation_time, undef, 'is undef'; +}; + +Test::Role::BSONDebug::CLEAR_ENCODE_ONE_QUEUE; +Test::Role::BSONDebug::CLEAR_DECODE_ONE_QUEUE; + +subtest 'first read' => sub { + my $session = $conn->start_session({ causalConsistency => 1 }); + + my $response = $coll->find_one({ _id => 1 }, {}, { session => $session }); + + my $command = Test::Role::BSONDebug::GET_LAST_ENCODE_ONE; + + ok ! $command->EXISTS( 'afterClusterTime' ), 'afterClusterTime not sent on first read'; +}; + +Test::Role::BSONDebug::CLEAR_ENCODE_ONE_QUEUE; +Test::Role::BSONDebug::CLEAR_DECODE_ONE_QUEUE; + +subtest 'update operation_time' => sub { + my $session = $conn->start_session({ causalConsistency => 1 }); + + is $session->operation_time, undef, 'Empty operation time'; + + my $response = $coll->insert_one({ _id => 1 }, { session => $session }); + + my $bson = Test::Role::BSONDebug::GET_LAST_DECODE_ONE; + + is $session->operation_time, $bson->{operation_time}, 'response has operation time and is updated in session'; + + $session->end_session; + + $session = $conn->start_session({ causalConsistency => 1 }); + + my $err = exception { $coll->insert_one({ _id => 1 }, { session => $session }) }; + + isa_ok( $err, 'MongoDB::DatabaseError', "duplicate insert error" ); + + my $error_bson = Test::Role::BSONDebug::GET_LAST_DECODE_ONE; + + is $session->operation_time, $error_bson->{operation_time}, 'response has operation time and is updated in session'; +}; + +clear_testdbs; + +done_testing; From 78ddf29d3392f92337697025b193db8b45800958 Mon Sep 17 00:00:00 2001 From: Thomas Bloor Date: Thu, 5 Apr 2018 20:11:03 +0100 Subject: [PATCH 03/11] PERL-793 Added spec tests 4 - 6 --- devel/t-dynamic/PERL-793-causal_consistency.t | 326 +++++++++++++++++- lib/MongoDB/Role/_SingleBatchDocWrite.pm | 2 + 2 files changed, 326 insertions(+), 2 deletions(-) diff --git a/devel/t-dynamic/PERL-793-causal_consistency.t b/devel/t-dynamic/PERL-793-causal_consistency.t index ef12d2aa..28755d5a 100644 --- a/devel/t-dynamic/PERL-793-causal_consistency.t +++ b/devel/t-dynamic/PERL-793-causal_consistency.t @@ -99,19 +99,341 @@ subtest 'update operation_time' => sub { my $bson = Test::Role::BSONDebug::GET_LAST_DECODE_ONE; - is $session->operation_time, $bson->{operation_time}, 'response has operation time and is updated in session'; + is $session->operation_time, $bson->{operationTime}, 'response has operation time and is updated in session'; $session->end_session; $session = $conn->start_session({ causalConsistency => 1 }); + is $session->operation_time, undef, 'Empty operation time'; + + # Try inserting the same thing again (_id must be unique in a collection afaik) my $err = exception { $coll->insert_one({ _id => 1 }, { session => $session }) }; isa_ok( $err, 'MongoDB::DatabaseError', "duplicate insert error" ); my $error_bson = Test::Role::BSONDebug::GET_LAST_DECODE_ONE; - is $session->operation_time, $error_bson->{operation_time}, 'response has operation time and is updated in session'; + is $session->operation_time, $error_bson->{operationTime}, 'response has operation time and is updated in session'; +}; + +Test::Role::BSONDebug::CLEAR_ENCODE_ONE_QUEUE; +Test::Role::BSONDebug::CLEAR_DECODE_ONE_QUEUE; + +subtest 'find_one then read includes operationtime' => sub { + # run for all read ops: + # * find + # * find_one + # * find_id + # * aggregate + # * count + # * distinct + + subtest 'find' => sub { + my $session = find_one_and_get_session(); + my $op_time = $session->operation_time; + + $coll->find({ _id => 1 }, { session => $session })->result; + + my $command = Test::Role::BSONDebug::GET_LAST_ENCODE_ONE; + + is $op_time, $command->FETCH('readConcern')->{afterClusterTime}, 'has correct afterClusterTime'; + }; + + subtest 'find_one' => sub { + my $session = find_one_and_get_session(); + my $op_time = $session->operation_time; + + $coll->find_one({ _id => 1 }, {}, { session => $session }); + + my $command = Test::Role::BSONDebug::GET_LAST_ENCODE_ONE; + + is $op_time, $command->FETCH('readConcern')->{afterClusterTime}, 'has correct afterClusterTime'; + }; + + subtest 'find_id' => sub { + my $session = find_one_and_get_session(); + my $op_time = $session->operation_time; + + $coll->find_id(1, {}, { session => $session }); + + my $command = Test::Role::BSONDebug::GET_LAST_ENCODE_ONE; + + is $op_time, $command->FETCH('readConcern')->{afterClusterTime}, 'has correct afterClusterTime'; + }; + + + subtest 'aggregate' => sub { + my $session = find_one_and_get_session(); + my $op_time = $session->operation_time; + + $coll->aggregate([ { '$match' => { count => { '$gt' => 0 } } } ], { session => $session }); + + my $command = Test::Role::BSONDebug::GET_LAST_ENCODE_ONE; + + is $op_time, $command->FETCH('readConcern')->{afterClusterTime}, 'has correct afterClusterTime'; + }; + + + subtest 'count' => sub { + my $session = find_one_and_get_session(); + my $op_time = $session->operation_time; + + $coll->count({ _id => 1 }, { session => $session }); + + my $command = Test::Role::BSONDebug::GET_LAST_ENCODE_ONE; + + is $op_time, $command->FETCH('readConcern')->{afterClusterTime}, 'has correct afterClusterTime'; + }; + + + subtest 'distinct' => sub { + my $session = find_one_and_get_session(); + my $op_time = $session->operation_time; + + $coll->distinct("id_", { _id => 1 }, { session => $session }); + + my $command = Test::Role::BSONDebug::GET_LAST_ENCODE_ONE; + + is $op_time, $command->FETCH('readConcern')->{afterClusterTime}, 'has correct afterClusterTime'; + }; +}; + +sub find_one_and_get_session { + my $session = $conn->start_session({ causalConsistency => 1 }); + + my $find = $coll->find_one({ _id => 1 }, {}, { session => $session }); + + return $session; +} + +Test::Role::BSONDebug::CLEAR_ENCODE_ONE_QUEUE; +Test::Role::BSONDebug::CLEAR_DECODE_ONE_QUEUE; + +subtest 'write then find_one includes operationTime' => sub { + # repeat for all write ops: + # * insert_one + # * insert_many + # * delete_one + # * delete_many + # * replace_one + # * update_one + # * update_many + # * find_one_and_delete + # * find_one_and_replace + # * find_one_and_update + # * ordered_bulk + # * unordered_bulk + + subtest 'insert_one' => sub { + my $session = $conn->start_session({ causalConsistency => 1 }); + + $coll->insert_one({ _id => 100 }, { session => $session }); + + find_one_and_assert( $session ); + + $session->end_session; + + $session = $conn->start_session({ causalConsistency => 1 }); + + my $err = exception { $coll->insert_one({ _id => 100 }, { session => $session }) }; + isa_ok( $err, 'MongoDB::DatabaseError' ); + + find_one_and_assert( $session ); + }; + + subtest 'insert_many' => sub { + my $session = $conn->start_session({ causalConsistency => 1 }); + + $coll->insert_many( [ + { _id => 101 }, + { _id => 102 }, + { _id => 103 }, + { _id => 104 }, + { _id => 105 }, + { _id => 106 }, + { _id => 107 }, + { _id => 108 }, + { _id => 109 }, + { _id => 110 }, + { _id => 111 }, + ], { session => $session }); + + find_one_and_assert( $session ); + + $session->end_session; + + $session = $conn->start_session({ causalConsistency => 1 }); + + my $err = exception { + $coll->insert_many( [ + { _id => 101 }, + { _id => 102 }, + { _id => 103 }, + { _id => 104 }, + { _id => 105 }, + { _id => 106 }, + { _id => 107 }, + { _id => 108 }, + { _id => 109 }, + { _id => 110 }, + { _id => 111 }, + ], { session => $session }) + }; + isa_ok( $err, 'MongoDB::DatabaseError' ); + + find_one_and_assert( $session ); + }; + + subtest 'delete_one' => sub { + my $session = $conn->start_session({ causalConsistency => 1 }); + + $coll->delete_one({ _id => 100 }, { session => $session }); + + find_one_and_assert( $session ); + # dont think theres a way to make delete exception? + }; + + subtest 'delete_many' => sub { + my $session = $conn->start_session({ causalConsistency => 1 }); + + $coll->delete_many({ _id => { '$in' => [101,102] } }, { session => $session }); + + find_one_and_assert( $session ); + # dont think theres a way to make delete exception? + }; + + subtest 'replace_one' => sub { + my $session = $conn->start_session({ causalConsistency => 1 }); + + $coll->replace_one({ _id => 103 }, { _id => 103, foo => 'qux' }, { session => $session }); + + find_one_and_assert( $session ); + # cant figure way to cause error? + }; + + subtest 'update_one' => sub { + my $session = $conn->start_session({ causalConsistency => 1 }); + + $coll->update_one({ _id => 104 }, { '$set' => { bar => 'baz' } }, { session => $session }); + + find_one_and_assert( $session ); + # cant figure way to cause error? + }; + + subtest 'update_many' => sub { + my $session = $conn->start_session({ causalConsistency => 1 }); + + $coll->update_many({ _id => { '$in' => [105,106] } }, { '$set' => { bar => 'baz' } }, { session => $session }); + + find_one_and_assert( $session ); + # cant figure way to cause error? + }; + + subtest 'find_one_and_delete' => sub { + my $session = $conn->start_session({ causalConsistency => 1 }); + + $coll->find_one_and_delete({ _id => 107 }, { session => $session }); + + find_one_and_assert( $session ); + # cant figure way to cause error? + }; + + subtest 'find_one_and_replace' => sub { + my $session = $conn->start_session({ causalConsistency => 1 }); + + $coll->find_one_and_replace({ _id => 108 }, { _id => 108, bar => 'baz' }, { session => $session }); + + find_one_and_assert( $session ); + # cant figure way to cause error? + }; + + subtest 'find_one_and_update' => sub { + my $session = $conn->start_session({ causalConsistency => 1 }); + + $coll->find_one_and_update({ _id => 109 }, { '$set' => { foo => 'qux' } }, { session => $session }); + + find_one_and_assert( $session ); + # cant figure way to cause error? + }; + + subtest 'ordered_bulk' => sub { + my $session = $conn->start_session({ causalConsistency => 1 }); + + my $bulk = $coll->ordered_bulk; + $bulk->insert_one({ _id => 120 }); + $bulk->insert_one({ _id => 121 }); + $bulk->execute(undef, { session => $session }); + + find_one_and_assert( $session ); + + $session->end_session; + + $session = $conn->start_session({ causalConsistency => 1 }); + + my $err = exception { + my $bulk2 = $coll->ordered_bulk; + $bulk2->insert_one({ _id => 120 }); + $bulk2->insert_one({ _id => 121 }); + $bulk2->execute(undef, { session => $session }); + }; + isa_ok( $err, 'MongoDB::DatabaseError' ); + + find_one_and_assert( $session ); + }; + + subtest 'unordered_bulk' => sub { + my $session = $conn->start_session({ causalConsistency => 1 }); + + my $bulk = $coll->unordered_bulk; + $bulk->insert_one({ _id => 123 }); + $bulk->insert_one({ _id => 124 }); + $bulk->execute(undef, { session => $session }); + + find_one_and_assert( $session ); + + $session->end_session; + + $session = $conn->start_session({ causalConsistency => 1 }); + + my $err = exception { + my $bulk2 = $coll->unordered_bulk; + $bulk2->insert_one({ _id => 123 }); + $bulk2->insert_one({ _id => 124 }); + $bulk2->execute(undef, { session => $session }); + }; + isa_ok( $err, 'MongoDB::DatabaseError' ); + + find_one_and_assert( $session ); + }; +}; + +sub find_one_and_assert { + my $session = shift; + my $op_time = $session->operation_time; + + ok defined $op_time, 'got operationTime in session'; + + $coll->find_one({ _id => 1 }, {}, { session => $session }); + + my $command = Test::Role::BSONDebug::GET_LAST_ENCODE_ONE; + + is $op_time, $command->FETCH('readConcern')->{afterClusterTime}, 'has correct afterClusterTime'; +} + +Test::Role::BSONDebug::CLEAR_ENCODE_ONE_QUEUE; +Test::Role::BSONDebug::CLEAR_DECODE_ONE_QUEUE; + +subtest 'turn off causalConsistency' => sub { + my $session = $conn->start_session({ causalConsistency => 0 }); + + $coll->find_one({ _id => 1 }, {}, { session => $session }); + + $coll->find_one({ _id => 1 }, {}, { session => $session }); + + my $command = Test::Role::BSONDebug::GET_LAST_ENCODE_ONE; + + ok ! $command->EXISTS('readConcern'), 'no readconcern'; }; clear_testdbs; diff --git a/lib/MongoDB/Role/_SingleBatchDocWrite.pm b/lib/MongoDB/Role/_SingleBatchDocWrite.pm index 8d3588b9..faaaa7dc 100644 --- a/lib/MongoDB/Role/_SingleBatchDocWrite.pm +++ b/lib/MongoDB/Role/_SingleBatchDocWrite.pm @@ -202,6 +202,8 @@ sub _send_write_command { my $res = $self->bson_codec->decode_one( $result->{docs} ); + $self->_update_operation_time( $res ); + $self->_update_session_and_cluster_time($res); # Error checking depends on write concern From b335f0c200dde4747bee177f87c4496511eb9d0e Mon Sep 17 00:00:00 2001 From: Thomas Bloor Date: Fri, 6 Apr 2018 14:43:59 +0100 Subject: [PATCH 04/11] PERL-793 finished spec tests --- devel/t-dynamic/PERL-793-causal_consistency.t | 61 ++++++++++++++++++- t/lib/MongoDBTest.pm | 5 +- 2 files changed, 63 insertions(+), 3 deletions(-) diff --git a/devel/t-dynamic/PERL-793-causal_consistency.t b/devel/t-dynamic/PERL-793-causal_consistency.t index 28755d5a..255a3521 100644 --- a/devel/t-dynamic/PERL-793-causal_consistency.t +++ b/devel/t-dynamic/PERL-793-causal_consistency.t @@ -69,6 +69,7 @@ plan skip_all => "Requires MongoDB 3.6" Test::Role::BSONDebug::CLEAR_ENCODE_ONE_QUEUE; Test::Role::BSONDebug::CLEAR_DECODE_ONE_QUEUE; +# spec test 1 subtest 'session operation_time undef on init' => sub { my $session = $conn->start_session; is $session->operation_time, undef, 'is undef'; @@ -77,6 +78,7 @@ subtest 'session operation_time undef on init' => sub { Test::Role::BSONDebug::CLEAR_ENCODE_ONE_QUEUE; Test::Role::BSONDebug::CLEAR_DECODE_ONE_QUEUE; +# spec test 2 subtest 'first read' => sub { my $session = $conn->start_session({ causalConsistency => 1 }); @@ -90,6 +92,7 @@ subtest 'first read' => sub { Test::Role::BSONDebug::CLEAR_ENCODE_ONE_QUEUE; Test::Role::BSONDebug::CLEAR_DECODE_ONE_QUEUE; +# spec test 3 subtest 'update operation_time' => sub { my $session = $conn->start_session({ causalConsistency => 1 }); @@ -120,6 +123,7 @@ subtest 'update operation_time' => sub { Test::Role::BSONDebug::CLEAR_ENCODE_ONE_QUEUE; Test::Role::BSONDebug::CLEAR_DECODE_ONE_QUEUE; +# spec test 4 subtest 'find_one then read includes operationtime' => sub { # run for all read ops: # * find @@ -210,6 +214,7 @@ sub find_one_and_get_session { Test::Role::BSONDebug::CLEAR_ENCODE_ONE_QUEUE; Test::Role::BSONDebug::CLEAR_DECODE_ONE_QUEUE; +# spec test 5 subtest 'write then find_one includes operationTime' => sub { # repeat for all write ops: # * insert_one @@ -424,6 +429,7 @@ sub find_one_and_assert { Test::Role::BSONDebug::CLEAR_ENCODE_ONE_QUEUE; Test::Role::BSONDebug::CLEAR_DECODE_ONE_QUEUE; +# spec test 6 subtest 'turn off causalConsistency' => sub { my $session = $conn->start_session({ causalConsistency => 0 }); @@ -433,7 +439,60 @@ subtest 'turn off causalConsistency' => sub { my $command = Test::Role::BSONDebug::GET_LAST_ENCODE_ONE; - ok ! $command->EXISTS('readConcern'), 'no readconcern'; + ok ! $command->EXISTS('readConcern'), 'no readconcern, so no afterClusterTime'; +}; + +Test::Role::BSONDebug::CLEAR_ENCODE_ONE_QUEUE; +Test::Role::BSONDebug::CLEAR_DECODE_ONE_QUEUE; + +# spec test 8 +subtest 'using default readConcern' => sub { + my $session = $conn->start_session({ causalConsistency => 1 }); + + # collection uses server ReadConcern by default + $coll->find_one({ _id => 1 }, {}, { session => $session }); + + my $op_time = $session->operation_time; + + $coll->find_one({ _id => 1 }, {}, { session => $session }); + + my $command = Test::Role::BSONDebug::GET_LAST_ENCODE_ONE; + + ok ! defined $command->FETCH('readConcern')->{level}, 'no read concern level with default value'; +}; + +Test::Role::BSONDebug::CLEAR_ENCODE_ONE_QUEUE; +Test::Role::BSONDebug::CLEAR_DECODE_ONE_QUEUE; + +# spec test 9 +subtest 'using custom readConcern' => sub { + my $session = $conn->start_session({ causalConsistency => 1 }); + + my $custom_coll = get_unique_collection( $testdb, 'custom_readconcern', { read_concern => { level => 'local' } } ); + # collection uses server ReadConcern by default + $custom_coll->find_one({ _id => 1 }, {}, { session => $session }); + + my $op_time = $session->operation_time; + + $custom_coll->find_one({ _id => 1 }, {}, { session => $session }); + + my $command = Test::Role::BSONDebug::GET_LAST_ENCODE_ONE; + + my $read_concern = $command->FETCH('readConcern'); + + is $read_concern->{level}, 'local', 'read concern level with custom value'; + is $read_concern->{afterClusterTime}, $op_time, 'read concern afterClusterTime present'; +}; + +#spec test 10 +subtest 'unacknowledged writes' => sub { + my $session = $conn->start_session({ causalConsistency => 1 }); + + my $custom_coll = get_unique_collection( $testdb, 'unac_write', { write_concern => { w => 0 } } ); + + $custom_coll->update_one({ _id => 1 }, { '$set' => { 'manamana' => 'doo dooo doo doodoo' } }, { session => $session }); + + ok ! defined $session->operation_time, 'no operation time set from unac write'; }; clear_testdbs; diff --git a/t/lib/MongoDBTest.pm b/t/lib/MongoDBTest.pm index 32a66a33..2f423e57 100644 --- a/t/lib/MongoDBTest.pm +++ b/t/lib/MongoDBTest.pm @@ -87,9 +87,10 @@ sub get_test_db { } sub get_unique_collection { - my ( $db, $prefix ) = @_; + my ( $db, $prefix, $options ) = @_; return $db->get_collection( - sprintf( '%s_%d_%d', $prefix, time(), int(rand(999999)) ) + sprintf( '%s_%d_%d', $prefix, time(), int(rand(999999)) ), + $options, ); } From 7d3b75dbb90298d429d90e1fea2814eb855d1a2b Mon Sep 17 00:00:00 2001 From: Thomas Bloor Date: Fri, 6 Apr 2018 14:50:27 +0100 Subject: [PATCH 05/11] PERL-793 Added documentation for causalConsistency in sessions --- lib/MongoDB/ClientSession.pm | 9 ++++++++- lib/MongoDB/MongoClient.pm | 8 ++++++++ 2 files changed, 16 insertions(+), 1 deletion(-) diff --git a/lib/MongoDB/ClientSession.pm b/lib/MongoDB/ClientSession.pm index cfff207f..1cad2559 100644 --- a/lib/MongoDB/ClientSession.pm +++ b/lib/MongoDB/ClientSession.pm @@ -64,7 +64,14 @@ has cluster_time => ( =attr options -Options provided for this particular session. +Options provided for this particular session. Available options include: + +=for :list +* C - If true, will enable causalConsistency for + this session. For more information, see L. + Defaults to true. + =cut diff --git a/lib/MongoDB/MongoClient.pm b/lib/MongoDB/MongoClient.pm index d7c0389e..16bf8baf 100644 --- a/lib/MongoDB/MongoClient.pm +++ b/lib/MongoDB/MongoClient.pm @@ -1485,6 +1485,14 @@ Returns a new L with the supplied options. will throw a C if sessions are not supported by the connected MongoDB deployment. +the options hash is an optional hash which can have the following keys: + +=for :list +* C - Enable Causally Consistent reads for this session. + Defaults to true. + +for more information see L. + =cut sub start_session { From d44d88dab00b49edcb9d91842bf8346bb1220dc5 Mon Sep 17 00:00:00 2001 From: Thomas Bloor Date: Fri, 6 Apr 2018 14:58:36 +0100 Subject: [PATCH 06/11] PERL-793 Added comment about unac writes and causal consistency --- lib/MongoDB/ClientSession.pm | 1 + 1 file changed, 1 insertion(+) diff --git a/lib/MongoDB/ClientSession.pm b/lib/MongoDB/ClientSession.pm index 1cad2559..44ee0a8c 100644 --- a/lib/MongoDB/ClientSession.pm +++ b/lib/MongoDB/ClientSession.pm @@ -70,6 +70,7 @@ Options provided for this particular session. Available options include: * C - If true, will enable causalConsistency for this session. For more information, see L. + Note that causalConsistency does not apply for unacknowledged writes. Defaults to true. From ecc08c1053ac08d1f1416c6bd8e78fcc1cfdf2f1 Mon Sep 17 00:00:00 2001 From: Thomas Bloor Date: Thu, 17 May 2018 15:27:04 +0100 Subject: [PATCH 07/11] PERL-793 Fix typo in ClientSession --- lib/MongoDB/ClientSession.pm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lib/MongoDB/ClientSession.pm b/lib/MongoDB/ClientSession.pm index 44ee0a8c..f31ed46c 100644 --- a/lib/MongoDB/ClientSession.pm +++ b/lib/MongoDB/ClientSession.pm @@ -196,7 +196,7 @@ recent than the sessions current operation time, then the session will be updated to this provided value. Setting C with a manually crafted value may cause a server -error. It is reccomended to only use an C retreived from +error. It is recommended to only use an C retreived from another session or directly from a database call. =cut From 4df3edcf5177448bb14574fa3653f486316ce731 Mon Sep 17 00:00:00 2001 From: Thomas Bloor Date: Thu, 17 May 2018 17:39:05 +0100 Subject: [PATCH 08/11] PERL-793 Refactor repetitive code in tests --- devel/t-dynamic/PERL-793-causal_consistency.t | 275 ++++++------------ 1 file changed, 91 insertions(+), 184 deletions(-) diff --git a/devel/t-dynamic/PERL-793-causal_consistency.t b/devel/t-dynamic/PERL-793-causal_consistency.t index 255a3521..5b7e32bb 100644 --- a/devel/t-dynamic/PERL-793-causal_consistency.t +++ b/devel/t-dynamic/PERL-793-causal_consistency.t @@ -133,74 +133,34 @@ subtest 'find_one then read includes operationtime' => sub { # * count # * distinct - subtest 'find' => sub { - my $session = find_one_and_get_session(); - my $op_time = $session->operation_time; - - $coll->find({ _id => 1 }, { session => $session })->result; - - my $command = Test::Role::BSONDebug::GET_LAST_ENCODE_ONE; - - is $op_time, $command->FETCH('readConcern')->{afterClusterTime}, 'has correct afterClusterTime'; - }; - - subtest 'find_one' => sub { - my $session = find_one_and_get_session(); - my $op_time = $session->operation_time; - - $coll->find_one({ _id => 1 }, {}, { session => $session }); - - my $command = Test::Role::BSONDebug::GET_LAST_ENCODE_ONE; - - is $op_time, $command->FETCH('readConcern')->{afterClusterTime}, 'has correct afterClusterTime'; - }; - - subtest 'find_id' => sub { - my $session = find_one_and_get_session(); - my $op_time = $session->operation_time; - - $coll->find_id(1, {}, { session => $session }); - - my $command = Test::Role::BSONDebug::GET_LAST_ENCODE_ONE; - - is $op_time, $command->FETCH('readConcern')->{afterClusterTime}, 'has correct afterClusterTime'; - }; - - - subtest 'aggregate' => sub { - my $session = find_one_and_get_session(); - my $op_time = $session->operation_time; - - $coll->aggregate([ { '$match' => { count => { '$gt' => 0 } } } ], { session => $session }); - - my $command = Test::Role::BSONDebug::GET_LAST_ENCODE_ONE; - - is $op_time, $command->FETCH('readConcern')->{afterClusterTime}, 'has correct afterClusterTime'; - }; - - - subtest 'count' => sub { - my $session = find_one_and_get_session(); - my $op_time = $session->operation_time; - - $coll->count({ _id => 1 }, { session => $session }); - - my $command = Test::Role::BSONDebug::GET_LAST_ENCODE_ONE; - - is $op_time, $command->FETCH('readConcern')->{afterClusterTime}, 'has correct afterClusterTime'; + my $tests = { + find => [ {_id => 1 } ], + find_one => [ { _id => 1 }, {} ], + find_id => [ 1, {} ], + aggregate => [ [ { '$match' => { count => { '$gt' => 0 } } } ] ], + count => [ { _id => 1 } ], + distinct => [ "id_", { _id => 1 } ], }; + for my $key ( qw/ + find + find_one + find_id + aggregate + count + distinct / ) { + subtest $key => sub { + my $session = find_one_and_get_session(); + my $op_time = $session->operation_time; - subtest 'distinct' => sub { - my $session = find_one_and_get_session(); - my $op_time = $session->operation_time; - - $coll->distinct("id_", { _id => 1 }, { session => $session }); + my $ret = $coll->$key(@{ $tests->{$key} }, { session => $session }); + if ( $key eq 'find' ) { $ret->result } - my $command = Test::Role::BSONDebug::GET_LAST_ENCODE_ONE; + my $command = Test::Role::BSONDebug::GET_LAST_ENCODE_ONE; - is $op_time, $command->FETCH('readConcern')->{afterClusterTime}, 'has correct afterClusterTime'; - }; + is $op_time, $command->FETCH('readConcern')->{afterClusterTime}, 'has correct afterClusterTime'; + }; + } }; sub find_one_and_get_session { @@ -230,137 +190,84 @@ subtest 'write then find_one includes operationTime' => sub { # * ordered_bulk # * unordered_bulk - subtest 'insert_one' => sub { - my $session = $conn->start_session({ causalConsistency => 1 }); - - $coll->insert_one({ _id => 100 }, { session => $session }); - - find_one_and_assert( $session ); - - $session->end_session; - - $session = $conn->start_session({ causalConsistency => 1 }); - - my $err = exception { $coll->insert_one({ _id => 100 }, { session => $session }) }; - isa_ok( $err, 'MongoDB::DatabaseError' ); - - find_one_and_assert( $session ); + # Undef exceptions are only due to not knowing how to cause one + my $tests = { + insert_one => { + success => [ { _id => 100 } ], + exception => [ { _id => 100 } ], + }, + insert_many => { + success => [ [ map { { _id => $_ } } 101..111 ] ], + exception => [ [ map { { _id => $_ } } 101..111 ] ], + }, + delete_one => { + success => [ { _id => 100 } ], + exception => undef, + }, + delete_many => { + success => [ { _id => { '$in' => [101,102] } } ], + exception => undef, + }, + replace_one => { + success => [ { _id => 103 }, { _id => 103, foo => 'qux' } ], + exception => undef, + }, + update_one => { + success => [ { _id => 104 }, { '$set' => { bar => 'baz' } } ], + exception => undef, + }, + update_many => { + success => [ { _id => { '$in' => [105,106] } }, { '$set' => { bar => 'baz' } } ], + exception => undef, + }, + find_one_and_delete => { + success => [ { _id => 107 } ], + exception => undef, + }, + find_one_and_replace => { + success => [ { _id => 108 }, { _id => 108, bar => 'baz' } ], + exception => undef, + }, + find_one_and_update => { + success => [ { _id => 109 }, { '$set' => { foo => 'qux' } } ], + exception => undef, + }, }; - subtest 'insert_many' => sub { - my $session = $conn->start_session({ causalConsistency => 1 }); + # Order of these actually matters - the insert_one and insert_many must go first + for my $key ( qw/ + insert_one + insert_many + delete_one + delete_many + replace_one + update_one + update_many + find_one_and_delete + find_one_and_replace + find_one_and_update / ) { + subtest $key => sub { + my $session = $conn->start_session({ causalConsistency => 1 }); - $coll->insert_many( [ - { _id => 101 }, - { _id => 102 }, - { _id => 103 }, - { _id => 104 }, - { _id => 105 }, - { _id => 106 }, - { _id => 107 }, - { _id => 108 }, - { _id => 109 }, - { _id => 110 }, - { _id => 111 }, - ], { session => $session }); + $coll->$key( @{ $tests->{ $key }->{ success } }, { session => $session }); - find_one_and_assert( $session ); + find_one_and_assert( $session ); - $session->end_session; + return unless defined $tests->{ $key }->{ exception }; - $session = $conn->start_session({ causalConsistency => 1 }); + $session->end_session; - my $err = exception { - $coll->insert_many( [ - { _id => 101 }, - { _id => 102 }, - { _id => 103 }, - { _id => 104 }, - { _id => 105 }, - { _id => 106 }, - { _id => 107 }, - { _id => 108 }, - { _id => 109 }, - { _id => 110 }, - { _id => 111 }, - ], { session => $session }) - }; - isa_ok( $err, 'MongoDB::DatabaseError' ); + $session = $conn->start_session({ causalConsistency => 1 }); - find_one_and_assert( $session ); - }; + my $err = exception { + $coll->$key( @{ $tests->{ $key }->{ exception } }, { session => $session }) + }; - subtest 'delete_one' => sub { - my $session = $conn->start_session({ causalConsistency => 1 }); - - $coll->delete_one({ _id => 100 }, { session => $session }); - - find_one_and_assert( $session ); - # dont think theres a way to make delete exception? - }; - - subtest 'delete_many' => sub { - my $session = $conn->start_session({ causalConsistency => 1 }); - - $coll->delete_many({ _id => { '$in' => [101,102] } }, { session => $session }); - - find_one_and_assert( $session ); - # dont think theres a way to make delete exception? - }; - - subtest 'replace_one' => sub { - my $session = $conn->start_session({ causalConsistency => 1 }); - - $coll->replace_one({ _id => 103 }, { _id => 103, foo => 'qux' }, { session => $session }); - - find_one_and_assert( $session ); - # cant figure way to cause error? - }; - - subtest 'update_one' => sub { - my $session = $conn->start_session({ causalConsistency => 1 }); - - $coll->update_one({ _id => 104 }, { '$set' => { bar => 'baz' } }, { session => $session }); - - find_one_and_assert( $session ); - # cant figure way to cause error? - }; + isa_ok( $err, 'MongoDB::DatabaseError' ); - subtest 'update_many' => sub { - my $session = $conn->start_session({ causalConsistency => 1 }); - - $coll->update_many({ _id => { '$in' => [105,106] } }, { '$set' => { bar => 'baz' } }, { session => $session }); - - find_one_and_assert( $session ); - # cant figure way to cause error? - }; - - subtest 'find_one_and_delete' => sub { - my $session = $conn->start_session({ causalConsistency => 1 }); - - $coll->find_one_and_delete({ _id => 107 }, { session => $session }); - - find_one_and_assert( $session ); - # cant figure way to cause error? - }; - - subtest 'find_one_and_replace' => sub { - my $session = $conn->start_session({ causalConsistency => 1 }); - - $coll->find_one_and_replace({ _id => 108 }, { _id => 108, bar => 'baz' }, { session => $session }); - - find_one_and_assert( $session ); - # cant figure way to cause error? - }; - - subtest 'find_one_and_update' => sub { - my $session = $conn->start_session({ causalConsistency => 1 }); - - $coll->find_one_and_update({ _id => 109 }, { '$set' => { foo => 'qux' } }, { session => $session }); - - find_one_and_assert( $session ); - # cant figure way to cause error? - }; + find_one_and_assert( $session ); + }; + } subtest 'ordered_bulk' => sub { my $session = $conn->start_session({ causalConsistency => 1 }); From 442d0078db23f065742f422925f37c7a620ca688 Mon Sep 17 00:00:00 2001 From: Thomas Bloor Date: Thu, 17 May 2018 17:47:20 +0100 Subject: [PATCH 09/11] PERL-793 Move test into normal testing dir --- .../PERL-793-causal_consistency.t | 17 +++-------------- 1 file changed, 3 insertions(+), 14 deletions(-) rename {devel/t-dynamic => t}/PERL-793-causal_consistency.t (97%) diff --git a/devel/t-dynamic/PERL-793-causal_consistency.t b/t/PERL-793-causal_consistency.t similarity index 97% rename from devel/t-dynamic/PERL-793-causal_consistency.t rename to t/PERL-793-causal_consistency.t index 5b7e32bb..591418e8 100644 --- a/devel/t-dynamic/PERL-793-causal_consistency.t +++ b/t/PERL-793-causal_consistency.t @@ -28,11 +28,6 @@ use MongoDB; use MongoDB::Error; use lib "t/lib"; -use lib "devel/lib"; - -use if $ENV{MONGOVERBOSE}, qw/Log::Any::Adapter Stderr/; - -use MongoDBTest::Orchestrator; use MongoDBTest qw/ build_client @@ -48,15 +43,6 @@ Role::Tiny->apply_roles_to_package( 'MongoDB::BSON', 'Test::Role::BSONDebug', ); -my $orc = -MongoDBTest::Orchestrator->new( - config_file => "devel/config/replicaset-single-3.6.yml" ); -$orc->start; - -$ENV{MONGOD} = $orc->as_uri; - -print $ENV{MONGOD}; - my $conn = build_client(); my $testdb = get_test_db($conn); my $server_version = server_version($conn); @@ -66,6 +52,9 @@ my $coll = $testdb->get_collection('test_collection'); plan skip_all => "Requires MongoDB 3.6" if $server_version < v3.6.0; +plan skip_all => "Causal Consistency unsupported on standalone servers" + if $server_type eq 'Standalone'; + Test::Role::BSONDebug::CLEAR_ENCODE_ONE_QUEUE; Test::Role::BSONDebug::CLEAR_DECODE_ONE_QUEUE; From 1d42d61ec9b5b1f727429842e3a22df922c96214 Mon Sep 17 00:00:00 2001 From: Thomas Bloor Date: Mon, 21 May 2018 16:09:09 +0100 Subject: [PATCH 10/11] PERL-793 Refactor to use monitoring callback for testing --- t/PERL-793-causal_consistency.t | 72 ++++++++++++++++----------------- t/lib/Test/Role/BSONDebug.pm | 43 -------------------- 2 files changed, 34 insertions(+), 81 deletions(-) delete mode 100644 t/lib/Test/Role/BSONDebug.pm diff --git a/t/PERL-793-causal_consistency.t b/t/PERL-793-causal_consistency.t index 591418e8..915d5fa2 100644 --- a/t/PERL-793-causal_consistency.t +++ b/t/PERL-793-causal_consistency.t @@ -38,12 +38,15 @@ use MongoDBTest qw/ get_unique_collection /; -use Test::Role::BSONDebug; -Role::Tiny->apply_roles_to_package( - 'MongoDB::BSON', 'Test::Role::BSONDebug', -); +my @events; + +sub clear_events { @events = () } +sub event_count { scalar @events } +sub event_cb { push @events, $_[0] } -my $conn = build_client(); +my $conn = build_client( + monitoring_callback => \&event_cb, +); my $testdb = get_test_db($conn); my $server_version = server_version($conn); my $server_type = server_type($conn); @@ -55,17 +58,13 @@ plan skip_all => "Requires MongoDB 3.6" plan skip_all => "Causal Consistency unsupported on standalone servers" if $server_type eq 'Standalone'; -Test::Role::BSONDebug::CLEAR_ENCODE_ONE_QUEUE; -Test::Role::BSONDebug::CLEAR_DECODE_ONE_QUEUE; - # spec test 1 subtest 'session operation_time undef on init' => sub { my $session = $conn->start_session; is $session->operation_time, undef, 'is undef'; }; -Test::Role::BSONDebug::CLEAR_ENCODE_ONE_QUEUE; -Test::Role::BSONDebug::CLEAR_DECODE_ONE_QUEUE; +clear_events(); # spec test 2 subtest 'first read' => sub { @@ -73,13 +72,12 @@ subtest 'first read' => sub { my $response = $coll->find_one({ _id => 1 }, {}, { session => $session }); - my $command = Test::Role::BSONDebug::GET_LAST_ENCODE_ONE; + my $event = $events[-2]; - ok ! $command->EXISTS( 'afterClusterTime' ), 'afterClusterTime not sent on first read'; + ok ! exists $event->{ command }->{ 'afterClusterTime' }, 'afterClusterTime not sent on first read'; }; -Test::Role::BSONDebug::CLEAR_ENCODE_ONE_QUEUE; -Test::Role::BSONDebug::CLEAR_DECODE_ONE_QUEUE; +clear_events(); # spec test 3 subtest 'update operation_time' => sub { @@ -89,9 +87,10 @@ subtest 'update operation_time' => sub { my $response = $coll->insert_one({ _id => 1 }, { session => $session }); - my $bson = Test::Role::BSONDebug::GET_LAST_DECODE_ONE; + my $event = $events[-1]; - is $session->operation_time, $bson->{operationTime}, 'response has operation time and is updated in session'; + # for some reason 'is' wont do the comparison correctly... + ok $session->operation_time == $event->{reply}->{operationTime}, 'response has operation time and is updated in session'; $session->end_session; @@ -104,13 +103,12 @@ subtest 'update operation_time' => sub { isa_ok( $err, 'MongoDB::DatabaseError', "duplicate insert error" ); - my $error_bson = Test::Role::BSONDebug::GET_LAST_DECODE_ONE; + my $err_event = $events[-1]; - is $session->operation_time, $error_bson->{operationTime}, 'response has operation time and is updated in session'; + ok $session->operation_time == $err_event->{reply}->{operationTime}, 'response has operation time and is updated in session'; }; -Test::Role::BSONDebug::CLEAR_ENCODE_ONE_QUEUE; -Test::Role::BSONDebug::CLEAR_DECODE_ONE_QUEUE; +clear_events(); # spec test 4 subtest 'find_one then read includes operationtime' => sub { @@ -138,6 +136,7 @@ subtest 'find_one then read includes operationtime' => sub { aggregate count distinct / ) { + clear_events(); subtest $key => sub { my $session = find_one_and_get_session(); my $op_time = $session->operation_time; @@ -145,9 +144,9 @@ subtest 'find_one then read includes operationtime' => sub { my $ret = $coll->$key(@{ $tests->{$key} }, { session => $session }); if ( $key eq 'find' ) { $ret->result } - my $command = Test::Role::BSONDebug::GET_LAST_ENCODE_ONE; + my $event = $events[-2]; - is $op_time, $command->FETCH('readConcern')->{afterClusterTime}, 'has correct afterClusterTime'; + is $op_time, $event->{command}->{'readConcern'}->{afterClusterTime}, 'has correct afterClusterTime'; }; } }; @@ -160,8 +159,7 @@ sub find_one_and_get_session { return $session; } -Test::Role::BSONDebug::CLEAR_ENCODE_ONE_QUEUE; -Test::Role::BSONDebug::CLEAR_DECODE_ONE_QUEUE; +clear_events(); # spec test 5 subtest 'write then find_one includes operationTime' => sub { @@ -235,6 +233,7 @@ subtest 'write then find_one includes operationTime' => sub { find_one_and_delete find_one_and_replace find_one_and_update / ) { + clear_events(); subtest $key => sub { my $session = $conn->start_session({ causalConsistency => 1 }); @@ -317,13 +316,12 @@ sub find_one_and_assert { $coll->find_one({ _id => 1 }, {}, { session => $session }); - my $command = Test::Role::BSONDebug::GET_LAST_ENCODE_ONE; + my $event = $events[-2]; - is $op_time, $command->FETCH('readConcern')->{afterClusterTime}, 'has correct afterClusterTime'; + is $op_time, $event->{command}->{'readConcern'}->{afterClusterTime}, 'has correct afterClusterTime'; } -Test::Role::BSONDebug::CLEAR_ENCODE_ONE_QUEUE; -Test::Role::BSONDebug::CLEAR_DECODE_ONE_QUEUE; +clear_events(); # spec test 6 subtest 'turn off causalConsistency' => sub { @@ -333,13 +331,12 @@ subtest 'turn off causalConsistency' => sub { $coll->find_one({ _id => 1 }, {}, { session => $session }); - my $command = Test::Role::BSONDebug::GET_LAST_ENCODE_ONE; + my $event = $events[-2]; - ok ! $command->EXISTS('readConcern'), 'no readconcern, so no afterClusterTime'; + ok ! exists $event->{command}->{'readConcern'}, 'no readconcern, so no afterClusterTime'; }; -Test::Role::BSONDebug::CLEAR_ENCODE_ONE_QUEUE; -Test::Role::BSONDebug::CLEAR_DECODE_ONE_QUEUE; +clear_events(); # spec test 8 subtest 'using default readConcern' => sub { @@ -352,13 +349,12 @@ subtest 'using default readConcern' => sub { $coll->find_one({ _id => 1 }, {}, { session => $session }); - my $command = Test::Role::BSONDebug::GET_LAST_ENCODE_ONE; + my $event = $events[-2]; - ok ! defined $command->FETCH('readConcern')->{level}, 'no read concern level with default value'; + ok ! defined $event->{command}->{'readConcern'}->{level}, 'no read concern level with default value'; }; -Test::Role::BSONDebug::CLEAR_ENCODE_ONE_QUEUE; -Test::Role::BSONDebug::CLEAR_DECODE_ONE_QUEUE; +clear_events(); # spec test 9 subtest 'using custom readConcern' => sub { @@ -372,9 +368,9 @@ subtest 'using custom readConcern' => sub { $custom_coll->find_one({ _id => 1 }, {}, { session => $session }); - my $command = Test::Role::BSONDebug::GET_LAST_ENCODE_ONE; + my $event = $events[-2]; - my $read_concern = $command->FETCH('readConcern'); + my $read_concern = $event->{command}->{'readConcern'}; is $read_concern->{level}, 'local', 'read concern level with custom value'; is $read_concern->{afterClusterTime}, $op_time, 'read concern afterClusterTime present'; diff --git a/t/lib/Test/Role/BSONDebug.pm b/t/lib/Test/Role/BSONDebug.pm deleted file mode 100644 index d651203e..00000000 --- a/t/lib/Test/Role/BSONDebug.pm +++ /dev/null @@ -1,43 +0,0 @@ -package Test::Role::BSONDebug; - -use Moo::Role; - -our @ENCODE_ONE_QUEUE; -our @DECODE_ONE_QUEUE; - -around encode_one => sub { - my $orig = shift; - - my $cmd = $_[1]; - my $ret = $orig->(@_); - - push @ENCODE_ONE_QUEUE, $cmd; - return $ret; -}; - -around decode_one => sub { - my $orig = shift; - - my $ret = $orig->(@_); - - push @DECODE_ONE_QUEUE, $ret; - return $ret; -}; - -sub GET_LAST_ENCODE_ONE { - return pop @ENCODE_ONE_QUEUE; -} - -sub GET_LAST_DECODE_ONE { - return pop @DECODE_ONE_QUEUE; -} - -sub CLEAR_ENCODE_ONE_QUEUE { - @ENCODE_ONE_QUEUE = (); -} - -sub CLEAR_DECODE_ONE_QUEUE { - @DECODE_ONE_QUEUE = (); -} - -1; From f9c8ee49df354260b67b17c65068bedd0fcc2a5c Mon Sep 17 00:00:00 2001 From: Thomas Bloor Date: Mon, 21 May 2018 16:09:55 +0100 Subject: [PATCH 11/11] PERL-793 remove ticket name from test --- t/{PERL-793-causal_consistency.t => causal_consistency.t} | 0 1 file changed, 0 insertions(+), 0 deletions(-) rename t/{PERL-793-causal_consistency.t => causal_consistency.t} (100%) diff --git a/t/PERL-793-causal_consistency.t b/t/causal_consistency.t similarity index 100% rename from t/PERL-793-causal_consistency.t rename to t/causal_consistency.t