File Coverage

blib/lib/POE/Component/Metabase/Relay/Server.pm
Criterion Covered Total %
statement 89 128 69.5
branch 5 26 19.2
condition 2 12 16.6
subroutine 25 30 83.3
pod 1 2 50.0
total 122 198 61.6


line stmt bran cond sub pod time code
1             package POE::Component::Metabase::Relay::Server;
2             # ABSTRACT: A Metabase relay server component
3             $POE::Component::Metabase::Relay::Server::VERSION = '0.36';
4 1     1   86893 use strict;
  1         2  
  1         26  
5 1     1   3 use warnings;
  1         2  
  1         26  
6 1     1   349 use CPAN::Testers::Report;
  1         29630  
  1         28  
7 1     1   7 use POE qw[Filter::Stream];
  1         1  
  1         10  
8 1     1   2047 use POE::Component::Metabase::Relay::Server::Queue;
  1         3  
  1         54  
9 1     1   647 use Test::POE::Server::TCP;
  1         3665  
  1         22  
10 1     1   5 use Carp ();
  1         1  
  1         11  
11 1     1   3 use Storable ();
  1         1  
  1         10  
12 1     1   3 use Socket ();
  1         2  
  1         10  
13 1     1   3 use JSON ();
  1         2  
  1         10  
14 1     1   4 use Metabase::User::Profile ();
  1         0  
  1         9  
15 1     1   4 use Metabase::User::Secret ();
  1         1  
  1         23  
16              
17             my @fields = qw(
18             osversion
19             distfile
20             archname
21             textreport
22             osname
23             perl_version
24             grade
25             );
26              
27 1     1   4 use MooseX::POE;
  1         2  
  1         8  
28 1     1   7793 use MooseX::Types::Path::Class qw[File];
  1         2  
  1         11  
29 1     1   779 use MooseX::Types::URI qw[Uri];
  1         2  
  1         10  
