line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package POE::Component::Metabase::Client::Submit; |
2
|
|
|
|
|
|
|
$POE::Component::Metabase::Client::Submit::VERSION = '0.14'; |
3
|
|
|
|
|
|
|
#ABSTRACT: a POE client that submits to Metabase servers |
4
|
|
|
|
|
|
|
|
5
|
1
|
|
|
1
|
|
490
|
use strict; |
|
1
|
|
|
|
|
1
|
|
|
1
|
|
|
|
|
23
|
|
6
|
1
|
|
|
1
|
|
3
|
use warnings; |
|
1
|
|
|
|
|
1
|
|
|
1
|
|
|
|
|
16
|
|
7
|
1
|
|
|
1
|
|
3
|
use Carp (); |
|
1
|
|
|
|
|
1
|
|
|
1
|
|
|
|
|
13
|
|
8
|
1
|
|
|
1
|
|
352
|
use HTTP::Status qw[:constants]; |
|
1
|
|
|
|
|
2807
|
|
|
1
|
|
|
|
|
302
|
|
9
|
1
|
|
|
1
|
|
451
|
use HTTP::Request::Common (); |
|
1
|
|
|
|
|
16319
|
|
|
1
|
|
|
|
|
25
|
|
10
|
1
|
|
|
1
|
|
6
|
use HTTP::Message 5.814 (); # for HTTP::Message::decodable() support |
|
1
|
|
|
|
|
15
|
|
|
1
|
|
|
|
|
14
|
|
11
|
1
|
|
|
1
|
|
4
|
use JSON (); |
|
1
|
|
|
|
|
1
|
|
|
1
|
|
|
|
|
16
|
|
12
|
1
|
|
|
1
|
|
529
|
use POE qw[Component::Client::HTTP Component::Client::Keepalive]; |
|
1
|
|
|
|
|
28627
|
|
|
1
|
|
|
|
|
6
|
|
13
|
1
|
|
|
1
|
|
115331
|
use URI; |
|
1
|
|
|
|
|
1
|
|
|
1
|
|
|
|
|
37
|
|
14
|
|
|
|
|
|
|
|
15
|
|
|
|
|
|
|
my @valid_args; |
16
|
|
|
|
|
|
|
BEGIN { |
17
|
1
|
|
|
1
|
|
2
|
@valid_args = qw(profile secret uri fact event session http_alias context resolver compress); |
18
|
|
|
|
|
|
|
|
19
|
1
|
|
|
|
|
2
|
for my $arg (@valid_args) { |
20
|
1
|
|
|
1
|
|
3
|
no strict 'refs'; |
|
1
|
|
|
|
|
1
|
|
|
1
|
|
|
|
|
43
|
|
21
|
0
|
|
|
0
|
|
|
*$arg = sub { $_[0]->{$arg}; } |
22
|
10
|
|
|
|
|
1237
|
} |
23
|
|
|
|
|
|
|
} |
24
|
|
|
|
|
|
|
|
25
|
|
|
|
|
|
|
sub submit { |
26
|
0
|
|
|
0
|
1
|
|
my ($class,%opts) = @_; |
27
|
0
|
|
|
|
|
|
$opts{lc $_} = delete $opts{$_} for keys %opts; |
28
|
0
|
|
|
|
|
|
my $options = delete $opts{options}; |
29
|
|
|
|
|
|
|
my $args = $class->__validate_args( |
30
|
|
|
|
|
|
|
[ %opts ], |
31
|
|
|
|
|
|
|
{ |
32
|
0
|
|
|
|
|
|
( map { $_ => 0 } @valid_args ), |
33
|
0
|
|
|
|
|
|
( map { $_ => 1 } qw(profile secret uri event fact) ) |
|
0
|
|
|
|
|
|
|
34
|
|
|
|
|
|
|
} # hehe |
35
|
|
|
|
|
|
|
); |
36
|
|
|
|
|
|
|
|
37
|
0
|
|
|
|
|
|
my $self = bless $args, $class; |
38
|
|
|
|
|
|
|
|
39
|
0
|
0
|
|
|
|
|
Carp::confess( "'profile' argument for $class must be a Metabase::User::Profile" ) |
40
|
|
|
|
|
|
|
unless $self->profile->isa('Metabase::User::Profile'); |
41
|
0
|
0
|
|
|
|
|
Carp::confess( "'secret' argument for $class must be a Metabase::User::secret" ) |
42
|
|
|
|
|
|
|
unless $self->secret->isa('Metabase::User::Secret'); |
43
|
0
|
0
|
|
|
|
|
Carp::confess( "'secret' argument for $class must be a Metabase::Fact" ) |
44
|
|
|
|
|
|
|
unless $self->secret->isa('Metabase::Fact'); |
45
|
|
|
|
|
|
|
|
46
|
0
|
0
|
|
|
|
|
$self->{session_id} = POE::Session->create( |
47
|
|
|
|
|
|
|
object_states => [ |
48
|
|
|
|
|
|
|
$self => [ qw(_start _dispatch _submit _response _register _guid_exists _http_req) ], |
49
|
|
|
|
|
|
|
], |
50
|
|
|
|
|
|
|
heap => $self, |
51
|
|
|
|
|
|
|
( ref($options) eq 'HASH' ? ( options => $options ) : () ), |
52
|
|
|
|
|
|
|
)->ID(); |
53
|
0
|
|
|
|
|
|
return $self; |
54
|
|
|
|
|
|
|
} |
55
|
|
|
|
|
|
|
|
56
|
|
|
|
|
|
|
sub _start { |
57
|
0
|
|
|
0
|
|
|
my ($kernel,$session,$sender,$self) = @_[KERNEL,SESSION,SENDER,OBJECT]; |
58
|
0
|
|
|
|
|
|
$self->{session_id} = $session->ID(); |
59
|
0
|
0
|
0
|
|
|
|
if ( $kernel == $sender and !$self->{session} ) { |
60
|
0
|
|
|
|
|
|
Carp::confess "Not called from another POE session and 'session' wasn't set\n"; |
61
|
|
|
|
|
|
|
} |
62
|
0
|
|
|
|
|
|
my $sender_id; |
63
|
0
|
0
|
|
|
|
|
if ( $self->{session} ) { |
64
|
0
|
0
|
|
|
|
|
if ( my $ref = $kernel->alias_resolve( $self->{session} ) ) { |
65
|
0
|
|
|
|
|
|
$sender_id = $ref->ID(); |
66
|
|
|
|
|
|
|
} |
67
|
|
|
|
|
|
|
else { |
68
|
0
|
|
|
|
|
|
Carp::confess "Could not resolve 'session' to a valid POE session\n"; |
69
|
|
|
|
|
|
|
} |
70
|
|
|
|
|
|
|
} |
71
|
|
|
|
|
|
|
else { |
72
|
0
|
|
|
|
|
|
$sender_id = $sender->ID(); |
73
|
|
|
|
|
|
|
} |
74
|
0
|
|
|
|
|
|
$kernel->refcount_increment( $sender_id, __PACKAGE__ ); |
75
|
0
|
|
|
|
|
|
$kernel->detach_myself; |
76
|
0
|
|
|
|
|
|
$self->{sender_id} = $sender_id; |
77
|
0
|
0
|
|
|
|
|
if ( $self->{http_alias} ) { |
78
|
0
|
|
|
|
|
|
my $http_ref = $kernel->alias_resolve( $self->{http_alias} ); |
79
|
0
|
0
|
|
|
|
|
$self->{http_id} = $http_ref->ID() if $http_ref; |
80
|
|
|
|
|
|
|
} |
81
|
0
|
0
|
|
|
|
|
unless ( $self->{http_id} ) { |
82
|
0
|
|
|
|
|
|
$self->{http_id} = 'metabaseclient' . $$ . $self->{session_id}; |
83
|
0
|
|
|
|
|
|
my $ka; |
84
|
0
|
0
|
|
|
|
|
if ( $self->resolver ) { |
85
|
0
|
|
|
|
|
|
$ka = POE::Component::Client::Keepalive->new( |
86
|
|
|
|
|
|
|
resolver => $self->resolver, |
87
|
|
|
|
|
|
|
); |
88
|
|
|
|
|
|
|
} |
89
|
|
|
|
|
|
|
POE::Component::Client::HTTP->spawn( |
90
|
|
|
|
|
|
|
Alias => $self->{http_id}, |
91
|
0
|
0
|
|
|
|
|
FollowRedirects => 2, |
92
|
|
|
|
|
|
|
Timeout => 120, |
93
|
|
|
|
|
|
|
Agent => 'Mozilla/5.0 (X11; U; Linux i686; en-US; ' |
94
|
|
|
|
|
|
|
. 'rv:1.1) Gecko/20020913 Debian/1.1-1', |
95
|
|
|
|
|
|
|
( defined $ka ? ( ConnectionManager => $ka ) : () ), |
96
|
|
|
|
|
|
|
); |
97
|
0
|
|
|
|
|
|
$self->{my_httpc} = 1; |
98
|
|
|
|
|
|
|
} |
99
|
0
|
|
|
|
|
|
$kernel->yield( '_submit' ); |
100
|
0
|
|
|
|
|
|
return; |
101
|
|
|
|
|
|
|
} |
102
|
|
|
|
|
|
|
|
103
|
|
|
|
|
|
|
sub _submit { |
104
|
0
|
|
|
0
|
|
|
my ($kernel,$self) = @_[KERNEL,OBJECT]; |
105
|
0
|
|
|
|
|
|
my $fact = $self->fact; |
106
|
0
|
|
|
|
|
|
my $path = sprintf 'submit/%s', $fact->type; |
107
|
|
|
|
|
|
|
|
108
|
0
|
0
|
|
|
|
|
$fact->set_creator($self->profile->resource) |
109
|
|
|
|
|
|
|
unless $fact->creator; |
110
|
|
|
|
|
|
|
|
111
|
0
|
|
|
|
|
|
my $req_uri = $self->_abs_uri($path); |
112
|
0
|
|
|
|
|
|
my $can_decode = HTTP::Message::decodable; |
113
|
|
|
|
|
|
|
|
114
|
0
|
0
|
|
|
|
|
my $req = HTTP::Request::Common::POST( |
115
|
|
|
|
|
|
|
$req_uri, |
116
|
|
|
|
|
|
|
( length $can_decode ? ('Accept-Encoding' => $can_decode) : () ), |
117
|
|
|
|
|
|
|
Content_Type => 'application/json', |
118
|
|
|
|
|
|
|
Accept => 'application/json', |
119
|
|
|
|
|
|
|
Content => JSON->new->encode($fact->as_struct), |
120
|
|
|
|
|
|
|
); |
121
|
0
|
|
|
|
|
|
$req->authorization_basic($self->profile->resource->guid, $self->secret->content); |
122
|
|
|
|
|
|
|
|
123
|
|
|
|
|
|
|
# Compress it? |
124
|
0
|
0
|
0
|
|
|
|
if ( defined $self->compress and $self->compress ne 'none' ) { |
125
|
0
|
|
|
|
|
|
my $err; |
126
|
0
|
|
|
|
|
|
eval { $req->encode( $self->compress ) }; |
|
0
|
|
|
|
|
|
|
127
|
0
|
0
|
|
|
|
|
if ( $@ ) { |
128
|
0
|
|
|
|
|
|
$self->{_error} = "Compression error: $@"; |
129
|
0
|
|
|
|
|
|
$self->{success} = 0; |
130
|
0
|
|
|
|
|
|
$kernel->yield( '_dispatch' ); |
131
|
0
|
|
|
|
|
|
return; |
132
|
|
|
|
|
|
|
} |
133
|
|
|
|
|
|
|
} |
134
|
|
|
|
|
|
|
|
135
|
0
|
|
|
|
|
|
$kernel->yield( '_http_req', $req, 'submit' ); |
136
|
0
|
|
|
|
|
|
return; |
137
|
|
|
|
|
|
|
} |
138
|
|
|
|
|
|
|
|
139
|
|
|
|
|
|
|
sub _guid_exists { |
140
|
0
|
|
|
0
|
|
|
my ($kernel,$self) = @_[KERNEL,OBJECT]; |
141
|
0
|
|
|
|
|
|
my $path = sprintf 'guid/%s', $self->profile->guid; |
142
|
0
|
|
|
|
|
|
my $req_uri = $self->_abs_uri($path); |
143
|
0
|
|
|
|
|
|
my $req = HTTP::Request::Common::HEAD( $req_uri ); |
144
|
0
|
|
|
|
|
|
$kernel->yield( '_http_req', $req, 'guid' ); |
145
|
0
|
|
|
|
|
|
return; |
146
|
|
|
|
|
|
|
} |
147
|
|
|
|
|
|
|
|
148
|
|
|
|
|
|
|
sub _register { |
149
|
0
|
|
|
0
|
|
|
my ($kernel,$self) = @_[KERNEL,OBJECT]; |
150
|
|
|
|
|
|
|
|
151
|
0
|
|
|
|
|
|
for my $type ( qw/profile secret/ ) { |
152
|
0
|
0
|
|
|
|
|
$self->$type->set_creator( $self->$type->resource ) |
153
|
|
|
|
|
|
|
unless $self->$type->creator; |
154
|
|
|
|
|
|
|
} |
155
|
|
|
|
|
|
|
|
156
|
0
|
|
|
|
|
|
my $req_uri = $self->_abs_uri('register'); |
157
|
0
|
|
|
|
|
|
my $can_decode = HTTP::Message::decodable; |
158
|
|
|
|
|
|
|
|
159
|
0
|
0
|
|
|
|
|
my $req = HTTP::Request::Common::POST( |
160
|
|
|
|
|
|
|
$req_uri, |
161
|
|
|
|
|
|
|
( length $can_decode ? ('Accept-Encoding' => $can_decode) : () ), |
162
|
|
|
|
|
|
|
Content_Type => 'application/json', |
163
|
|
|
|
|
|
|
Accept => 'application/json', |
164
|
|
|
|
|
|
|
Content => JSON->new->encode([ |
165
|
|
|
|
|
|
|
$self->profile->as_struct, $self->secret->as_struct |
166
|
|
|
|
|
|
|
]), |
167
|
|
|
|
|
|
|
); |
168
|
|
|
|
|
|
|
|
169
|
0
|
|
|
|
|
|
$kernel->yield( '_http_req', $req, 'register' ); |
170
|
0
|
|
|
|
|
|
return; |
171
|
|
|
|
|
|
|
} |
172
|
|
|
|
|
|
|
|
173
|
|
|
|
|
|
|
sub _http_req { |
174
|
0
|
|
|
0
|
|
|
my ($self,$req,$id) = @_[OBJECT,ARG0,ARG1]; |
175
|
|
|
|
|
|
|
$poe_kernel->post( |
176
|
|
|
|
|
|
|
$self->{http_id}, |
177
|
0
|
|
|
|
|
|
'request', |
178
|
|
|
|
|
|
|
'_response', |
179
|
|
|
|
|
|
|
$req, |
180
|
|
|
|
|
|
|
$id, |
181
|
|
|
|
|
|
|
); |
182
|
0
|
|
|
|
|
|
return; |
183
|
|
|
|
|
|
|
} |
184
|
|
|
|
|
|
|
|
185
|
|
|
|
|
|
|
sub _response { |
186
|
0
|
|
|
0
|
|
|
my ($kernel,$self,$request_packet,$response_packet) = @_[KERNEL,OBJECT,ARG0,ARG1]; |
187
|
0
|
|
|
|
|
|
my $tag = $request_packet->[1]; |
188
|
0
|
|
|
|
|
|
my $res = $response_packet->[0]; |
189
|
|
|
|
|
|
|
# and punt an event back to the requesting session |
190
|
0
|
0
|
0
|
|
|
|
if ( $tag eq 'submit' and $res->code == HTTP_UNAUTHORIZED ) { |
191
|
0
|
|
|
|
|
|
$kernel->yield( '_guid_exists' ); |
192
|
0
|
|
|
|
|
|
return; |
193
|
|
|
|
|
|
|
} |
194
|
0
|
0
|
|
|
|
|
if ( $tag eq 'guid' ) { |
195
|
0
|
0
|
|
|
|
|
if ( $res->is_success ) { |
196
|
0
|
|
|
|
|
|
$self->{_error} = 'authentication failed'; |
197
|
0
|
|
|
|
|
|
$self->{content} = $res->content; |
198
|
0
|
|
|
|
|
|
$kernel->yield( '_dispatch' ); |
199
|
0
|
|
|
|
|
|
return; |
200
|
|
|
|
|
|
|
} |
201
|
0
|
|
|
|
|
|
$kernel->yield( '_register' ); |
202
|
0
|
|
|
|
|
|
return; |
203
|
|
|
|
|
|
|
} |
204
|
0
|
0
|
|
|
|
|
if ( $tag eq 'register' ) { |
205
|
0
|
0
|
|
|
|
|
unless ( $res->is_success ) { |
206
|
0
|
|
|
|
|
|
$self->{_error} = 'registration failed'; |
207
|
0
|
|
|
|
|
|
$self->{content} = $res->content; |
208
|
0
|
|
|
|
|
|
$kernel->yield( '_dispatch' ); |
209
|
0
|
|
|
|
|
|
return; |
210
|
|
|
|
|
|
|
} |
211
|
0
|
|
|
|
|
|
$kernel->yield( '_submit' ); |
212
|
0
|
|
|
|
|
|
return; |
213
|
|
|
|
|
|
|
} |
214
|
0
|
0
|
|
|
|
|
unless ( $res->is_success ) { |
215
|
0
|
|
|
|
|
|
$self->{_error} = "fact submission failed"; |
216
|
|
|
|
|
|
|
} |
217
|
|
|
|
|
|
|
else { |
218
|
0
|
|
|
|
|
|
$self->{success} = 1; |
219
|
|
|
|
|
|
|
} |
220
|
|
|
|
|
|
|
|
221
|
|
|
|
|
|
|
# decode the content if we requested it |
222
|
0
|
0
|
|
|
|
|
if ( defined $request_packet->[0]->header( 'Accept-Encoding' ) ) { |
223
|
0
|
|
|
|
|
|
eval { $self->{content} = $res->decoded_content( 'charset' => 'none' ) }; |
|
0
|
|
|
|
|
|
|
224
|
0
|
0
|
|
|
|
|
if ( $@ ) { |
225
|
0
|
|
|
|
|
|
$self->{_error} = "unable to decode content: $@"; |
226
|
0
|
|
|
|
|
|
$self->{success} = 0; |
227
|
|
|
|
|
|
|
} |
228
|
|
|
|
|
|
|
} else { |
229
|
0
|
|
|
|
|
|
$self->{content} = $res->content; |
230
|
|
|
|
|
|
|
} |
231
|
0
|
|
|
|
|
|
$kernel->yield( '_dispatch' ); |
232
|
0
|
|
|
|
|
|
return; |
233
|
|
|
|
|
|
|
} |
234
|
|
|
|
|
|
|
|
235
|
|
|
|
|
|
|
sub _dispatch { |
236
|
0
|
|
|
0
|
|
|
my ($kernel,$self) = @_[KERNEL,OBJECT]; |
237
|
|
|
|
|
|
|
$kernel->post( $self->{http_id}, 'shutdown' ) |
238
|
0
|
0
|
|
|
|
|
if $self->{my_httpc}; |
239
|
0
|
|
|
|
|
|
my $ref = {}; |
240
|
0
|
|
|
|
|
|
for ( qw(_error success context content) ) { |
241
|
0
|
0
|
|
|
|
|
$ref->{$_} = $self->{$_} if $self->{$_}; |
242
|
|
|
|
|
|
|
} |
243
|
0
|
0
|
|
|
|
|
$ref->{error} = delete $ref->{_error} if $ref->{_error}; |
244
|
0
|
|
|
|
|
|
$kernel->post( $self->{sender_id}, $self->event, $ref ); |
245
|
0
|
|
|
|
|
|
$kernel->refcount_decrement( $self->{sender_id}, __PACKAGE__ ); |
246
|
0
|
|
|
|
|
|
return; |
247
|
|
|
|
|
|
|
} |
248
|
|
|
|
|
|
|
|
249
|
|
|
|
|
|
|
#--------------------------------------------------------------------------# |
250
|
|
|
|
|
|
|
# private methods |
251
|
|
|
|
|
|
|
#--------------------------------------------------------------------------# |
252
|
|
|
|
|
|
|
|
253
|
|
|
|
|
|
|
# Stolen from ::Fact. |
254
|
|
|
|
|
|
|
# XXX: Should refactor this into something in Fact, which we can then rely on. |
255
|
|
|
|
|
|
|
# -- rjbs, 2009-03-30 |
256
|
|
|
|
|
|
|
sub __validate_args { |
257
|
0
|
|
|
0
|
|
|
my ($self, $args, $spec) = @_; |
258
|
0
|
0
|
0
|
|
|
|
my $hash = (@$args == 1 and ref $args->[0]) ? { %{ $args->[0] } } |
|
0
|
0
|
|
|
|
|
|
259
|
|
|
|
|
|
|
: (@$args == 0) ? { } |
260
|
|
|
|
|
|
|
: { @$args }; |
261
|
|
|
|
|
|
|
|
262
|
0
|
|
|
|
|
|
my @errors; |
263
|
|
|
|
|
|
|
|
264
|
0
|
|
|
|
|
|
for my $key (keys %$hash) { |
265
|
|
|
|
|
|
|
push @errors, qq{unknown argument "$key" when constructing $self} |
266
|
0
|
0
|
|
|
|
|
unless exists $spec->{ $key }; |
267
|
|
|
|
|
|
|
} |
268
|
|
|
|
|
|
|
|
269
|
0
|
|
|
|
|
|
for my $key (grep { $spec->{ $_ } } keys %$spec) { |
|
0
|
|
|
|
|
|
|
270
|
|
|
|
|
|
|
push @errors, qq{missing required argument "$key" when constructing $self} |
271
|
0
|
0
|
|
|
|
|
unless defined $hash->{ $key }; |
272
|
|
|
|
|
|
|
} |
273
|
|
|
|
|
|
|
|
274
|
0
|
0
|
|
|
|
|
Carp::confess(join qq{\n}, @errors) if @errors; |
275
|
|
|
|
|
|
|
|
276
|
0
|
|
|
|
|
|
return $hash; |
277
|
|
|
|
|
|
|
} |
278
|
|
|
|
|
|
|
|
279
|
|
|
|
|
|
|
sub _abs_uri { |
280
|
0
|
|
|
0
|
|
|
my ($self, $str) = @_; |
281
|
0
|
|
|
|
|
|
my $req_uri = URI->new($str)->abs($self->uri); |
282
|
|
|
|
|
|
|
} |
283
|
|
|
|
|
|
|
|
284
|
|
|
|
|
|
|
sub _error { |
285
|
0
|
|
|
0
|
|
|
my ($self, $res, $prefix) = @_; |
286
|
0
|
|
0
|
|
|
|
$prefix ||= "unrecognized error"; |
287
|
0
|
0
|
0
|
|
|
|
if ( ref($res) && $res->header('Content-Type') eq 'application/json') { |
288
|
0
|
|
|
|
|
|
my $entity = JSON->new->decode($res->content); |
289
|
0
|
|
|
|
|
|
return "$prefix\: $entity->{error}"; |
290
|
|
|
|
|
|
|
} |
291
|
|
|
|
|
|
|
else { |
292
|
0
|
|
|
|
|
|
return "$prefix\: " . $res->message; |
293
|
|
|
|
|
|
|
} |
294
|
|
|
|
|
|
|
} |
295
|
|
|
|
|
|
|
|
296
|
|
|
|
|
|
|
'Submit this'; |
297
|
|
|
|
|
|
|
|
298
|
|
|
|
|
|
|
__END__ |