fix warning
[perl-cwmp.git] / lib / CWMP / Session.pm
1 # Dobrica Pavlinusic, <dpavlin@rot13.org> 06/18/07 10:19:50 CEST
2 package CWMP::Session;
3
4 use strict;
5 use warnings;
6
7 use base qw/Class::Accessor/;
8 __PACKAGE__->mk_accessors( qw/
9 debug
10 create_dump
11 session
12
13 sock
14 state
15 store
16 / );
17
18 use Data::Dump qw/dump/;
19 use Carp qw/carp confess cluck croak/;
20
21 use CWMP::Parser;
22 use CWMP::Methods;
23 use CWMP::Store;
24
25 #use Devel::LeakTrace::Fast;
26
27 =head1 NAME
28
29 CWMP::Session - implement logic of CWMP protocol
30
31 =head1 METHODS
32
33 =head2 new
34
35   my $server = CWMP::Session->new({
36         sock => $io_socket_object,
37         store => { ... },
38         debug => 1,
39         create_dump => 1,
40   });
41
42 =cut
43
44 sub new {
45         my $class = shift;
46         my $self = $class->SUPER::new( @_ );
47
48         confess "need store" unless $self->store;
49
50         $self->debug( 0 ) unless $self->debug;
51
52         my $store_obj = CWMP::Store->new({
53                 debug => $self->debug,
54                 %{ $self->store },
55         });
56
57         croak "can't open ", dump( $self->store ), ": $!" unless $store_obj;
58
59         # FIXME looks ugly. Should we have separate accessor for this?
60         $self->store( $store_obj );
61
62         $self->create_dump( 1 ) if $self->debug > 2;
63
64         return $self;
65 }
66
67 my $vendor_data = {
68  'InternetGatewayDevice.ManagementServer.PeriodicInformEnable' => 1,
69  'InternetGatewayDevice.ManagementServer.PeriodicInformInterval' => 17,
70  'InternetGatewayDevice.DeviceInfo.ProvisioningCode' => 'test provision',
71 };
72
73 our $set_tried;
74
75 sub vendor_hook {
76         my ( $self, $uid, $stored, $queue ) = @_;
77         warn "# vendor_hook $uid ",dump($stored) if $self->debug > 2;
78
79         my @refresh;
80
81         foreach my $n ( keys %$vendor_data ) {
82                 if ( defined $stored->{$n} && $vendor_data->{$n} ne $stored->{$n} ) {
83                         next if $set_tried->{$uid}->{$n}++;
84                         push @refresh, $n;
85                         $queue->enqueue( 'SetParameterValues', { $n => $vendor_data->{$n} } );
86                 }
87         }
88
89         if ( @refresh ) {
90                 $queue->enqueue( 'GetParameterValues', [ @refresh ] );
91                 warn "vendor_hook $uid SetParameterValues ", dump( @refresh );
92                 return $self->dispatch( 'GetParameterValues', [ @refresh ] );
93         }
94
95         return;
96 }
97
98 =head2 process_request
99
100 One request from client/response from server cycle. Call multiple times to
101 facilitate brain-dead concept of adding state to stateless protocol like
102 HTTP.
103
104 If used with debugging level of 3 or more, it will also create dumps of
105 requests named C<< dump/nr.request >> where C<nr> is number from 0 to total number
106 of requests in single session.
107
108 =cut
109
110
111 sub process_request {
112         my ( $self, $ip, $xml ) = @_;
113
114         my $size = length( $xml );
115
116         my $state;
117
118         if ( $size > 0 ) {
119
120                 warn "## request payload: ",length($xml)," bytes\n$xml\n" if $self->debug;
121
122                 $state = CWMP::Parser->parse( $xml );
123
124                 warn "## acquired state = ", dump( $state ), "\n" if $self->debug;
125
126                 if ( ! defined( $state->{DeviceId} ) ) {
127                         if ( $self->state ) {
128                                 warn "## state without DeviceId, using old one...\n";
129                                 $state->{DeviceId} = $self->state->{DeviceId};
130                         } else {
131                                 warn "WARNING: state without DeviceId, and I don't have old one!\n";
132                                 warn "## state = ",dump( $state );
133                         }
134                 }
135
136                 $self->state( $state );
137                 $self->store->update_state( $state );
138
139         } else {
140
141                 warn "## empty request, using last request state\n";
142
143                 $state = $self->state;
144                 delete( $state->{_dispatch} );
145                 #warn "last request state = ", dump( $state ), "\n" if $self->debug > 1;
146         }
147
148         my $uid = $self->store->state_to_uid( $state );
149
150         my $to_uid = join(" ", grep { defined($_) } "to $uid",
151                         # board
152                         $state->{Parameter}->{'InternetGatewayDevice.DeviceInfo.HardwareVersion'},
153                         # version
154                         $state->{Parameter}->{'InternetGatewayDevice.DeviceInfo.SoftwareVersion'},
155                         # summary
156 #                       $state->{Parameter}->{'InternetGatewayDevice.DeviceSummary'},
157         ) . "\n";
158
159         my $queue = CWMP::Queue->new({
160                 id => $uid,
161                 debug => $self->debug,
162         });
163         $xml = '';
164
165         if ( my $dispatch = $state->{_dispatch} ) {
166                 $xml = $self->dispatch( $dispatch );
167         } elsif ( my $job = $queue->dequeue ) {
168                 $xml = $self->dispatch( $job->dispatch );
169                 $job->finish;
170         } else {
171                 my $stored = $self->store->get_state( $uid );
172                 if ( ! defined $stored->{ParameterInfo} ) {
173                         $xml = $self->dispatch( 'GetParameterNames', [ 'InternetGatewayDevice.', 1 ] );
174                 } else {
175                         my @params =
176                                 grep { m/\.$/ && ! m/\.\d+\.$/ }
177                                 keys %{ $stored->{ParameterInfo} }
178                         ;
179                         if ( @params ) {
180                                 warn "# GetParameterNames ", dump( @params );
181                                 my $first = shift @params;
182                                 delete $stored->{ParameterInfo}->{$first};
183                                 $xml = $self->dispatch( 'GetParameterNames', [ $first, 1 ] );
184                                 foreach ( @params ) {
185                                         $queue->enqueue( 'GetParameterNames', [ $_, 1 ] );
186                                         delete $stored->{ParameterInfo}->{ $_ };
187                                 }
188                                 $self->store->set_state( $uid, $stored );
189                         } else {
190
191                                 my @params = sort
192                                         grep { ! exists $stored->{Parameter}->{$_} }
193                                         grep { ! m/\.$/ && ! m/NumberOfEntries/ }
194                                         keys %{ $stored->{ParameterInfo} }
195                                 ;
196                                 if ( @params ) {
197                                         warn "# GetParameterValues ", dump( @params );
198                                         my $first = shift @params;
199                                         $xml = $self->dispatch( 'GetParameterValues', [ $first ] );
200                                         while ( @params ) {
201                                                 my @chunk = splice @params, 0, 16; # FIXME 16 seems to be max
202                                                 $queue->enqueue( 'GetParameterValues', [ @chunk ] );
203                                         }
204
205                                 } elsif ( $xml = $self->vendor_hook( $uid, $stored, $queue ) ) {
206
207                                         warn "vendor_hook triggered\n";
208
209                                 } else {
210
211                                         warn ">>> empty response $to_uid";
212                                         $state->{NoMoreRequests} = 1;
213                                         $xml = '';
214
215                                 }
216                         }
217                 }
218         }
219
220         my $status = length($xml) ? 200 : 204;
221
222         my $out = join("\r\n",
223                 "HTTP/1.1 $status OK",
224                 'Content-Type: text/xml; charset="utf-8"',
225                 'Server: Perl-CWMP/42',
226                 'SOAPServer: Perl-CWMP/42'
227         ) . "\r\n";
228
229         $out .= "Set-Cookie: ID=" . $state->{ID} . "; path=/\r\n" if $state->{ID};
230
231         $out .= "Content-Length: " . length( $xml ) . "\r\n\r\n";
232         $out .= $xml if length($xml);
233
234         warn "### request over for $uid\n" if $self->debug;
235
236         return $out;    # next request
237 };
238
239 =head2 dispatch
240
241   $xml = $self->dispatch('Inform', $response_arguments );
242
243 If debugging level of 3 or more, it will create dumps of responses named C<< dump/nr.response >>
244
245 =cut
246
247 sub dispatch {
248         my $self = shift;
249
250         my $dispatch = shift || die "no dispatch?";
251         my $args = shift;
252
253         my $response = CWMP::Methods->new({ debug => $self->debug });
254
255         if ( $response->can( $dispatch ) ) {
256                 warn ">>> dispatching to $dispatch with args ",dump( $args ),"\n";
257                 my $xml = $response->$dispatch( $self->state, $args );
258                 warn "## response payload: ",length($xml)," bytes\n$xml\n" if $self->debug;
259                 return $xml;
260         } else {
261                 confess "can't dispatch to $dispatch";
262         }
263 };
264
265
266 =head2 error
267
268   return $self->error( 501, 'System error' );
269
270 =cut
271
272 sub error {
273   my ($self, $number, $msg) = @_;
274   $msg ||= 'ERROR';
275   $self->sock->send( "HTTP/1.1 $number $msg\r\n" );
276   warn "Error - $number - $msg\n";
277   return 0;     # close connection
278 }
279
280 1;