cwmp/google/acs.pl

#!/usr/bin/perl

use warnings;
use strict;

use lib 'lib';
use SOAP::Transport::HTTP +trace => 'debug';
use HTTP::Cookies;
use CGI::Simple::Cookie;
use Data::Dump qw/dump/;

#SOAP::Trace->import( 'all' );

# Eh...
$SOAP::Constants::DO_NOT_CHECK_MUSTUNDERSTAND = 1;

$SIG{PIPE} = $SIG{INT} = 'IGNORE'; # don't want to die on 'Broken pipe' or Ctrl-C

my $cwmp = new CWMP;

my $daemon = SOAP::Transport::HTTP::Daemon->new(
        #LocalAddr => 'localhost',
        LocalPort => 3333,
        Reuse => 1,
        #'Listen' => 128,
)
        ->dispatch_with({
                'urn:dslforum-org:cwmp-1-0' => $cwmp,
                'http://schemas.xmlsoap.org/soap/envelope/' => $cwmp,
        })
;

my $cookies = new CGI::Simple::Cookie(
        -name => 'foo',
        -value => 'bar',
);
$daemon->options->{simple_cookie} = $cookies;

$daemon->options->{empty_request} = sub {
        $cwmp->empty_request( @_ );
};

$cwmp->enqueue( qw/GetRPCMethods/ );

print "Contact to ACS server at ", $daemon->url, " queue ", dump( $cwmp->queue ),"\n";
$daemon->handle;

package CWMP;
use strict;

use Data::Dump qw/dump/;
use Carp qw/cluck/;

sub new {
        bless {}, shift;
}

# CPE methods             Responding  Calling
#
# GetRPCMethods           Required    Optional
# SetParameterValues      Required    Required
# GetParameterValues      Required    Required
# GetParameterNames       Required    Required
# SetParameterAttributes  Required    Optional
# GetParameterAttributes  Required    Optional
# AddObject               Required    Optional
# DeleteObject            Required    Optional
# Reboot                  Required    Optional
# Download                Required    Required
# Upload                  Optional    Optional
# FactoryReset            Optional    Optional
# GetQueuedTransfers      Optional    Optional
# ScheduleInform          Optional    Optional
# SetVouchers             Optional    Optional
# GetOptions              Optional    Optional

# Server methods   Calling    Responding
#
# GetRPCMethods    Optional   Required
# Inform           Required   Required
# TransferComplete Required   Required
# RequestDownload  Optional   Optional
# Kicked           Optional   Optional


my $ID;

my @queue;

sub enqueue {
        my $self = shift;
        push @queue, @_;
}

sub queue {
        my $self = shift;
        return @queue;
}

sub consume_queue {
        my @results = ( SOAP::Header->name('ID' => $ID)->prefix('cwmp')->mustUnderstand(1) );


        my $op = shift @queue;

        if ( $op ) {
                push @results, SOAP::Data->name( $op )->prefix('cwmp');
                warn "consume_queue $op\n";
        };

        push @results, SOAP::Header->name('NoMoreRequests' => 1)->prefix('cwmp') unless ( @queue );

        warn "## conqume_queue results = ", dump( @results );

        return @results;
}

## SOAP ACS methods

sub Inform {
        my ($self, $DeviceId, $Event, $MaxEnvelopes, $CurrentTime, $RetryCount, $ParameterList, $headers) = @_;

        my $p;

        #cluck dump( $daemon );
        #warn dump( $headers );

        $ID = ( grep { $_->name eq 'ID' } @$headers )[0]->value;

        foreach ( @$ParameterList ) {
                $p->{ $_->{Name} } = $_->{Value};
        }

        warn "request $ID from ", dump( $DeviceId ), " with events ",dump( $Event ), "maxEnvelopes: $MaxEnvelopes on $CurrentTime retry $RetryCount params ", dump( $p );

        return SOAP::Data->name('MaxEnvelopes' => 1);
}

sub GetParameterValuesResponse {
        my $self = shift;

        warn "GetParameterValuesResponse ",dump( @_ );

        return;
}

sub Fault {
        my $self = shift;

        warn "Fault ",dump( @_ );

        return;
}

## special handling of empty POST request from CPE

