File Coverage

blib/lib/Flower/Node.pm
Criterion Covered Total %
statement 67 131 51.1
branch 14 40 35.0
condition 2 29 6.9
subroutine 19 29 65.5
pod 0 14 0.0
total 102 243 41.9


line stmt bran cond sub pod time code
1             package Flower::Node;
2              
3 3     3   610 use strict;
  3         6  
  3         70  
4 3     3   14 use warnings;
  3         5  
  3         82  
5 3     3   14 use feature qw(say);
  3         4  
  3         284  
6 3     3   813 use Mojo::UserAgent;
  3         255185  
  3         32  
7 3     3   98 use Mojo::ByteStream qw/b/;
  3         6  
  3         148  
8 3     3   16 use JSON::XS;
  3         6  
  3         198  
9              
10 3     3   1587 use AnyEvent;
  3         5676  
  3         83  
11 3     3   15 use Scalar::Util qw/refaddr/;
  3         5  
  3         148  
12              
13 3     3   14 use Carp qw/confess/;
  3         15  
  3         155  
14              
15 3     3   16 use overload '""' => \&to_string;
  3         4  
  3         49  
16              
17 3     3   1013 use Data::UUID;
  3         820  
  3         5315  
18              
19             my $uuid = Data::UUID->new();
20             my $timeout = 60;
21              
22             my $json = JSON::XS->new->allow_nonref;
23              
24              
25             #my $json = JSON->new();
26              
27             sub new {
28 7     7 0 1732 my $class = shift;
29 7 50       25 confess "called as object method" if ref $class;
30              
31 7   100     30 my $args = shift || {};
32              
33 7 100       435 confess "no parent supplied" if ( !$args->{parent} );
34 5 100       154 confess "no port supplied" if ( !$args->{port} );
35 4 100       151 confess "no ip supplied" if ( !$args->{ip} );
36              
37             my $self = {
38             uuid => $args->{uuid},
39             ip => $args->{ip},
40             port => $args->{port},
41             timeout => time() + ( $timeout / 2 ) - int( rand(20) ),
42             parent => $args->{parent},
43             files => $args->{files},
44 3         136 };
45              
46 3         8 bless $self, __PACKAGE__;
47 3         12 return $self;
48             }
49              
50             # accessors
51              
52             sub uuid {
53 2     2 0 3 my $self = shift;
54 2         46 return $self->{uuid};
55             }
56              
57             sub ip {
58 1     1 0 2 my $self = shift;
59 1         4 return $self->{ip};
60             }
61              
62             sub port {
63 1     1 0 2 my $self = shift;
64 1         3 return $self->{port};
65             }
66              
67             sub parent {
68 0     0 0 0 my $self = shift;
69 0         0 return $self->{parent};
70             }
71              
72             sub files {
73 0     0 0 0 my $self = shift;
74             confess "set_files was never called for $self"
75 0 0       0 unless defined $self->{files};
76 0         0 return $self->{files};
77             }
78              
79             sub has_files_object {
80 0     0 0 0 my $self = shift;
81 0 0       0 return 1 if $self->{files};
82 0         0 return 0;
83             }
84              
85             # mutators
86              
87             sub set_files {
88 1     1 0 2 my $self = shift;
89 1         2 my $files = shift;
90 1         32 $self->{files} = $files;
91 1         2 return;
92             }
93              
94             # checks
95              
96             sub has_timed_out {
97 2     2 0 3 my $self = shift;
98 2 100       10 return 1 if ( $self->{timeout} < time() );
99 1         4 return 0;
100             }
101              
102             # action methods
103              
104             sub ping_if_necessary {
105 1     1 0 18 my $self = shift;
106 1         3 my $all_nodes = shift;
107              
108 1 50       4 if ( $self->{ping_cv} ) {
109 0         0 return;
110             }
111              
112             # ping if less than half of our timeout is left
113 1 50       5 if ( $self->{timeout} - $timeout / 2 < time() ) {
114              
115 1         4 my $url = "https://" . $self->ip . ":" . $self->port . "/REST/1.0/ping?";
116 1         12 my $nodedata = $json->encode($all_nodes);
117              
118 1         15 $self->{ping_ua} = Mojo::UserAgent->new;
119 1         36 $self->{ping_cv} = AE::cv;
120              
121             # set up what we do when there is a response
122             $self->{ping_cv}->cb(
123             sub {
124 0     0   0 my ( $node, $tx ) = ( shift->recv );
125 0         0 $node->ping_received($tx);
126             }
127 1         1904 );
128              
129             # do the ping (POST)
130             $self->{ping_ua}->post(
131             $url => { 'Content-Type' => 'application/json' } => $nodedata => sub {
132 0     0   0 my ( $ua, $tx ) = @_;
133 0         0 $self->{ping_cv}->send( $self, $tx );
134             }
135 1         55 );
136             }
137             }
138              
139             sub ping_received {
140 0     0 0 0 my $self = shift;
141 0         0 my $tx = shift;
142              
143 0 0 0     0 if ( $tx && $tx->res && $tx->res->code && $tx->res->code == 200 ) {
      0        
      0        
144 0         0 my $response;
145 0         0 eval { $response = $tx->res->json; };
  0         0  
146 0 0 0     0 if ( !$@ && $response->{result} eq 'ok' ) {
147              
148             # UUID better match too, if we know the uuid yet (we may not)
149 0 0 0     0 if ( !$self->uuid || ( $response->{uuid} eq $self->uuid ) ) {
150              
151             # reset the timer and set the uuid
152 0         0 $self->{timeout} = time() + $timeout;
153 0         0 $self->{uuid} = $response->{uuid};
154              
155             # schedule to update the file list
156 0         0 $self->get_file_list();
157             }
158              
159             else {
160 0         0 warn "uuid does not match!\n";
161 0         0 warn "expected " . $self->uuid . "\n";
162 0         0 warn "got " . $response->{uuid} . "\n";
163             }
164             }
165             else {
166 0         0 warn "something bad happened: $@\n";
167             }
168             }
169             else {
170 0         0 say " * $self - bad ping response";
171 0         0 say " body . " . $tx->res->body;
172             }
173              
174             # whatever happened, we are done with the request, so kill
175             # the event and ua.
176 0         0 undef $self->{ping_cv};
177 0         0 undef $self->{ping_ua};
178              
179             }
180              
181             sub get_file_list {
182 0     0 0 0 my $self = shift;
183 0         0 my $all_nodes = shift;
184              
185             # don't do it to ourself
186 0 0       0 if ( refaddr($self) eq refaddr( $self->parent->self ) ) {
187 0         0 return;
188             }
189              
190 0 0       0 if ( $self->{files_cv} ) {
191 0         0 warn "get_file_list already in progress";
192 0         0 return;
193             }
194              
195 0         0 my $url = "https://" . $self->ip . ":" . $self->port . "/REST/1.0/files";
196              
197 0         0 $self->{files_ua} = Mojo::UserAgent->new;
198 0         0 $self->{files_cv} = AE::cv;
199              
200             # set up what we do when there is a response
201             $self->{files_cv}->cb(
202             sub {
203 0     0   0 my ( $node, $tx ) = ( shift->recv );
204 0         0 $node->file_list_received($tx);
205             }
206 0         0 );
207              
208             # do the request
209             $self->{files_ua}->get(
210             $url => sub {
211 0     0   0 my ( $ua, $tx ) = @_;
212 0         0 $self->{files_cv}->send( $self, $tx );
213             }
214 0         0 );
215              
216             }
217              
218             sub file_list_received {
219 0     0 0 0 my $self = shift;
220 0         0 my $tx = shift;
221              
222 0 0 0     0 if ( $tx && $tx->res && $tx->res->code && $tx->res->code == 200 ) {
      0        
      0        
223 0         0 my $response;
224 0         0 eval { $response = $tx->res->json; };
  0         0  
225 0 0 0     0 if ( !$@ && $response->{result} eq 'ok' ) {
226              
227             # good stuff
228 0         0 my $files_data = $response->{files}; # array of hashrefs
229             # create an empty files object if we don't have one yet.
230 0 0       0 if ( !$self->has_files_object ) {
231 0         0 $self->set_files( Flower::Files->new() );
232             }
233              
234             # update it
235 0         0 $self->files->update_files_from_arrayref($files_data);
236             }
237             else {
238 0         0 warn "something bad happened: $@\n";
239             }
240             }
241             else {
242 0         0 say " * $self - bad get_files response";
243 0         0 say " body . " . $tx->res->body;
244             }
245              
246             # whatever happened, we are done with the request, so kill
247             # the event and ua.
248 0         0 undef $self->{files_cv};
249 0         0 undef $self->{files_ua};
250             }
251              
252             # helpers
253              
254             sub to_string {
255 3     3 0 37 my $self = shift;
256             return sprintf(
257             "%s | %s | %s (%s secs)",
258             $self->{uuid} ? $self->{uuid} : "[undef]",
259             $self->{ip} ? $self->{ip} : "[undef]",
260             $self->{port} ? $self->{port} : "[undef]",
261 3 50       37 $self->{timeout} - time(),
    50          
    50          
262             );
263             }
264              
265             1;