30              
31             {
32 1     1   1129 use Moose::Util::TypeConstraints;
  1         2  
  1         7  
33             my $tc = subtype as 'ArrayRef[Str]';
34             coerce $tc, from 'Str', via { [$_] };
35              
36             has 'address' => (
37             is => 'ro',
38             isa => $tc,
39             default => 0,
40             coerce => 1,
41             );
42              
43             my $ps = subtype as 'Str', where { $poe_kernel->alias_resolve( $_ ) };
44             coerce $ps, from 'Str', via { $poe_kernel->alias_resolve( $_ )->ID };
45              
46             has 'session' => (
47             is => 'ro',
48             isa => $ps,
49             coerce => 1,
50             writer => '_set_session',
51             );
52              
53 1     1   1333 no Moose::Util::TypeConstraints;
  1         2  
  1         5  
54             }
55              
56             has 'port' => (
57             is => 'ro',
58             default => sub { 0 },
59             writer => '_set_port',
60             );
61              
62             has 'id_file' => (
63             is => 'ro',
64             required => 1,
65             isa => File,
66             coerce => 1,
67             );
68              
69             has 'dsn' => (
70             is => 'ro',
71             isa => 'Str',
72             required => 1,
73             );
74              
75             has 'uri' => (
76             is => 'ro',
77             isa => Uri,
78             coerce => 1,
79             required => 1,
80             );
81              
82             has 'username' => (
83             is => 'ro',
84             isa => 'Str',
85             default => '',
86             );
87              
88             has 'password' => (
89             is => 'ro',
90             isa => 'Str',
91             default => '',
92             );
93              
94             has 'db_opts' => (
95             is => 'ro',
96             isa => 'HashRef',
97             default => sub {{}},
98             );
99              
100             has 'debug' => (
101             is => 'rw',
102             isa => 'Bool',
103             default => 0,
104             );
105              
106             has 'multiple' => (
107             is => 'ro',
108             isa => 'Bool',
109             default => 0,
110             );
111              
112             has 'recv_event' => (
113             is => 'ro',
114             isa => 'Str',
115             );
116              
117             has 'no_relay' => (
118             is => 'rw',
119             isa => 'Bool',
120             default => 0,
121             trigger => sub {
122             my( $self, $new, $old ) = @_;
123             return if ! $self->_has_queue;
124             $self->queue->no_relay( $new );
125             },
126             );
127              
128             has 'no_curl' => (
129             is => 'ro',
130             isa => 'Bool',
131             default => 0,
132             );
133              
134             has 'submissions' => (
135             is => 'rw',
136             isa => 'Int',
137             default => 10,
138             trigger => sub {
139             my( $self, $new, $old ) = @_;
140             return if ! $self->_has_queue;
141             $self->queue->submissions( $new );
142             },
143             );
144              
145             has '_profile' => (
146             is => 'ro',
147             isa => 'Metabase::User::Profile',
148             init_arg => undef,
149             writer => '_set_profile',
150             );
151              
152             has '_secret' => (
153             is => 'ro',
154             isa => 'Metabase::User::Secret',
155             init_arg => undef,
156             writer => '_set_secret',
157             );
158              
159             has '_relayd' => (
160             accessor => 'relayd',
161             isa => 'ArrayRef[Test::POE::Server::TCP]',
162             lazy_build => 1,
163             auto_deref => 1,
164             init_arg => undef,
165             );
166              
167             has '_queue' => (
168             accessor => 'queue',
169             isa => 'POE::Component::Metabase::Relay::Server::Queue',
170             lazy_build => 1,
171             init_arg => undef,
172             );
173              
174             has '_requests' => (
175             is => 'ro',
176             isa => 'HashRef',
177             default => sub {{}},
178             init_arg => undef,
179             );
180              
181             sub _build__relayd {
182 1     1   1 my $self = shift;
183             return [map {
184 1         30 Test::POE::Server::TCP->spawn(
185             address => $_,
186             port => $self->port,
187             prefix => 'relayd',
188             filter => POE::Filter::Stream->new(),
189             )
190 1         1 } @{ $self->address }]
  1         30  
191             }
192              
193             sub _build__queue {
194 1     1   1 my $self = shift;
195 1         35 POE::Component::Metabase::Relay::Server::Queue->spawn(
196             dsn => $self->dsn,
197             username => $self->username,
198             password => $self->password,
199             db_opts => $self->db_opts,
200             uri => $self->uri->as_string,
201             profile => $self->_profile,
202             secret => $self->_secret,
203             debug => $self->debug,
204             multiple => $self->multiple,
205             no_relay => $self->no_relay,
206             no_curl => $self->no_curl,
207             submissions => $self->submissions,
208             );
209             }
210              
211             sub spawn {
212 1     1 1 350 shift->new(@_);
213             }
214              
215             sub START {
216 1     1 0 1262 my ($kernel,$self,$sender) = @_[KERNEL,OBJECT,SENDER];
217 1 0 33     5 if ( $kernel == $sender and $self->recv_event and !$self->session ) {
      33        
218 0         0 Carp::croak "Not called from another POE session and 'session' wasn't set\n";
219             }
220 1 50       39 if ( $self->recv_event ) {
221 0 0       0 $self->_set_session( $sender->ID ) unless $self->session;
222             }
223 1         3 $self->_load_id_file;
224 1         38 $self->relayd;
225 1         36 $self->queue;
226 1         2 return;
227             }
228              
229              
230             event 'shutdown' => sub {
231 1     1   8814872 my ($kernel,$self) = @_[KERNEL,OBJECT];
232 1         92 $_->shutdown for $self->relayd;
233 1         885 $poe_kernel->post(
234             $self->queue->get_session_id,
235             'shutdown',
236             );
237 1         157 return;
238             };
239              
240             event 'relayd_registered' => sub {
241 1     1   141 my ($kernel,$self,$relayd) = @_[KERNEL,OBJECT,ARG0];
242 1         5 my ($port, $addr) = Socket::unpack_sockaddr_in($relayd->getsockname);
243              
244 1 50       54 if ($self->debug) {
245 0         0 my $hostname = scalar(gethostbyaddr($addr, Socket::AF_INET));
246              
247 0 0       0 if (defined($hostname)) {
248 0         0 warn "Listening on '", join(q{:} => $hostname, $port), "'\n";
249             } else {
250 0         0 my $dotted_num = Socket::inet_ntoa($addr);
251 0         0 warn "Listening on '", join(q{:} => $dotted_num, $port), "'\n";
252             }
253              
254             }
255              
256 1         5 $self->_set_port( $relayd->port );
257 1         3 return;
258             };
259              
260             event 'relayd_connected' => sub {
261 0     0   0 my ($kernel,$self,$id,$ip) = @_[KERNEL,OBJECT,ARG0,ARG1];
262 0         0 return;
263             };
264              
265             event 'relayd_disconnected' => sub {
266 0     0   0 my ($kernel,$self,$id,$ip) = @_[KERNEL,OBJECT,ARG0,ARG1];
267 0         0 my $data = delete $self->_requests->{$id};
268 0         0 my $report = eval { Storable::thaw($data); };
  0         0  
269 0 0 0     0 if ( defined $report and ref $report and ref $report eq 'HASH' ) {
      0        
270 0         0 $kernel->yield( 'process_report', $report, $ip );
271             }
272             else {
273 0 0       0 return unless $self->debug;
274 0         0 warn "Client '$id' failed to send parsable data!\n";
275 0         0 warn "The error from Storable::thaw was '$@'\n";
276             }
277 0         0 return;
278             };
279              
280             event 'relayd_client_input' => sub {
281 0     0   0 my ($kernel,$self,$id,$data) = @_[KERNEL,OBJECT,ARG0,ARG1];
282 0         0 $self->_requests->{$id} .= $data;
283 0         0 return;
284             };
285              
286             event 'process_report' => sub {
287 0     0   0 my ($kernel,$self,$data,$ip) = @_[KERNEL,OBJECT,ARG0,ARG1];
288 0         0 my @present = grep { defined $data->{$_} } @fields;
  0         0  
289 0 0       0 return unless scalar @present == scalar @fields;
290             # Build CPAN::Testers::Report with its various component facts.
291 0         0 my $metabase_report = eval { CPAN::Testers::Report->open(
292             resource => 'cpan:///distfile/' . $data->{distfile}
293 0         0 ); };
294              
295 0 0       0 return unless $metabase_report;
296              
297 0 0       0 $kernel->post( $self->session, $self->recv_event, $data, $ip )
298             if $self->recv_event;
299              
300             $metabase_report->add( 'CPAN::Testers::Fact::LegacyReport' => {
301 0         0 map { ( $_ => $data->{$_} ) } qw(grade osname osversion archname perl_version textreport)
  0         0  
302             });
303              
304             # TestSummary happens to be the same as content metadata
305             # of LegacyReport for now
306 0         0 $metabase_report->add( 'CPAN::Testers::Fact::TestSummary' =>
307             [$metabase_report->facts]->[0]->content_metadata()
308             );
309              
310 0         0 $metabase_report->close();
311              
312 0         0 $kernel->yield( 'submit_report', $metabase_report );
313 0         0 return;
314             };
315              
316             event 'submit_report' => sub {
317 0     0   0 my ($kernel,$self,$report) = @_[KERNEL,OBJECT,ARG0];
318 0         0 $kernel->post(
319             $self->queue->get_session_id,
320             'submit',
321             $report,
322             );
323 0         0 return;
324             };
325              
326             sub _load_id_file {
327 1     1   2 my $self = shift;
328              
329 1 50       34 open my $fh, '<', $self->id_file
330             or Carp::confess __PACKAGE__. ": could not read ID file '" . $self->id_file
331             . "'\n$!";
332              
333 1         97 my $data = JSON->new->decode( do { local $/; <$fh> } );
  1         3  
  1         51  
334              
335 1 50       6 my $profile = eval { Metabase::User::Profile->from_struct($data->[0]) }
  1         15  
336             or Carp::confess __PACKAGE__ . ": could not load Metabase profile\n"
337             . "from '" . $self->id_file . "':\n$@";
338              
339 1 50       3664 my $secret = eval { Metabase::User::Secret->from_struct($data->[1]) }
  1         17  
340             or Carp::confess __PACKAGE__ . ": could not load Metabase secret\n"
341             . "from '" . $self->id_file . "':\n $@";
342              
343 1         433 $self->_set_profile( $profile );
344 1         37 $self->_set_secret( $secret );
345 1         13 return 1;
346             }
347              
348 1     1   1269 no MooseX::POE;
  1         1  
  1         4  