sub empty_request {

        my (undef, $self) = @_;

#       warn "empty_request headers = ",dump( $self->request->headers );

    $self->serializer->soapversion(SOAP::Lite->soapversion);
    $self->serializer->xmlschema($SOAP::Constants::DEFAULT_XML_SCHEMA);

        my @results = (
#               SOAP::Header->name('ID' => $ID)->prefix('cwmp')->mustUnderstand(1),
#               SOAP::Data->name('GetParameterValues' =>
#                       SOAP::Data->value( 'ParametarNames' => [
#                               'InternetGatewayDevice.ManagementServer.',
#                               'a.', 'a.b.', 'a.b.c.',
#                       ],
#                       ),
#               )->prefix('cwmp'),
        );


        push @results, ( consume_queue );

    my $result = $self->serializer
#      ->prefix('s') # distinguish generated element names between client and server
#      ->uri('urn:dslforum-org:cwmp-1-0')
          ->ns('urn:dslforum-org:cwmp-1-0', 'cwmp')
      ->envelope( freeform => @results );

        my $xml = $result;
        $xml =~ s/</\n</gs;

        warn "empty_request result:\n$xml\n";

#       warn $self->response->headers;

        return $result;
}

1	dpavlin	2	#!/usr/bin/perl
2
3			use warnings;
4			use strict;
5
6	dpavlin	11	use lib 'lib';
7	dpavlin	2	use SOAP::Transport::HTTP +trace => 'debug';
8	dpavlin	15	use HTTP::Cookies;
9			use CGI::Simple::Cookie;
10	dpavlin	19	use Data::Dump qw/dump/;
11	dpavlin	2
12	dpavlin	17	#SOAP::Trace->import( 'all' );
13	dpavlin	15
14	dpavlin	2	# Eh...
15			$SOAP::Constants::DO_NOT_CHECK_MUSTUNDERSTAND = 1;
16
17			$SIG{PIPE} = $SIG{INT} = 'IGNORE'; # don't want to die on 'Broken pipe' or Ctrl-C
18
19	dpavlin	19	my $cwmp = new CWMP;
20
21	dpavlin	2	my $daemon = SOAP::Transport::HTTP::Daemon->new(
22			#LocalAddr => 'localhost',
23			LocalPort => 3333,
24			Reuse => 1,
25			#'Listen' => 128,
26			)
27	dpavlin	17	->dispatch_with({
28	dpavlin	19	'urn:dslforum-org:cwmp-1-0' => $cwmp,
29			'http://schemas.xmlsoap.org/soap/envelope/' => $cwmp,
30	dpavlin	17	})
31	dpavlin	2	;
32
33	dpavlin	15	my $cookies = new CGI::Simple::Cookie(
34			-name => 'foo',
35			-value => 'bar',
36			);
37			$daemon->options->{simple_cookie} = $cookies;
38	dpavlin	2
39	dpavlin	22	$daemon->options->{empty_request} = sub {
40			$cwmp->empty_request( @_ );
41			};
42
43	dpavlin	19	$cwmp->enqueue( qw/GetRPCMethods/ );
44
45			print "Contact to ACS server at ", $daemon->url, " queue ", dump( $cwmp->queue ),"\n";
46	dpavlin	2	$daemon->handle;
47
48			package CWMP;
49			use strict;
50
51			use Data::Dump qw/dump/;
52	dpavlin	7	use Carp qw/cluck/;
53	dpavlin	2
54			sub new {
55			bless {}, shift;
56			}
57
58	dpavlin	12	# CPE methods Responding Calling
59			#
60			# GetRPCMethods Required Optional
61			# SetParameterValues Required Required
62			# GetParameterValues Required Required
63			# GetParameterNames Required Required
64			# SetParameterAttributes Required Optional
65			# GetParameterAttributes Required Optional
66			# AddObject Required Optional
67			# DeleteObject Required Optional
68			# Reboot Required Optional
69			# Download Required Required
70			# Upload Optional Optional
71			# FactoryReset Optional Optional
72			# GetQueuedTransfers Optional Optional
73			# ScheduleInform Optional Optional
74			# SetVouchers Optional Optional
75			# GetOptions Optional Optional
76
77	dpavlin	2	# Server methods Calling Responding
78	dpavlin	12	#
79	dpavlin	2	# GetRPCMethods Optional Required
80			# Inform Required Required
81			# TransferComplete Required Required
82			# RequestDownload Optional Optional
83			# Kicked Optional Optional
84
85	dpavlin	12
86			my $ID;
87
88	dpavlin	19	my @queue;
89	dpavlin	17
90	dpavlin	19	sub enqueue {
91			my $self = shift;
92			push @queue, @_;
93			}
94
95			sub queue {
96			my $self = shift;
97			return @queue;
98			}
99
100	dpavlin	18	sub consume_queue {
101			my @results = ( SOAP::Header->name('ID' => $ID)->prefix('cwmp')->mustUnderstand(1) );
102	dpavlin	19
103
104			my $op = shift @queue;
105
106			if ( $op ) {
107	dpavlin	18	push @results, SOAP::Data->name( $op )->prefix('cwmp');
108	dpavlin	19	warn "consume_queue $op\n";
109			};
110
111			push @results, SOAP::Header->name('NoMoreRequests' => 1)->prefix('cwmp') unless ( @queue );
112
113			warn "## conqume_queue results = ", dump( @results );
114
115	dpavlin	18	return @results;
116			}
117
118			## SOAP ACS methods
119
120	dpavlin	2	sub Inform {
121	dpavlin	7	my ($self, $DeviceId, $Event, $MaxEnvelopes, $CurrentTime, $RetryCount, $ParameterList, $headers) = @_;
122	dpavlin	2
123			my $p;
124
125	dpavlin	7	#cluck dump( $daemon );
126			#warn dump( $headers );
127
128	dpavlin	12	$ID = ( grep { $_->name eq 'ID' } @$headers )[0]->value;
129	dpavlin	7
130	dpavlin	2	foreach ( @$ParameterList ) {
131			$p->{ $_->{Name} } = $_->{Value};
132			}
133
134	dpavlin	7	warn "request $ID from ", dump( $DeviceId ), " with events ",dump( $Event ), "maxEnvelopes: $MaxEnvelopes on $CurrentTime retry $RetryCount params ", dump( $p );
135	dpavlin	2
136	dpavlin	17	return SOAP::Data->name('MaxEnvelopes' => 1);
137	dpavlin	2	}
138	dpavlin	12
139			sub GetParameterValuesResponse {
140	dpavlin	17	my $self = shift;
141
142	dpavlin	12	warn "GetParameterValuesResponse ",dump( @_ );
143	dpavlin	17
144			return;
145	dpavlin	12	}
146
147	dpavlin	17	sub Fault {
148			my $self = shift;
149
150			warn "Fault ",dump( @_ );
151
152			return;
153			}
154
155	dpavlin	18	## special handling of empty POST request from CPE
156	dpavlin	17
157	dpavlin	12	sub empty_request {
158	dpavlin	22
159	dpavlin	12	my (undef, $self) = @_;
160
161	dpavlin	19	# warn "empty_request headers = ",dump( $self->request->headers );
162
163	dpavlin	12	$self->serializer->soapversion(SOAP::Lite->soapversion);
164			$self->serializer->xmlschema($SOAP::Constants::DEFAULT_XML_SCHEMA);
165
166			my @results = (
167	dpavlin	17	# SOAP::Header->name('ID' => $ID)->prefix('cwmp')->mustUnderstand(1),
168			# SOAP::Data->name('GetParameterValues' =>
169			# SOAP::Data->value( 'ParametarNames' => [
170			# 'InternetGatewayDevice.ManagementServer.',
171			# 'a.', 'a.b.', 'a.b.c.',
172			# ],
173			# ),
174			# )->prefix('cwmp'),
175	dpavlin	12	);
176
177	dpavlin	17
178	dpavlin	19
179			push @results, ( consume_queue );
180
181	dpavlin	12	my $result = $self->serializer
182			# ->prefix('s') # distinguish generated element names between client and server
183			# ->uri('urn:dslforum-org:cwmp-1-0')
184			->ns('urn:dslforum-org:cwmp-1-0', 'cwmp')
185			->envelope( freeform => @results );
186
187			my $xml = $result;
188			$xml =~ s/</\n</gs;
189
190	dpavlin	19	warn "empty_request result:\n$xml\n";
191	dpavlin	12
192	dpavlin	19	# warn $self->response->headers;
193
194	dpavlin	12	return $result;
195			}
196	dpavlin	17