File Coverage

blib/lib/MongoDB/Role/_CommandMonitoring.pm
Criterion Covered Total %
statement 33 123 26.8
branch 0 40 0.0
condition n/a
subroutine 11 24 45.8
pod 0 6 0.0
total 44 193 22.8


line stmt bran cond sub pod time code
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              
15 60     60   74355 use strict;
  60         132  
  60         1736  
16 60     60   305 use warnings;
  60         110  
  60         2222  
17              
18             package MongoDB::Role::_CommandMonitoring;
19              
20             # MongoDB role to add command monitoring support to Ops
21              
22 60     60   296 use version;
  60         115  
  60         384  
23             our $VERSION = 'v2.2.2';
24              
25 60     60   4193 use Moo::Role;
  60         120  
  60         347  
26 60     60   48848 use BSON;
  60         7499876  
  60         3464  
27 60     60   524 use BSON::Raw;
  60         123  
  60         1652  
28 60     60   326 use MongoDB::_Types -types, 'to_IxHash';
  60         137  
  60         590  
29 60     60   292666 use Tie::IxHash;
  60         139  
  60         1632  
30 60     60   313 use Safe::Isa;
  60         137  
  60         8296  
31 60     60   390 use Time::HiRes qw/time/;
  60         124  
  60         533  
32 60     60   5599 use namespace::clean;
  60         149  
  60         537  