349              
350             __PACKAGE__->meta->make_immutable;
351              
352             1;
353              
354             __END__
355              
356             =pod
357              
358             =encoding UTF-8
359              
360             =head1 NAME
361              
362             POE::Component::Metabase::Relay::Server - A Metabase relay server component
363              
364             =head1 VERSION
365              
366             version 0.36
367              
368             =head1 SYNOPSIS
369              
370             use strict;
371             use warnings;
372              
373             use POE qw[Component::Metabase::Relay::Server];
374              
375             my $test_httpd = POE::Component::Metabase::Relay::Server->spawn(
376             port => 8080,
377             id_file => shift,
378             dsn => 'dbi:SQLite:dbname=dbfile',
379             uri => 'https://metabase.example.foo/',
380             debug => 1,
381             );
382              
383             $poe_kernel->run();
384             exit 0;
385              
386             =head1 DESCRIPTION
387              
388             POE::Component::Metabase::Relay::Server is a relay server for L<Metabase>. It provides a listener
389             that accepts connections from L<Test::Reporter::Transport::Socket> based CPAN Testers and
390             relays the L<Storable> serialised data to L<Metabase> using L<POE::Component::Metabase::Client::Submit>.
391              
392             L<POE::Component::Client::HTTP> is used to submit reports usually, but if version C<0.06> of
393             L<POE::Component::Curl::Multi> is found to be installed, this will be used in preference. You can
394             disable this usage using the C<no_curl> option to C<spawn>.
395              
396             =head1 NAME
397              
398             POE::Component::Metabase::Relay::Server - A Metabase relay server component
399              
400             =head1 VERSION
401              
402             version 0.34
403              
404             =for Pod::Coverage START
405              
406             =head1 CONSTRUCTOR
407              
408             =over
409              
410             =item C<spawn>
411              
412             Spawns a new component session and creates a SQLite database if it doesn't already exist.
413              
414             Takes a number of mandatory parameters:
415              
416             'id_file', the file path of a Metabase ID file;
417             'dsn', a DBI DSN to use to store the submission queue;
418             'uri', the uri of metabase server to submit to;
419              
420             and a number of optional parameters:
421              
422             'address', the address to bind the listener to, defaults to INADDR_ANY;
423             'port', the port to listen on, defaults to 0, which picks a random port;
424             'username', a DSN username if required;
425             'password', a DSN password if required;
426             'db_opts', a hashref of DBD options that is passed to POE::Component::EasyDBI;
427             'debug', enable debugging information;
428             'multiple', set to true to enable the Queue to use multiple PoCo-Client-HTTPs, default 0;
429             'no_relay', set to true to disable report submissions to the Metabase, default 0;
430             'no_curl', set to true to disable automatic usage of POE::Component::Curl::Multi, default 0;
431             'submissions', an int to control the number of parallel http clients ( used only if multiple == 1 ), default 10;
432             'session', a POE::Session alias or session ID to send events to;
433             'recv_event', an event to be triggered when reports are received by the relay;
434              
435             C<address> may be either an simple scalar value or an arrayref of addresses to bind to.
436              
437             If C<recv_event> is specified an event will be sent for every report received by the relay server.
438             Unless C<session> is specified this event will be sent to the parent session of the component.
439              
440             =back
441              
442             =head1 OUTPUT EVENTS
443              
444             If C<recv_event> is specified to C<spawn>, an event will be sent with the following:
445              
446             C<ARG0> will be a C<HASHREF> with the following keys:
447              
448             osversion
449             distfile
450             archname
451             textreport
452             osname
453             perl_version
454             grade
455              
456             C<ARG1> will be the IP address of the client that sent the report.
457              
458             If C<queue_event> is specified to C<spawn>, an event will be sent for particular changes in queue status
459              
460             =head1 AUTHOR
461              
462             Chris Williams <chris@bingosnet.co.uk>
463              
464             =head1 COPYRIGHT AND LICENSE
465              
466             This software is copyright (c) 2014 by Chris Williams.
467              
468             This is free software; you can redistribute it and/or modify it under
469             the same terms as the Perl 5 programming language system itself.
470              
471             =head1 AUTHOR
472              
473             Chris Williams <chris@bingosnet.co.uk>
474              
475             =head1 COPYRIGHT AND LICENSE
476              
477             This software is copyright (c) 2016 by Chris Williams.
478              
479             This is free software; you can redistribute it and/or modify it under
480             the same terms as the Perl 5 programming language system itself.
481              
482             =cut