line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
# vim: filetype=perl:noexpandtab:ts=3:sw=3 |
2
|
|
|
|
|
|
|
# |
3
|
|
|
|
|
|
|
# Copyright (C) 2009 NZ Registry Services |
4
|
|
|
|
|
|
|
# |
5
|
|
|
|
|
|
|
# This program is free software: you can redistribute it and/or modify |
6
|
|
|
|
|
|
|
# it under the terms of the Artistic License 2.0 or later. You should |
7
|
|
|
|
|
|
|
# have received a copy of the Artistic License the file COPYING.txt. |
8
|
|
|
|
|
|
|
# If not, see <http://www.perlfoundation.org/artistic_license_2_0> |
9
|
|
|
|
|
|
|
|
10
|
|
|
|
|
|
|
package SRS::EPP::Session; |
11
|
|
|
|
|
|
|
|
12
|
|
|
|
|
|
|
# this object is unfortunately something of a ``God Object'', but |
13
|
|
|
|
|
|
|
# measures are taken to stop that from being awful; mostly delegation |
14
|
|
|
|
|
|
|
# to other objects |
15
|
|
|
|
|
|
|
|
16
|
1
|
|
|
1
|
|
1238
|
use 5.010; |
|
1
|
|
|
|
|
4
|
|
|
1
|
|
|
|
|
51
|
|
17
|
1
|
|
|
1
|
|
7
|
use strict; |
|
1
|
|
|
|
|
1
|
|
|
1
|
|
|
|
|
52
|
|
18
|
|
|
|
|
|
|
|
19
|
1
|
|
|
1
|
|
247
|
use Moose; |
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
20
|
|
|
|
|
|
|
use MooseX::Method::Signatures; |
21
|
|
|
|
|
|
|
|
22
|
|
|
|
|
|
|
with 'MooseX::Log::Log4perl::Easy'; |
23
|
|
|
|
|
|
|
|
24
|
|
|
|
|
|
|
# messages that we use |
25
|
|
|
|
|
|
|
# - XML formats |
26
|
|
|
|
|
|
|
use XML::EPP; |
27
|
|
|
|
|
|
|
use XML::SRS; |
28
|
|
|
|
|
|
|
|
29
|
|
|
|
|
|
|
# - wrapper classes |
30
|
|
|
|
|
|
|
use SRS::EPP::Command; |
31
|
|
|
|
|
|
|
use SRS::EPP::Response; |
32
|
|
|
|
|
|
|
use SRS::EPP::Response::Error; |
33
|
|
|
|
|
|
|
use SRS::EPP::SRSMessage; |
34
|
|
|
|
|
|
|
use SRS::EPP::SRSRequest; |
35
|
|
|
|
|
|
|
use SRS::EPP::SRSResponse; |
36
|
|
|
|
|
|
|
|
37
|
|
|
|
|
|
|
# queue classes and slave components |
38
|
|
|
|
|
|
|
use SRS::EPP::Packets; |
39
|
|
|
|
|
|
|
use SRS::EPP::Session::CmdQ; |
40
|
|
|
|
|
|
|
use SRS::EPP::Session::BackendQ; |
41
|
|
|
|
|
|
|
use SRS::EPP::Proxy::UA; |
42
|
|
|
|
|
|
|
|
43
|
|
|
|
|
|
|
# other includes |
44
|
|
|
|
|
|
|
use HTTP::Request::Common qw(POST); |
45
|
|
|
|
|
|
|
use bytes qw(); |
46
|
|
|
|
|
|
|
use utf8; |
47
|
|
|
|
|
|
|
use Encode qw(decode encode); |
48
|
|
|
|
|
|
|
|
49
|
|
|
|
|
|
|
has io => |
50
|
|
|
|
|
|
|
is => "ro", |
51
|
|
|
|
|
|
|
isa => "Net::SSLeay::OO::SSL", |
52
|
|
|
|
|
|
|
; |
53
|
|
|
|
|
|
|
|
54
|
|
|
|
|
|
|
# so the socket doesn't fall out of scope and get closed... |
55
|
|
|
|
|
|
|
has 'socket' => |
56
|
|
|
|
|
|
|
is => "ro", |
57
|
|
|
|
|
|
|
isa => "IO::Handle", |
58
|
|
|
|
|
|
|
; |
59
|
|
|
|
|
|
|
|
60
|
|
|
|
|
|
|
has user => |
61
|
|
|
|
|
|
|
is => "rw", |
62
|
|
|
|
|
|
|
isa => "Str", |
63
|
|
|
|
|
|
|
; |
64
|
|
|
|
|
|
|
|
65
|
|
|
|
|
|
|
# hack for login message |
66
|
|
|
|
|
|
|
has want_user => |
67
|
|
|
|
|
|
|
is => "rw", |
68
|
|
|
|
|
|
|
isa => "Str", |
69
|
|
|
|
|
|
|
clearer => "clear_want_user", |
70
|
|
|
|
|
|
|
; |
71
|
|
|
|
|
|
|
|
72
|
|
|
|
|
|
|
# this "State" is the state according to the chart in RFC3730 and is |
73
|
|
|
|
|
|
|
# updated for amusement's sake only |
74
|
|
|
|
|
|
|
has state => |
75
|
|
|
|
|
|
|
is => "rw", |
76
|
|
|
|
|
|
|
isa => "Str", |
77
|
|
|
|
|
|
|
default => "Waiting for Client", |
78
|
|
|
|
|
|
|
trigger => sub { |
79
|
|
|
|
|
|
|
my $self = shift; |
80
|
|
|
|
|
|
|
if ( $self->has_proxy ) { |
81
|
|
|
|
|
|
|
$self->proxy->show_state(shift, $self); |
82
|
|
|
|
|
|
|
} |
83
|
|
|
|
|
|
|
}, |
84
|
|
|
|
|
|
|
; |
85
|
|
|
|
|
|
|
|
86
|
|
|
|
|
|
|
has 'proxy' => |
87
|
|
|
|
|
|
|
is => "ro", |
88
|
|
|
|
|
|
|
isa => "SRS::EPP::Proxy", |
89
|
|
|
|
|
|
|
predicate => "has_proxy", |
90
|
|
|
|
|
|
|
weak_ref => 1, |
91
|
|
|
|
|
|
|
handles => [qw/openpgp/], |
92
|
|
|
|
|
|
|
required => 1, |
93
|
|
|
|
|
|
|
; |
94
|
|
|
|
|
|
|
|
95
|
|
|
|
|
|
|
# this object is billed with providing an Event.pm-like interface. |
96
|
|
|
|
|
|
|
has event => |
97
|
|
|
|
|
|
|
is => "ro", |
98
|
|
|
|
|
|
|
required => 1, |
99
|
|
|
|
|
|
|
; |
100
|
|
|
|
|
|
|
|
101
|
|
|
|
|
|
|
has output_event_watcher => |
102
|
|
|
|
|
|
|
is => "rw", |
103
|
|
|
|
|
|
|
; |
104
|
|
|
|
|
|
|
|
105
|
|
|
|
|
|
|
has input_event_watcher => |
106
|
|
|
|
|
|
|
is => "rw", |
107
|
|
|
|
|
|
|
; |
108
|
|
|
|
|
|
|
|
109
|
|
|
|
|
|
|
# 'yield' means to queue an event for running but not run it |
110
|
|
|
|
|
|
|
# immediately. |
111
|
|
|
|
|
|
|
has 'yielding' => |
112
|
|
|
|
|
|
|
is => "ro", |
113
|
|
|
|
|
|
|
isa => "HashRef", |
114
|
|
|
|
|
|
|
default => sub { {} }, |
115
|
|
|
|
|
|
|
; |
116
|
|
|
|
|
|
|
|
117
|
|
|
|
|
|
|
method yield(Str $method, @args) { |
118
|
|
|
|
|
|
|
my $trace; |
119
|
|
|
|
|
|
|
if ( $self->log->is_trace ) { |
120
|
|
|
|
|
|
|
my $caller = ((caller(1))[3]); |
121
|
|
|
|
|
|
|
$self->log_trace( |
122
|
|
|
|
|
|
|
"$caller yields $method" |
123
|
|
|
|
|
|
|
.(@args?" (with args: @args)":"") |
124
|
|
|
|
|
|
|
); |
125
|
|
|
|
|
|
|
} |
126
|
|
|
|
|
|
|
if ( !@args ) { |
127
|
|
|
|
|
|
|
if ( $self->yielding->{$method} ) { |
128
|
|
|
|
|
|
|
$self->log_trace(" - already yielding"); |
129
|
|
|
|
|
|
|
return; |
130
|
|
|
|
|
|
|
} |
131
|
|
|
|
|
|
|
else { |
132
|
|
|
|
|
|
|
$self->yielding->{$method} = 1; |
133
|
|
|
|
|
|
|
} |
134
|
|
|
|
|
|
|
} |
135
|
|
|
|
|
|
|
$self->event->timer( |
136
|
|
|
|
|
|
|
desc => $method, |
137
|
|
|
|
|
|
|
after => 0, |
138
|
|
|
|
|
|
|
cb => sub { |
139
|
|
|
|
|
|
|
delete $self->yielding->{$method}; |
140
|
|
|
|
|
|
|
if ( $self->log->is_trace ) { |
141
|
|
|
|
|
|
|
$self->log_trace( |
142
|
|
|
|
|
|
|
"Calling $method".(@args?"(@args)":"") |
143
|
|
|
|
|
|
|
); |
144
|
|
|
|
|
|
|
} |
145
|
|
|
|
|
|
|
$self->$method(@args); |
146
|
|
|
|
|
|
|
}); |
147
|
|
|
|
|
|
|
} |
148
|
|
|
|
|
|
|
|
149
|
|
|
|
|
|
|
has 'connection_id' => |
150
|
|
|
|
|
|
|
is => "ro", |
151
|
|
|
|
|
|
|
isa => "Str", |
152
|
|
|
|
|
|
|
default => sub { |
153
|
|
|
|
|
|
|
sprintf("sep.%x.%.4x",time(),$$&65535); |
154
|
|
|
|
|
|
|
}, |
155
|
|
|
|
|
|
|
; |
156
|
|
|
|
|
|
|
|
157
|
|
|
|
|
|
|
has 'peerhost' => |
158
|
|
|
|
|
|
|
is => "rw", |
159
|
|
|
|
|
|
|
isa => "Str", |
160
|
|
|
|
|
|
|
; |
161
|
|
|
|
|
|
|
|
162
|
|
|
|
|
|
|
has 'peer_cn' => |
163
|
|
|
|
|
|
|
is => "rw", |
164
|
|
|
|
|
|
|
isa => "Str", |
165
|
|
|
|
|
|
|
; |
166
|
|
|
|
|
|
|
|
167
|
|
|
|
|
|
|
has 'server_id_seq' => |
168
|
|
|
|
|
|
|
is => "rw", |
169
|
|
|
|
|
|
|
isa => "Num", |
170
|
|
|
|
|
|
|
traits => [qw/Number/], |
171
|
|
|
|
|
|
|
handles => { |
172
|
|
|
|
|
|
|
'inc_server_id' => 'add', |
173
|
|
|
|
|
|
|
}, |
174
|
|
|
|
|
|
|
default => 0, |
175
|
|
|
|
|
|
|
; |
176
|
|
|
|
|
|
|
|
177
|
|
|
|
|
|
|
# called when a response is generated from the server itself, not the |
178
|
|
|
|
|
|
|
# back-end. Return an ephemeral ID based on the timestamp and a |
179
|
|
|
|
|
|
|
# session counter. |
180
|
|
|
|
|
|
|
method new_server_id() { |
181
|
|
|
|
|
|
|
$self->inc_server_id(1); |
182
|
|
|
|
|
|
|
my $id = $self->connection_id.".".sprintf("%.3d",$self->server_id_seq); |
183
|
|
|
|
|
|
|
$self->log_trace("server-generated ID is $id"); |
184
|
|
|
|
|
|
|
$id; |
185
|
|
|
|
|
|
|
} |
186
|
|
|
|
|
|
|
|
187
|
|
|
|
|
|
|
#---- |
188
|
|
|
|
|
|
|
# input packet chunking |
189
|
|
|
|
|
|
|
has 'input_packeter' => |
190
|
|
|
|
|
|
|
default => sub { |
191
|
|
|
|
|
|
|
my $self = shift; |
192
|
|
|
|
|
|
|
SRS::EPP::Packets->new(session => $self); |
193
|
|
|
|
|
|
|
}, |
194
|
|
|
|
|
|
|
handles => [qw( input_event input_state input_expect )], |
195
|
|
|
|
|
|
|
; |
196
|
|
|
|
|
|
|
|
197
|
|
|
|
|
|
|
method read_input( Int $how_much where { $_ > 0 } ) { |
198
|
|
|
|
|
|
|
my $rv = $self->io->read($how_much); |
199
|
|
|
|
|
|
|
$self->log_trace("read_input($how_much) = ".bytes::length($rv)); |
200
|
|
|
|
|
|
|
return $rv; |
201
|
|
|
|
|
|
|
} |
202
|
|
|
|
|
|
|
|
203
|
|
|
|
|
|
|
method input_ready() { |
204
|
|
|
|
|
|
|
!!$self->io->peek(1); |
205
|
|
|
|
|
|
|
} |
206
|
|
|
|
|
|
|
|
207
|
|
|
|
|
|
|
# convert input packets to messages |
208
|
|
|
|
|
|
|
method input_packet( Str $data ) { |
209
|
|
|
|
|
|
|
$self->log_debug("parsing ".bytes::length($data)." bytes of XML"); |
210
|
|
|
|
|
|
|
my $msg = eval { |
211
|
|
|
|
|
|
|
if ( ! utf8::is_utf8($data) ) { |
212
|
|
|
|
|
|
|
my $pre_length = bytes::length($data); |
213
|
|
|
|
|
|
|
$data = decode("utf8", $data); |
214
|
|
|
|
|
|
|
my $post_length = length($data); |
215
|
|
|
|
|
|
|
if ( $pre_length != $post_length ) { |
216
|
|
|
|
|
|
|
$self->log_debug( |
217
|
|
|
|
|
|
|
"data is $post_length unicode characters" |
218
|
|
|
|
|
|
|
); |
219
|
|
|
|
|
|
|
} |
220
|
|
|
|
|
|
|
} |
221
|
|
|
|
|
|
|
$self->log_packet("input", $data); |
222
|
|
|
|
|
|
|
XML::EPP->parse($data); |
223
|
|
|
|
|
|
|
}; |
224
|
|
|
|
|
|
|
my $error = ( $msg ? undef : $@ ); |
225
|
|
|
|
|
|
|
$self->log_info("error parsing message: $error") |
226
|
|
|
|
|
|
|
if $error; |
227
|
|
|
|
|
|
|
my $queue_item = SRS::EPP::Command->new( |
228
|
|
|
|
|
|
|
( $msg ? (message => $msg) : () ), |
229
|
|
|
|
|
|
|
xml => $data, |
230
|
|
|
|
|
|
|
( $error ? (error => $error) : () ), |
231
|
|
|
|
|
|
|
session => $self, |
232
|
|
|
|
|
|
|
); |
233
|
|
|
|
|
|
|
$self->log_info("queuing command: $queue_item"); |
234
|
|
|
|
|
|
|
$self->queue_command($queue_item); |
235
|
|
|
|
|
|
|
if ( $error ) { |
236
|
|
|
|
|
|
|
my $error_rs = SRS::EPP::Response::Error->new( |
237
|
|
|
|
|
|
|
client_id => $queue_item->client_id, |
238
|
|
|
|
|
|
|
server_id => $self->new_server_id, |
239
|
|
|
|
|
|
|
code => 2001, |
240
|
|
|
|
|
|
|
exception => $error, |
241
|
|
|
|
|
|
|
); |
242
|
|
|
|
|
|
|
$self->log_info("queuing response: $error_rs"); |
243
|
|
|
|
|
|
|
# insert a dummy command which returns a 2001 |
244
|
|
|
|
|
|
|
# response |
245
|
|
|
|
|
|
|
$self->add_command_response( |
246
|
|
|
|
|
|
|
$error_rs, |
247
|
|
|
|
|
|
|
$queue_item, |
248
|
|
|
|
|
|
|
); |
249
|
|
|
|
|
|
|
$self->yield("send_pending_replies"); |
250
|
|
|
|
|
|
|
} |
251
|
|
|
|
|
|
|
else { |
252
|
|
|
|
|
|
|
$self->yield("process_queue"); |
253
|
|
|
|
|
|
|
} |
254
|
|
|
|
|
|
|
} |
255
|
|
|
|
|
|
|
|
256
|
|
|
|
|
|
|
#---- |
257
|
|
|
|
|
|
|
# queues |
258
|
|
|
|
|
|
|
has 'processing_queue' => |
259
|
|
|
|
|
|
|
default => sub { |
260
|
|
|
|
|
|
|
my $self = shift; |
261
|
|
|
|
|
|
|
SRS::EPP::Session::CmdQ->new(); |
262
|
|
|
|
|
|
|
}, |
263
|
|
|
|
|
|
|
handles => [qw( queue_command next_command |
264
|
|
|
|
|
|
|
add_command_response commands_queued |
265
|
|
|
|
|
|
|
response_ready dequeue_response )], |
266
|
|
|
|
|
|
|
; |
267
|
|
|
|
|
|
|
|
268
|
|
|
|
|
|
|
has 'backend_queue' => |
269
|
|
|
|
|
|
|
default => sub { |
270
|
|
|
|
|
|
|
my $self = shift; |
271
|
|
|
|
|
|
|
SRS::EPP::Session::BackendQ->new(); |
272
|
|
|
|
|
|
|
}, |
273
|
|
|
|
|
|
|
handles => [qw( queue_backend_request backend_next |
274
|
|
|
|
|
|
|
backend_pending |
275
|
|
|
|
|
|
|
add_backend_response backend_response_ready |
276
|
|
|
|
|
|
|
dequeue_backend_response ) ], |
277
|
|
|
|
|
|
|
; |
278
|
|
|
|
|
|
|
|
279
|
|
|
|
|
|
|
# this shouldn't be required... but is a good checklist |
280
|
|
|
|
|
|
|
method check_queues() { |
281
|
|
|
|
|
|
|
$self->yield("send_pending_replies") |
282
|
|
|
|
|
|
|
if $self->response_ready; |
283
|
|
|
|
|
|
|
$self->yield("process_queue") |
284
|
|
|
|
|
|
|
if !$self->stalled and $self->commands_queued; |
285
|
|
|
|
|
|
|
$self->yield("process_responses") |
286
|
|
|
|
|
|
|
if $self->backend_response_ready; |
287
|
|
|
|
|
|
|
$self->yield("send_backend_queue") |
288
|
|
|
|
|
|
|
if $self->backend_pending; |
289
|
|
|
|
|
|
|
} |
290
|
|
|
|
|
|
|
|
291
|
|
|
|
|
|
|
# "stalling" means that no more processing can be advanced until the |
292
|
|
|
|
|
|
|
# responses to the currently processing commands are available. |
293
|
|
|
|
|
|
|
# |
294
|
|
|
|
|
|
|
# eg, "login" and "logout" both stall the queue, as will the |
295
|
|
|
|
|
|
|
# <transform><renew> command, if we have to first query the back-end |
296
|
|
|
|
|
|
|
# to determine what the correct renewal message is. |
297
|
|
|
|
|
|
|
has stalled => |
298
|
|
|
|
|
|
|
is => "rw", |
299
|
|
|
|
|
|
|
isa => "Bool", |
300
|
|
|
|
|
|
|
trigger => sub { |
301
|
|
|
|
|
|
|
my $self = shift; |
302
|
|
|
|
|
|
|
my $val = shift; |
303
|
|
|
|
|
|
|
$self->log_debug( |
304
|
|
|
|
|
|
|
"processing queue is ".($val?"":"un-")."stalled" |
305
|
|
|
|
|
|
|
); |
306
|
|
|
|
|
|
|
if ( !$val ) { |
307
|
|
|
|
|
|
|
$self->check_queues; |
308
|
|
|
|
|
|
|
} |
309
|
|
|
|
|
|
|
} |
310
|
|
|
|
|
|
|
; |
311
|
|
|
|
|
|
|
|
312
|
|
|
|
|
|
|
method process_queue( Int $count = 1 ) { |
313
|
|
|
|
|
|
|
while ( $count-- > 0 ) { |
314
|
|
|
|
|
|
|
if ( $self->stalled ) { |
315
|
|
|
|
|
|
|
$self->state("Processing Command"); |
316
|
|
|
|
|
|
|
$self->log_trace("stalled; not processing"); |
317
|
|
|
|
|
|
|
last; |
318
|
|
|
|
|
|
|
} |
319
|
|
|
|
|
|
|
my $command = $self->next_command or last; |
320
|
|
|
|
|
|
|
$self->log_info( |
321
|
|
|
|
|
|
|
"processing command $command" |
322
|
|
|
|
|
|
|
); |
323
|
|
|
|
|
|
|
if ( $command->simple ) { |
324
|
|
|
|
|
|
|
# "simple" commands include "hello" and "logout" |
325
|
|
|
|
|
|
|
my $response = $command->process($self); |
326
|
|
|
|
|
|
|
$self->log_debug( |
327
|
|
|
|
|
|
|
"processed simple command $command; response is $response" |
328
|
|
|
|
|
|
|
); |
329
|
|
|
|
|
|
|
$self->add_command_response($response, $command); |
330
|
|
|
|
|
|
|
} |
331
|
|
|
|
|
|
|
elsif ( $command->authenticated xor $self->user ) { |
332
|
|
|
|
|
|
|
$self->add_command_response( |
333
|
|
|
|
|
|
|
$command->make_response( |
334
|
|
|
|
|
|
|
Error => code => 2001, |
335
|
|
|
|
|
|
|
), |
336
|
|
|
|
|
|
|
$command, |
337
|
|
|
|
|
|
|
); |
338
|
|
|
|
|
|
|
$self->log_info( |
339
|
|
|
|
|
|
|
"rejecting command: ".($self->user?"already":"not")." logged in" |
340
|
|
|
|
|
|
|
); |
341
|
|
|
|
|
|
|
} |
342
|
|
|
|
|
|
|
else { |
343
|
|
|
|
|
|
|
# regular message which may need to talk to the SRS backend |
344
|
|
|
|
|
|
|
my @messages = $command->process($self); |
345
|
|
|
|
|
|
|
|
346
|
|
|
|
|
|
|
# check what kind of messages these are |
347
|
|
|
|
|
|
|
if ( $messages[0]->does('XML::SRS::Action') or $messages[0]->does('XML::SRS::Query') ) { |
348
|
|
|
|
|
|
|
@messages = map { |
349
|
|
|
|
|
|
|
SRS::EPP::SRSRequest->new( |
350
|
|
|
|
|
|
|
message => $_, |
351
|
|
|
|
|
|
|
); |
352
|
|
|
|
|
|
|
} @messages; |
353
|
|
|
|
|
|
|
$self->log_info( |
354
|
|
|
|
|
|
|
"command produced ".@messages." SRS messages" |
355
|
|
|
|
|
|
|
); |
356
|
|
|
|
|
|
|
$self->queue_backend_request($command, @messages); |
357
|
|
|
|
|
|
|
if ( $command->isa("SRS::EPP::Command::Login") ) { |
358
|
|
|
|
|
|
|
$self->state("Processing <login>"); |
359
|
|
|
|
|
|
|
#$self->stalled(1); |
360
|
|
|
|
|
|
|
} |
361
|
|
|
|
|
|
|
else { |
362
|
|
|
|
|
|
|
$self->state("Processing Command"); |
363
|
|
|
|
|
|
|
} |
364
|
|
|
|
|
|
|
$self->yield("send_backend_queue"); |
365
|
|
|
|
|
|
|
} |
366
|
|
|
|
|
|
|
elsif ( $messages[0]->isa('XML::EPP') ) { |
367
|
|
|
|
|
|
|
# add these messages to the outgoing queue |
368
|
|
|
|
|
|
|
@messages = map { |
369
|
|
|
|
|
|
|
SRS::EPP::EPPResponse->new( |
370
|
|
|
|
|
|
|
message => $_, |
371
|
|
|
|
|
|
|
); |
372
|
|
|
|
|
|
|
} @messages; |
373
|
|
|
|
|
|
|
|
374
|
|
|
|
|
|
|
# add to the queue |
375
|
|
|
|
|
|
|
$self->add_command_response($_, $command) |
376
|
|
|
|
|
|
|
for @messages; |
377
|
|
|
|
|
|
|
} |
378
|
|
|
|
|
|
|
else { |
379
|
|
|
|
|
|
|
# not sure what these are |
380
|
|
|
|
|
|
|
die "Really shouldn't be here\n"; |
381
|
|
|
|
|
|
|
} |
382
|
|
|
|
|
|
|
} |
383
|
|
|
|
|
|
|
$self->yield("send_pending_replies") |
384
|
|
|
|
|
|
|
if $self->response_ready; |
385
|
|
|
|
|
|
|
} |
386
|
|
|
|
|
|
|
} |
387
|
|
|
|
|
|
|
|
388
|
|
|
|
|
|
|
#---- |
389
|
|
|
|
|
|
|
# method to say "we're connected, so send a greeting"; if this class |
390
|
|
|
|
|
|
|
# were abstracted to not run over a stream transport then this would |
391
|
|
|
|
|
|
|
# be important. |
392
|
|
|
|
|
|
|
method connected() { |
393
|
|
|
|
|
|
|
$self->state("Prepare Greeting"); |
394
|
|
|
|
|
|
|
my $response = SRS::EPP::Response::Greeting->new( |
395
|
|
|
|
|
|
|
session => $self, |
396
|
|
|
|
|
|
|
); |
397
|
|
|
|
|
|
|
$self->log_info( |
398
|
|
|
|
|
|
|
"prepared greeting $response for ".$self->peerhost |
399
|
|
|
|
|
|
|
); |
400
|
|
|
|
|
|
|
my $socket_fd = $self->io->get_fd; |
401
|
|
|
|
|
|
|
$self->log_trace("setting up io event handlers for FD $socket_fd"); |
402
|
|
|
|
|
|
|
my $w = $self->event->io( |
403
|
|
|
|
|
|
|
desc => "input_event", |
404
|
|
|
|
|
|
|
fd => $socket_fd, |
405
|
|
|
|
|
|
|
poll => 'r', |
406
|
|
|
|
|
|
|
cb => sub { |
407
|
|
|
|
|
|
|
$self->log_trace("got input callback"); |
408
|
|
|
|
|
|
|
$self->input_event; |
409
|
|
|
|
|
|
|
}, |
410
|
|
|
|
|
|
|
timeout => 120, |
411
|
|
|
|
|
|
|
timeout_cb => sub { |
412
|
|
|
|
|
|
|
$self->log_trace("got input timeout event"); |
413
|
|
|
|
|
|
|
$self->input_timeout; |
414
|
|
|
|
|
|
|
}, |
415
|
|
|
|
|
|
|
); |
416
|
|
|
|
|
|
|
$self->input_event_watcher($w); |
417
|
|
|
|
|
|
|
|
418
|
|
|
|
|
|
|
$w = $self->event->io( |
419
|
|
|
|
|
|
|
desc => "output_event", |
420
|
|
|
|
|
|
|
fd => $socket_fd, |
421
|
|
|
|
|
|
|
poll => 'w', |
422
|
|
|
|
|
|
|
cb => sub { |
423
|
|
|
|
|
|
|
$self->output_event; |
424
|
|
|
|
|
|
|
}, |
425
|
|
|
|
|
|
|
timeout => 120, |
426
|
|
|
|
|
|
|
timeout_cb => sub { |
427
|
|
|
|
|
|
|
$self->log_trace("got output timeout event"); |
428
|
|
|
|
|
|
|
}, |
429
|
|
|
|
|
|
|
); |
430
|
|
|
|
|
|
|
$w->stop; |
431
|
|
|
|
|
|
|
$self->output_event_watcher($w); |
432
|
|
|
|
|
|
|
|
433
|
|
|
|
|
|
|
$self->send_reply($response); |
434
|
|
|
|
|
|
|
$self->state("Waiting for Client Authentication"); |
435
|
|
|
|
|
|
|
} |
436
|
|
|
|
|
|
|
|
437
|
|
|
|
|
|
|
#---- |
438
|
|
|
|
|
|
|
# Backend stuff. Perhaps this should all go in the BackendQ class. |
439
|
|
|
|
|
|
|
|
440
|
|
|
|
|
|
|
has 'backend_tx_max' => |
441
|
|
|
|
|
|
|
isa => "Int", |
442
|
|
|
|
|
|
|
is => "rw", |
443
|
|
|
|
|
|
|
default => 10, |
444
|
|
|
|
|
|
|
; |
445
|
|
|
|
|
|
|
|
446
|
|
|
|
|
|
|
has 'user_agent' => |
447
|
|
|
|
|
|
|
is => "rw", |
448
|
|
|
|
|
|
|
lazy => 1, |
449
|
|
|
|
|
|
|
default => sub { |
450
|
|
|
|
|
|
|
my $self = shift; |
451
|
|
|
|
|
|
|
my $ua = SRS::EPP::Proxy::UA->new(session => $self); |
452
|
|
|
|
|
|
|
$self->log_trace("setting up UA input event"); |
453
|
|
|
|
|
|
|
my $w; |
454
|
|
|
|
|
|
|
$w = $self->event->io( |
455
|
|
|
|
|
|
|
desc => "user_agent", |
456
|
|
|
|
|
|
|
fd => $ua->read_fh, |
457
|
|
|
|
|
|
|
poll => 'r', |
458
|
|
|
|
|
|
|
cb => sub { |
459
|
|
|
|
|
|
|
if ( $self->user_agent ) { |
460
|
|
|
|
|
|
|
$self->log_trace("UA input event fired, calling backend_response"); |
461
|
|
|
|
|
|
|
$self->backend_response; |
462
|
|
|
|
|
|
|
} |
463
|
|
|
|
|
|
|
else { |
464
|
|
|
|
|
|
|
$self->log_trace("canceling UA watcher"); |
465
|
|
|
|
|
|
|
$w->cancel; |
466
|
|
|
|
|
|
|
} |
467
|
|
|
|
|
|
|
}, |
468
|
|
|
|
|
|
|
); |
469
|
|
|
|
|
|
|
$ua; |
470
|
|
|
|
|
|
|
}, |
471
|
|
|
|
|
|
|
handles => { |
472
|
|
|
|
|
|
|
"user_agent_busy" => "busy", |
473
|
|
|
|
|
|
|
}, |
474
|
|
|
|
|
|
|
; |
475
|
|
|
|
|
|
|
|
476
|
|
|
|
|
|
|
has 'backend_url' => |
477
|
|
|
|
|
|
|
isa => "Str", |
478
|
|
|
|
|
|
|
is => "rw", |
479
|
|
|
|
|
|
|
required => 1, |
480
|
|
|
|
|
|
|
; |
481
|
|
|
|
|
|
|
|
482
|
|
|
|
|
|
|
has 'active_request' => |
483
|
|
|
|
|
|
|
is => "rw", |
484
|
|
|
|
|
|
|
isa => "Maybe[SRS::EPP::SRSMessage]", |
485
|
|
|
|
|
|
|
; |
486
|
|
|
|
|
|
|
|
487
|
|
|
|
|
|
|
method next_message() { |
488
|
|
|
|
|
|
|
my @next = $self->backend_next($self->backend_tx_max) |
489
|
|
|
|
|
|
|
or return; |
490
|
|
|
|
|
|
|
my $tx = XML::SRS::Request->new( |
491
|
|
|
|
|
|
|
version => "auto", |
492
|
|
|
|
|
|
|
requests => [ map { $_->message } @next ], |
493
|
|
|
|
|
|
|
); |
494
|
|
|
|
|
|
|
my $rq = SRS::EPP::SRSMessage->new( |
495
|
|
|
|
|
|
|
message => $tx, |
496
|
|
|
|
|
|
|
parts => \@next, |
497
|
|
|
|
|
|
|
); |
498
|
|
|
|
|
|
|
$self->log_info("creating a ".@next."-part SRS message"); |
499
|
|
|
|
|
|
|
if ( $self->log->is_debug ) { |
500
|
|
|
|
|
|
|
$self->log_debug("parts: @next"); |
501
|
|
|
|
|
|
|
} |
502
|
|
|
|
|
|
|
$self->active_request( $rq ); |
503
|
|
|
|
|
|
|
$rq; |
504
|
|
|
|
|
|
|
} |
505
|
|
|
|
|
|
|
|
506
|
|
|
|
|
|
|
method send_backend_queue() { |
507
|
|
|
|
|
|
|
return if $self->user_agent_busy; |
508
|
|
|
|
|
|
|
|
509
|
|
|
|
|
|
|
my $tx = $self->next_message; |
510
|
|
|
|
|
|
|
my $xml = $tx->to_xml; |
511
|
|
|
|
|
|
|
$self->log_packet( |
512
|
|
|
|
|
|
|
"backend request", |
513
|
|
|
|
|
|
|
$xml, |
514
|
|
|
|
|
|
|
); |
515
|
|
|
|
|
|
|
my $sig = $self->openpgp->detached_sign($xml); |
516
|
|
|
|
|
|
|
$self->log_debug("signed XML message - sig is ".$sig) |
517
|
|
|
|
|
|
|
if $self->log->is_debug; |
518
|
|
|
|
|
|
|
my $reg_id = $self->user; |
519
|
|
|
|
|
|
|
if ( !$reg_id ) { |
520
|
|
|
|
|
|
|
$reg_id = $self->want_user; |
521
|
|
|
|
|
|
|
} |
522
|
|
|
|
|
|
|
|
523
|
|
|
|
|
|
|
my $req = POST( |
524
|
|
|
|
|
|
|
$self->backend_url, |
525
|
|
|
|
|
|
|
[ |
526
|
|
|
|
|
|
|
r => $xml, |
527
|
|
|
|
|
|
|
s => $sig, |
528
|
|
|
|
|
|
|
n => $reg_id, |
529
|
|
|
|
|
|
|
], |
530
|
|
|
|
|
|
|
); |
531
|
|
|
|
|
|
|
$self->log_info( |
532
|
|
|
|
|
|
|
"posting to ".$self->backend_url." as registrar $reg_id" |
533
|
|
|
|
|
|
|
); |
534
|
|
|
|
|
|
|
|
535
|
|
|
|
|
|
|
$self->user_agent->request( $req ); |
536
|
|
|
|
|
|
|
} |
537
|
|
|
|
|
|
|
|
538
|
|
|
|
|
|
|
sub url_decode { |
539
|
|
|
|
|
|
|
my $url_encoded = shift; |
540
|
|
|
|
|
|
|
$url_encoded =~ tr{+}{ }; |
541
|
|
|
|
|
|
|
$url_encoded =~ s{%([0-9a-f]{2})}{chr(hex($1))}eg; |
542
|
|
|
|
|
|
|
return $url_encoded; |
543
|
|
|
|
|
|
|
} |
544
|
|
|
|
|
|
|
|
545
|
|
|
|
|
|
|
#---- |
546
|
|
|
|
|
|
|
# Dealing with backend responses |
547
|
|
|
|
|
|
|
method backend_response() { |
548
|
|
|
|
|
|
|
my $response = $self->user_agent->get_response; |
549
|
|
|
|
|
|
|
|
550
|
|
|
|
|
|
|
# urldecode response; split response from fields |
551
|
|
|
|
|
|
|
my $content = $response->content; |
552
|
|
|
|
|
|
|
|
553
|
|
|
|
|
|
|
$self->log_debug( |
554
|
|
|
|
|
|
|
"received ".bytes::length($content)." bytes of " |
555
|
|
|
|
|
|
|
."response from back-end" |
556
|
|
|
|
|
|
|
); |
557
|
|
|
|
|
|
|
|
558
|
|
|
|
|
|
|
my %fields = map { |
559
|
|
|
|
|
|
|
my ($key, $value) = split "=", $_, 2; |
560
|
|
|
|
|
|
|
($key, decode("utf8", url_decode($value))); |
561
|
|
|
|
|
|
|
} split "&", $content; |
562
|
|
|
|
|
|
|
|
563
|
|
|
|
|
|
|
# check signature |
564
|
|
|
|
|
|
|
$self->log_debug("verifying signature"); |
565
|
|
|
|
|
|
|
$self->openpgp->verify_detached($fields{r}, $fields{s}) |
566
|
|
|
|
|
|
|
or die "failed to verify BE response integrity"; |
567
|
|
|
|
|
|
|
|
568
|
|
|
|
|
|
|
# decode message |
569
|
|
|
|
|
|
|
$self->log_packet("BE response", $fields{r}); |
570
|
|
|
|
|
|
|
my $message = XML::SRS::Response->parse($fields{r}); |
571
|
|
|
|
|
|
|
my $rs_tx = SRS::EPP::SRSMessage->new( message => $message ); |
572
|
|
|
|
|
|
|
|
573
|
|
|
|
|
|
|
$self->be_response($rs_tx); |
574
|
|
|
|
|
|
|
|
575
|
|
|
|
|
|
|
# user agent is now free, perhaps more messages are waiting |
576
|
|
|
|
|
|
|
$self->yield("send_backend_queue") |
577
|
|
|
|
|
|
|
if $self->backend_pending; |
578
|
|
|
|
|
|
|
} |
579
|
|
|
|
|
|
|
|
580
|
|
|
|
|
|
|
method be_response( SRS::EPP::SRSMessage $rs_tx ) { |
581
|
|
|
|
|
|
|
my $request = $self->active_request; |
582
|
|
|
|
|
|
|
#$self->active_request(undef); |
583
|
|
|
|
|
|
|
my $rq_parts = $request->parts; |
584
|
|
|
|
|
|
|
my $rs_parts = $rs_tx->parts; |
585
|
|
|
|
|
|
|
$self->log_debug( |
586
|
|
|
|
|
|
|
"response from back-end has ".@$rs_parts." parts, " |
587
|
|
|
|
|
|
|
."active request ".@$rq_parts." parts" |
588
|
|
|
|
|
|
|
); |
589
|
|
|
|
|
|
|
if ( @$rs_parts < @$rq_parts and @$rs_parts == 1 and |
590
|
|
|
|
|
|
|
$rs_parts->[0]->message->isa("XML::SRS::Error") |
591
|
|
|
|
|
|
|
) { |
592
|
|
|
|
|
|
|
# this is a more fundamental type of error than others |
593
|
|
|
|
|
|
|
# ... 'extend' to the other messages |
594
|
|
|
|
|
|
|
@$rs_parts = ((@$rs_parts) x @$rq_parts); |
595
|
|
|
|
|
|
|
} |
596
|
|
|
|
|
|
|
(@$rq_parts == @$rs_parts) or do { |
597
|
|
|
|
|
|
|
die "rs parts != rq parts"; |
598
|
|
|
|
|
|
|
}; |
599
|
|
|
|
|
|
|
|
600
|
|
|
|
|
|
|
for (my $i = 0; $i <= $#$rq_parts; $i++ ) { |
601
|
|
|
|
|
|
|
$self->add_backend_response($rq_parts->[$i], $rs_parts->[$i]); |
602
|
|
|
|
|
|
|
} |
603
|
|
|
|
|
|
|
$self->yield("process_responses"); |
604
|
|
|
|
|
|
|
} |
605
|
|
|
|
|
|
|
|
606
|
|
|
|
|
|
|
method process_responses() { |
607
|
|
|
|
|
|
|
while ( $self->backend_response_ready ) { |
608
|
|
|
|
|
|
|
my ($cmd, @rs) = $self->dequeue_backend_response; |
609
|
|
|
|
|
|
|
$self->log_info("notifying command $cmd of back-end response"); |
610
|
|
|
|
|
|
|
my $resp = $cmd->notify(@rs); |
611
|
|
|
|
|
|
|
if ( $resp->isa("SRS::EPP::Response") ) { |
612
|
|
|
|
|
|
|
$self->log_info( "command $cmd is complete" ); |
613
|
|
|
|
|
|
|
$self->state("Prepare Response"); |
614
|
|
|
|
|
|
|
$self->log_debug( "response to $cmd is response $resp" ); |
615
|
|
|
|
|
|
|
$self->add_command_response($resp, $cmd); |
616
|
|
|
|
|
|
|
$self->yield("send_pending_replies") |
617
|
|
|
|
|
|
|
if $self->response_ready; |
618
|
|
|
|
|
|
|
} |
619
|
|
|
|
|
|
|
elsif ( $resp->isa("XML::SRS") ) { |
620
|
|
|
|
|
|
|
$self->log_info( "command $cmd not yet complete" ); |
621
|
|
|
|
|
|
|
my @messages = map { |
622
|
|
|
|
|
|
|
SRS::EPP::SRSRequest->new( |
623
|
|
|
|
|
|
|
message => $_, |
624
|
|
|
|
|
|
|
); |
625
|
|
|
|
|
|
|
} $resp; |
626
|
|
|
|
|
|
|
$self->log_info( |
627
|
|
|
|
|
|
|
"command $cmd produced ".@messages." further SRS messages" |
628
|
|
|
|
|
|
|
); |
629
|
|
|
|
|
|
|
$self->queue_backend_request($cmd, @messages); |
630
|
|
|
|
|
|
|
$self->yield("send_backend_queue"); |
631
|
|
|
|
|
|
|
} |
632
|
|
|
|
|
|
|
} |
633
|
|
|
|
|
|
|
} |
634
|
|
|
|
|
|
|
|
635
|
|
|
|
|
|
|
method send_pending_replies() { |
636
|
|
|
|
|
|
|
while ( $self->response_ready ) { |
637
|
|
|
|
|
|
|
my $response = $self->dequeue_response; |
638
|
|
|
|
|
|
|
$self->log_info( |
639
|
|
|
|
|
|
|
"queuing response $response" |
640
|
|
|
|
|
|
|
); |
641
|
|
|
|
|
|
|
$self->send_reply($response); |
642
|
|
|
|
|
|
|
} |
643
|
|
|
|
|
|
|
if ( ! $self->commands_queued ) { |
644
|
|
|
|
|
|
|
if ( $self->user ) { |
645
|
|
|
|
|
|
|
$self->state("Waiting for Command"); |
646
|
|
|
|
|
|
|
} |
647
|
|
|
|
|
|
|
else { |
648
|
|
|
|
|
|
|
$self->state("Waiting for Client Authentication"); |
649
|
|
|
|
|
|
|
} |
650
|
|
|
|
|
|
|
} |
651
|
|
|
|
|
|
|
} |
652
|
|
|
|
|
|
|
|
653
|
|
|
|
|
|
|
#---- |
654
|
|
|
|
|
|
|
# Sending responses back |
655
|
|
|
|
|
|
|
has 'output_queue' => |
656
|
|
|
|
|
|
|
is => "ro", |
657
|
|
|
|
|
|
|
isa => "ArrayRef[Str]", |
658
|
|
|
|
|
|
|
default => sub { [] }, |
659
|
|
|
|
|
|
|
; |
660
|
|
|
|
|
|
|
|
661
|
|
|
|
|
|
|
method send_reply( SRS::EPP::Response $rs ) { |
662
|
|
|
|
|
|
|
$self->log_debug( |
663
|
|
|
|
|
|
|
"converting response $rs to XML" |
664
|
|
|
|
|
|
|
); |
665
|
|
|
|
|
|
|
my $reply_data = $rs->to_xml; |
666
|
|
|
|
|
|
|
$self->log_packet("output", $reply_data); |
667
|
|
|
|
|
|
|
if ( utf8::is_utf8($reply_data) ) { |
668
|
|
|
|
|
|
|
$reply_data = encode("utf8", $reply_data); |
669
|
|
|
|
|
|
|
} |
670
|
|
|
|
|
|
|
$self->log_info( |
671
|
|
|
|
|
|
|
"response $rs is ".bytes::length($reply_data) |
672
|
|
|
|
|
|
|
." bytes long" |
673
|
|
|
|
|
|
|
); |
674
|
|
|
|
|
|
|
my $length = pack("N", bytes::length($reply_data)+4); |
675
|
|
|
|
|
|
|
push @{ $self->output_queue }, $length, $reply_data; |
676
|
|
|
|
|
|
|
$self->yield("output_event"); |
677
|
|
|
|
|
|
|
my $remaining = 0; |
678
|
|
|
|
|
|
|
for ( @{ $self->output_queue }) { |
679
|
|
|
|
|
|
|
$remaining += bytes::length; |
680
|
|
|
|
|
|
|
} |
681
|
|
|
|
|
|
|
return $remaining; |
682
|
|
|
|
|
|
|
} |
683
|
|
|
|
|
|
|
|
684
|
|
|
|
|
|
|
# once we are "shutdown", no new commands will be allowed to process |
685
|
|
|
|
|
|
|
# (stalled queue) and the connection will be disconnected once the |
686
|
|
|
|
|
|
|
# back-end processing and output queue is cleared. |
687
|
|
|
|
|
|
|
has 'shutting_down' => |
688
|
|
|
|
|
|
|
is => "rw", |
689
|
|
|
|
|
|
|
isa => "Bool", |
690
|
|
|
|
|
|
|
; |
691
|
|
|
|
|
|
|
method shutdown() { |
692
|
|
|
|
|
|
|
$self->log_info( "shutting down session" ); |
693
|
|
|
|
|
|
|
$self->state("Shutting down"); |
694
|
|
|
|
|
|
|
$self->stalled(1); |
695
|
|
|
|
|
|
|
$self->shutting_down(1); |
696
|
|
|
|
|
|
|
$self->yield("output_event"); |
697
|
|
|
|
|
|
|
} |
698
|
|
|
|
|
|
|
|
699
|
|
|
|
|
|
|
method input_timeout() { |
700
|
|
|
|
|
|
|
# just hang up... |
701
|
|
|
|
|
|
|
$self->shutdown; |
702
|
|
|
|
|
|
|
} |
703
|
|
|
|
|
|
|
|
704
|
|
|
|
|
|
|
method do_close() { |
705
|
|
|
|
|
|
|
# hang up on us without logging out will you? Well, we'll |
706
|
|
|
|
|
|
|
# just have to close your TCP session without properly closing |
707
|
|
|
|
|
|
|
# SSL. Take that. |
708
|
|
|
|
|
|
|
$self->log_debug( "shutting down Socket" ); |
709
|
|
|
|
|
|
|
$self->socket->shutdown(1); |
710
|
|
|
|
|
|
|
$self->log_debug( "shutting down user agent" ); |
711
|
|
|
|
|
|
|
$self->user_agent(undef); |
712
|
|
|
|
|
|
|
$self->input_event_watcher->cancel; |
713
|
|
|
|
|
|
|
$self->event->unloop_all; |
714
|
|
|
|
|
|
|
} |
715
|
|
|
|
|
|
|
|
716
|
|
|
|
|
|
|
# called when input_event fires, but nothing is readable. |
717
|
|
|
|
|
|
|
method empty_read() { |
718
|
|
|
|
|
|
|
$self->log_info( "detected EOF on input" ); |
719
|
|
|
|
|
|
|
$self->do_close; |
720
|
|
|
|
|
|
|
} |
721
|
|
|
|
|
|
|
|
722
|
|
|
|
|
|
|
method output_event() { |
723
|
|
|
|
|
|
|
my $oq = $self->output_queue; |
724
|
|
|
|
|
|
|
my $written = 0; |
725
|
|
|
|
|
|
|
my $io = $self->io; |
726
|
|
|
|
|
|
|
while ( @$oq ) { |
727
|
|
|
|
|
|
|
my $datum = shift @$oq; |
728
|
|
|
|
|
|
|
my $wrote = $io->write( $datum ); |
729
|
|
|
|
|
|
|
if ( $wrote <= 0 ) { |
730
|
|
|
|
|
|
|
$self->log_debug("error on write? \$! = $!"); |
731
|
|
|
|
|
|
|
unshift @$oq, $datum; |
732
|
|
|
|
|
|
|
last; |
733
|
|
|
|
|
|
|
} |
734
|
|
|
|
|
|
|
else { |
735
|
|
|
|
|
|
|
$written += $wrote; # thankfully, this is returned in bytes. |
736
|
|
|
|
|
|
|
if ( $wrote < bytes::length $datum ) { |
737
|
|
|
|
|
|
|
unshift @$oq, bytes::substr $datum, $wrote; |
738
|
|
|
|
|
|
|
last; |
739
|
|
|
|
|
|
|
} |
740
|
|
|
|
|
|
|
} |
741
|
|
|
|
|
|
|
} |
742
|
|
|
|
|
|
|
$self->log_trace( |
743
|
|
|
|
|
|
|
"output_event wrote $written bytes, ".@$oq." chunk(s) remaining" |
744
|
|
|
|
|
|
|
); |
745
|
|
|
|
|
|
|
if ( @$oq ) { |
746
|
|
|
|
|
|
|
$self->output_event_watcher->start; |
747
|
|
|
|
|
|
|
} |
748
|
|
|
|
|
|
|
else { |
749
|
|
|
|
|
|
|
$self->output_event_watcher->stop; |
750
|
|
|
|
|
|
|
$self->log_info("flushed output to client"); |
751
|
|
|
|
|
|
|
if ( $self->shutting_down ) { |
752
|
|
|
|
|
|
|
$self->check_queues; |
753
|
|
|
|
|
|
|
# if check_queues didn't yield any events, we're done. |
754
|
|
|
|
|
|
|
if ( !keys %{$self->yielding} ) { |
755
|
|
|
|
|
|
|
$self->do_close; |
756
|
|
|
|
|
|
|
} |
757
|
|
|
|
|
|
|
else { |
758
|
|
|
|
|
|
|
$self->log_debug( |
759
|
|
|
|
|
|
|
"shutdown still pending: @{[keys %{$self->yielding}]}" |
760
|
|
|
|
|
|
|
); |
761
|
|
|
|
|
|
|
} |
762
|
|
|
|
|
|
|
} |
763
|
|
|
|
|
|
|
} |
764
|
|
|
|
|
|
|
return $written; |
765
|
|
|
|
|
|
|
} |
766
|
|
|
|
|
|
|
|
767
|
|
|
|
|
|
|
method log_packet(Str $label, Str $data) { |
768
|
|
|
|
|
|
|
$data =~ s{([\0-\037])}{chr(ord($1)+0x2400)}eg; |
769
|
|
|
|
|
|
|
$data =~ s{([,\|])}{chr(ord($1)+0xff00-0x20)}eg; |
770
|
|
|
|
|
|
|
my @data; |
771
|
|
|
|
|
|
|
while ( length $data ) { |
772
|
|
|
|
|
|
|
push @data, substr $data, 0, 1024, ""; |
773
|
|
|
|
|
|
|
} |
774
|
|
|
|
|
|
|
for (my $i = 0; $i <= $#data; $i++ ) { |
775
|
|
|
|
|
|
|
my $n_of_n = (@data > 1 ? " [".($i+1)." of ".@data."]" : ""); |
776
|
|
|
|
|
|
|
$self->log_info( |
777
|
|
|
|
|
|
|
"$label message$n_of_n: " |
778
|
|
|
|
|
|
|
.encode("utf8", $data[$i]), |
779
|
|
|
|
|
|
|
); |
780
|
|
|
|
|
|
|
} |
781
|
|
|
|
|
|
|
} |
782
|
|
|
|
|
|
|
1; |
783
|
|
|
|
|
|
|
|
784
|
|
|
|
|
|
|
__END__ |
785
|
|
|
|
|
|
|
|
786
|
|
|
|
|
|
|
=head1 NAME |
787
|
|
|
|
|
|
|
|
788
|
|
|
|
|
|
|
SRS::EPP::Session - logic for EPP Session State machine |
789
|
|
|
|
|
|
|
|
790
|
|
|
|
|
|
|
=head1 SYNOPSIS |
791
|
|
|
|
|
|
|
|
792
|
|
|
|
|
|
|
my $session = SRS::EPP::Session->new( io => $socket ); |
793
|
|
|
|
|
|
|
|
794
|
|
|
|
|
|
|
#--- session events: |
795
|
|
|
|
|
|
|
|
796
|
|
|
|
|
|
|
$session->connected; |
797
|
|
|
|
|
|
|
$session->input_event; |
798
|
|
|
|
|
|
|
$session->input_packet($data); |
799
|
|
|
|
|
|
|
$session->queue_command($command); |
800
|
|
|
|
|
|
|
$session->process_queue($count); |
801
|
|
|
|
|
|
|
$session->be_response($srs_rs); |
802
|
|
|
|
|
|
|
$session->send_pending_replies(); |
803
|
|
|
|
|
|
|
$session->send_reply($response); |
804
|
|
|
|
|
|
|
$session->output_event; |
805
|
|
|
|
|
|
|
|
806
|
|
|
|
|
|
|
#--- information messages: |
807
|
|
|
|
|
|
|
|
808
|
|
|
|
|
|
|
# print RFC3730 state eg 'Waiting for Client', |
809
|
|
|
|
|
|
|
# 'Prepare Greeting' (see Page 4 of RFC3730) |
810
|
|
|
|
|
|
|
print $session->state; |
811
|
|
|
|
|
|
|
|
812
|
|
|
|
|
|
|
# return the credential used for login |
813
|
|
|
|
|
|
|
print $session->user; |
814
|
|
|
|
|
|
|
|
815
|
|
|
|
|
|
|
=head1 DESCRIPTION |
816
|
|
|
|
|
|
|
|
817
|
|
|
|
|
|
|
The SRS::EPP::Session class manages the flow of individual |
818
|
|
|
|
|
|
|
connections. It implements the "EPP Server State Machine" from |
819
|
|
|
|
|
|
|
RFC3730, as well as the exchange encapsulation described in RFC3734 |
820
|
|
|
|
|
|
|
"EPP TCP Transport". |
821
|
|
|
|
|
|
|
|
822
|
|
|
|
|
|
|
This class is designed to be called from within an event-based |
823
|
|
|
|
|
|
|
framework; this is fairly essential in the context of a server given |
824
|
|
|
|
|
|
|
the potential to deadlock if the client does not clear its responses |
825
|
|
|
|
|
|
|
in a timely fashion. |
826
|
|
|
|
|
|
|
|
827
|
|
|
|
|
|
|
Input commands go through several stages: |
828
|
|
|
|
|
|
|
|
829
|
|
|
|
|
|
|
=over |
830
|
|
|
|
|
|
|
|
831
|
|
|
|
|
|
|
=item * |
832
|
|
|
|
|
|
|
|
833
|
|
|
|
|
|
|
First, incoming data ready is chunked into complete EPP requests. |
834
|
|
|
|
|
|
|
This is a binary de-chunking, and is based on reading a packet length |
835
|
|
|
|
|
|
|
as a U32, then waiting for that many octets. See L</input_event> |
836
|
|
|
|
|
|
|
|
837
|
|
|
|
|
|
|
=item * |
838
|
|
|
|
|
|
|
|
839
|
|
|
|
|
|
|
Complete chunks are passed to the L<SRS::EPP::Command> constructor for |
840
|
|
|
|
|
|
|
validation and object construction. See L</input_packet> |
841
|
|
|
|
|
|
|
|
842
|
|
|
|
|
|
|
=item * |
843
|
|
|
|
|
|
|
|
844
|
|
|
|
|
|
|
The constructed object is triaged, and added to an appropriate |
845
|
|
|
|
|
|
|
processing queue. See L</queue_command> |
846
|
|
|
|
|
|
|
|
847
|
|
|
|
|
|
|
=item * |
848
|
|
|
|
|
|
|
|
849
|
|
|
|
|
|
|
The request is processed; either locally for requests such as |
850
|
|
|
|
|
|
|
C<E<gt>helloE<lt>>, or converted to the back-end format |
851
|
|
|
|
|
|
|
(L<SRS::Request>) and placed in the back-end queue (this is normally |
852
|
|
|
|
|
|
|
immediately dispatched). See L</process_queue> |
853
|
|
|
|
|
|
|
|
854
|
|
|
|
|
|
|
=item * |
855
|
|
|
|
|
|
|
|
856
|
|
|
|
|
|
|
The response (a L<SRS::Response> object) from the back-end is |
857
|
|
|
|
|
|
|
received; this is converted to a corresponding L<SRS::EPP::Response> |
858
|
|
|
|
|
|
|
object. Outstanding queued back-end requests are then dispatched if |
859
|
|
|
|
|
|
|
they are present (so each session has a maximum of one outstanding |
860
|
|
|
|
|
|
|
request at a time). See L</be_response> |
861
|
|
|
|
|
|
|
|
862
|
|
|
|
|
|
|
=item * |
863
|
|
|
|
|
|
|
|
864
|
|
|
|
|
|
|
Prepared L<SRS::EPP::Response> objects are queued, this involves |
865
|
|
|
|
|
|
|
individually converting them to strings, which are sent back to the |
866
|
|
|
|
|
|
|
client, each response its own SSL frame. See L</send_reply> |
867
|
|
|
|
|
|
|
|
868
|
|
|
|
|
|
|
=item * |
869
|
|
|
|
|
|
|
|
870
|
|
|
|
|
|
|
If the output blocks, then the responses wait and are sent back as |
871
|
|
|
|
|
|
|
the response queue clears. See L</output_event> |
872
|
|
|
|
|
|
|
|
873
|
|
|
|
|
|
|
=back |
874
|
|
|
|
|
|
|
|
875
|
|
|
|
|
|
|
=head1 METHODS |
876
|
|
|
|
|
|
|
|
877
|
|
|
|
|
|
|
=head2 connected() |
878
|
|
|
|
|
|
|
|
879
|
|
|
|
|
|
|
This event signals to the Session that the client is now connected. |
880
|
|
|
|
|
|
|
It signals that it is time to issue a C<E<gt>greetingE<lt>> response, |
881
|
|
|
|
|
|
|
just as if a C<E<gt>helloE<lt>> message had been received. |
882
|
|
|
|
|
|
|
|
883
|
|
|
|
|
|
|
=head2 input_event() |
884
|
|
|
|
|
|
|
|
885
|
|
|
|
|
|
|
This event is intended to be invoked whenever there is data ready to |
886
|
|
|
|
|
|
|
read on the input socket. It returns false if not enough data could |
887
|
|
|
|
|
|
|
be read to get a complete subpacket. |
888
|
|
|
|
|
|
|
|
889
|
|
|
|
|
|
|
=head2 input_packet($data) |
890
|
|
|
|
|
|
|
|
891
|
|
|
|
|
|
|
This message is self-fired with a complete packet of data once it has |
892
|
|
|
|
|
|
|
been read. |
893
|
|
|
|
|
|
|
|
894
|
|
|
|
|
|
|
=head2 queue_command($command) |
895
|
|
|
|
|
|
|
|
896
|
|
|
|
|
|
|
Enqueues an EPP command for processing and does nothing else. |
897
|
|
|
|
|
|
|
|
898
|
|
|
|
|
|
|
=head2 process_queue($count) |
899
|
|
|
|
|
|
|
|
900
|
|
|
|
|
|
|
Processes the back-end queue, up to C<$count> at a time. At the end |
901
|
|
|
|
|
|
|
of this, if there are no outstanding back-end transactions, any |
902
|
|
|
|
|
|
|
produced L<SRS::Request> objects are wrapped into an |
903
|
|
|
|
|
|
|
L<SRS::Transaction> object and dispatched to the back-end. |
904
|
|
|
|
|
|
|
|
905
|
|
|
|
|
|
|
Returns the number of commands remaining to process. |
906
|
|
|
|
|
|
|
|
907
|
|
|
|
|
|
|
=head2 be_response($srs_rs) |
908
|
|
|
|
|
|
|
|
909
|
|
|
|
|
|
|
This is fired when a back-end response is received. It is responsible |
910
|
|
|
|
|
|
|
for matching responses with commands in the command queue and |
911
|
|
|
|
|
|
|
converting to L<SRS::EPP::Response> objects. |
912
|
|
|
|
|
|
|
|
913
|
|
|
|
|
|
|
=head2 send_pending_replies() |
914
|
|
|
|
|
|
|
|
915
|
|
|
|
|
|
|
This is called by process_queue() or be_response(), and checks each |
916
|
|
|
|
|
|
|
command for a corresponding L<SRS::EPP::Response> object, dequeues and |
917
|
|
|
|
|
|
|
starts to send them back. |
918
|
|
|
|
|
|
|
|
919
|
|
|
|
|
|
|
=head2 send_reply($response) |
920
|
|
|
|
|
|
|
|
921
|
|
|
|
|
|
|
This is called by send_pending_replies(), and converts a |
922
|
|
|
|
|
|
|
L<SRS::EPP::Response> object to network form, then starts to send it. |
923
|
|
|
|
|
|
|
Returns the total number of octets which are currently outstanding; if |
924
|
|
|
|
|
|
|
this is non-zero, the caller is expected to watch the output socket |
925
|
|
|
|
|
|
|
for writability and call L<output_event()> once it is writable. |
926
|
|
|
|
|
|
|
|
927
|
|
|
|
|
|
|
=head2 output_event() |
928
|
|
|
|
|
|
|
|
929
|
|
|
|
|
|
|
This event is intended to be called when the return socket is newly |
930
|
|
|
|
|
|
|
writable; it writes everything it can to the output socket and returns |
931
|
|
|
|
|
|
|
the number of bytes written. |
932
|
|
|
|
|
|
|
|
933
|
|
|
|
|
|
|
=head1 SEE ALSO |
934
|
|
|
|
|
|
|
|
935
|
|
|
|
|
|
|
L<SRS::EPP::Command>, L<SRS::EPP::Response> |
936
|
|
|
|
|
|
|
|
937
|
|
|
|
|
|
|
=cut |
938
|
|
|
|
|
|
|
|
939
|
|
|
|
|
|
|
# Local Variables: |
940
|
|
|
|
|
|
|
# mode:cperl |
941
|
|
|
|
|
|
|
# indent-tabs-mode: t |
942
|
|
|
|
|
|
|
# cperl-continued-statement-offset: 8 |
943
|
|
|
|
|
|
|
# cperl-brace-offset: 0 |
944
|
|
|
|
|
|
|
# cperl-close-paren-offset: 0 |
945
|
|
|
|
|
|
|
# cperl-continued-brace-offset: 0 |
946
|
|
|
|
|
|
|
# cperl-continued-statement-offset: 8 |
947
|
|
|
|
|
|
|
# cperl-extra-newline-before-brace: nil |
948
|
|
|
|
|
|
|
# cperl-indent-level: 8 |
949
|
|
|
|
|
|
|
# cperl-indent-parens-as-block: t |
950
|
|
|
|
|
|
|
# cperl-indent-wrt-brace: nil |
951
|
|
|
|
|
|
|
# cperl-label-offset: -8 |
952
|
|
|
|
|
|
|
# cperl-merge-trailing-else: t |
953
|
|
|
|
|
|
|
# End: |
954
|
|
|
|
|
|
|
|