33              
34             requires qw/monitoring_callback db_name/;
35             has command_start_time => ( is => 'rw', );
36             has command_start_event => ( is => 'rw', );
37              
38             sub publish_command_started {
39 0     0 0   my ( $self, $link, $command, $request_id ) = @_;
40 0 0         return unless $self->monitoring_callback;
41              
42 0 0         if ( $command->$_can('_as_tied_hash') ) {
43 0           $command = $command->_as_tied_hash;
44             } else {
45 0           $command = _to_tied_ixhash($command);
46             }
47 0           my $command_name = tied(%$command)->Keys(0);
48              
49 0 0         my $event = {
50             type => 'command_started',
51             databaseName => $self->db_name,
52             commandName => $command_name,
53             command => (
54             _needs_redaction($command_name)
55             ? _to_tied_ixhash([])
56             : $command,
57             ),
58             requestId => $request_id,
59             connectionId => $link->address,
60             };
61              
62             # Cache for constructing matching succeeded/failed event later
63 0           $self->command_start_event($event);
64              
65             # Guard against exceptions in the callback
66 0           eval { $self->monitoring_callback->($event) };
  0            
67              
68             # Set the time last so it doesn't include all the work above
69 0           $self->command_start_time(time);
70 0           return;
71             }
72              
73             sub publish_command_reply {
74 0     0 0   my ( $self, $bson ) = @_;
75 0 0         return unless $self->monitoring_callback;
76              
77             # Record duration early before doing work to prepare success/fail
78             # events
79 0           my $duration = time - $self->command_start_time();
80              
81 0           my $start_event = $self->command_start_event();
82              
83 0 0         my $reply =
84             ref($bson) eq 'HASH'
85             ? $bson
86             : BSON->new()->decode_one($bson);
87              
88             my $event = {
89             databaseName => $start_event->{databaseName},
90             commandName => $start_event->{commandName},
91             requestId => $start_event->{requestId},
92             connectionId => $start_event->{connectionId},
93             durationSecs => $duration,
94             reply => (
95             _needs_redaction($start_event->{commandName})
96 0 0         ? {}
97             : $reply,
98             ),
99             };
100              
101 0 0         if ( $reply->{ok} ) {
102 0           $event->{type} = 'command_succeeded';
103             }
104             else {
105 0           $event->{type} = 'command_failed';
106 0           $event->{failure} = _extract_errmsg($reply);
107             }
108              
109             # Guard against exceptions in the callback
110 0           eval { $self->monitoring_callback->($event) };
  0            
111              
112 0           return;
113             }
114              
115             sub publish_command_exception {
116 0     0 0   my ($self, $err) = @_;
117 0 0         return unless $self->monitoring_callback;
118              
119             # Record duration early before doing work to prepare success/fail
120             # events
121 0           my $duration = time - $self->command_start_time();
122              
123 0           my $start_event = $self->command_start_event();
124              
125             my $event = {
126             type => "command_failed",
127             databaseName => $start_event->{databaseName},
128             commandName => $start_event->{commandName},
129             requestId => $start_event->{requestId},
130             connectionId => $start_event->{connectionId},
131 0           durationSecs => $duration,
132             reply => {},
133             failure => "$err",
134             eval_error => $err,
135             };
136              
137             # Guard against exceptions in the callback
138 0           eval { $self->monitoring_callback->($event) };
  0            
139              
140 0           return;
141             }
142              
143             sub publish_legacy_write_started {
144 0     0 0   my ( $self, $link, $cmd_name, $op_doc, $request_id ) = @_;
145 0           my $method = "_convert_legacy_$cmd_name";
146 0           return $self->publish_command_started( $link, $self->$method($op_doc), $request_id );
147             }
148              
149             sub publish_legacy_reply_succeeded {
150 0     0 0   my ($self, $result) = @_;
151 0 0         my $batchfield = ref($self) eq "MongoDB::Op::_Query" ? "firstBatch" : "nextBatch";
152              
153             my $reply = {
154             ok => 1,
155             cursor => {
156             id => $result->{cursor_id},
157             ns => $self->full_name,
158 0           $batchfield => [ @{$result->{docs}} ],
  0            
159             },
160             };
161              
162 0           return $self->publish_command_reply($reply);
163             }
164              
165             sub publish_legacy_query_error {
166 0     0 0   my ($self, $result) = @_;
167              
168 0           my $reply = {
169             %$result,
170             ok => 0,
171             };
172              
173 0           return $self->publish_command_reply($reply);
174             }
175              
176             sub _needs_redaction {
177 0     0     my ($name) = @_;
178 0 0         return 1 if grep { $name eq $_ } qw(
  0            
179             authenticate
180             saslStart
181             saslContinue
182             getnonce
183             createUser
184             updateUser
185             copydbgetnonce
186             copydbsaslstart
187             copydb
188             );
189 0           return 0;
190             }
191              
192             sub _convert_legacy_insert {
193 0     0     my ( $self, $op_doc ) = @_;
194 0 0         $op_doc = [$op_doc] unless ref $op_doc eq 'ARRAY';
195             return [
196             insert => $self->coll_name,
197             documents => $op_doc,
198 0           @{ $self->write_concern->as_args },
  0            
199             ];
200             }
201              
202             # Duplicated from MongoDB::CommandResult
203             sub _extract_errmsg {
204 0     0     my ($output) = @_;
205 0           for my $err_key (qw/$err err errmsg/) {
206 0 0         return $output->{$err_key} if exists $output->{$err_key};
207             }
208 0 0         if ( exists $output->{writeConcernError} ) {
209 0           return $output->{writeConcernError}{errmsg};
210             }
211 0           return "";
212             }
213              
214             sub _convert_legacy_update {
215 0     0     my ( $self, $op_doc ) = @_;
216              
217             return [
218             update => $self->coll_name,
219             updates => [
220             update => $self->coll_name,
221             updates => [$op_doc],
222             ],
223 0           @{ $self->write_concern->as_args },
  0            
224             ];
225             }
226              
227             sub _convert_legacy_delete {
228 0     0     my ( $self, $op_doc ) = @_;
229              
230             return [
231             delete => $self->coll_name,
232             deletes => [$op_doc],
233 0           @{ $self->write_concern->as_args },
  0            
234             ];
235             }
236              
237             sub _decode_preencoded {
238 0     0     my ($obj) = @_;
239 0           my $codec = BSON->new;
240 0           my $type = ref($obj);
241 0 0         if ( $type eq 'BSON::Raw' ) {
    0          
    0          
    0          
242 0           return $codec->decode_one( $obj->{bson} );
243             }
244             elsif ( $type eq 'Tie::IxHash' ) {
245 0           tie my %out, "Tie::IxHash";
246 0           $out{$_} = _decode_preencoded( $obj->FETCH($_) ) for $obj->Keys;
247 0           return \%out;
248             }
249             elsif ( $type eq 'ARRAY' ) {
250 0           return [ map { _decode_preencoded($_) } @$obj ];
  0            
251             }
252             elsif ( $type eq 'HASH' ) {
253 0           return { map { ; $_ => _decode_preencoded( $obj->{$_} ) } keys %$obj };
  0            
254             }
255 0           return $obj;
256             }
257              
258             sub _to_tied_ixhash {
259 0     0     my ($in) = @_;
260 0           my $type = ref($in);
261 0           my %out;
262 0 0         if ( $type eq 'ARRAY' ) {
    0          
    0          
263             # earlier type checks should ensure even elements
264 0           tie %out, "Tie::IxHash", map { _decode_preencoded($_) } @$in;
  0            
265             }
266             elsif ( $type eq "Tie::IxHash" ) {
267 0           tie %out, "Tie::IxHash";
268 0           $out{$_} = _decode_preencoded( $in->FETCH($_) ) for $in->Keys;
269             }
270             elsif ( $in->$_can('_as_tied_hash') ) {
271 0           %out = %{ $in->_as_tied_hash() };
  0            
272             } else {
273 0           tie %out, "Tie::IxHash", map { ; $_ => _decode_preencoded( $in->{$_} ) } keys %$in;
  0            
274             }
275 0           return \%out;
276             }
277              
278             1;