lib/CWMP/Session.pm

# Dobrica Pavlinusic, <dpavlin@rot13.org> 06/18/07 10:19:50 CEST
package CWMP::Server;

use strict;
use warnings;

use base qw/HTTP::Server::Simple::CGI Class::Accessor/;
__PACKAGE__->mk_accessors( qw/
debug
/ );

use Data::Dump qw/dump/;
use CWMP::Request;
use CWMP::Response;
use Carp qw/confess/;

=head1 NAME

CWMP::Server - implement logic of CWMP protocol

=head1 METHODS

=head2 handler

We override L<HTTP::Server::Simple::CGI/handler> so that we can support
chunked transfer encoding.

=cut

sub handler {
    my $self = shift;

    my $chunk;

        my $transfer_encoding = $self->header('Transfer-Encoding');

        if ( $transfer_encoding && $transfer_encoding =~ qr/^chunked/i ) {

                my $len = 0;
                my $hex;
                do {
                        $hex = <STDIN>;         # get chunk length
                        $hex =~ s/[\n\r]*$//s;
                        $len = hex( $hex );

                        warn "getting chunk of 0x$hex $len bytes\n" if $self->debug;

                        while( $len > 0 ) {
                                my $line = <STDIN>;
                                $chunk .= $line;
                                $len -= length( $line );
                        }

                } while ( hex( $hex ) != 0 );
        }

        warn "handler got ", length($chunk), " bytes\n" if $self->debug;

    my $cgi  = new CGI( $chunk );

    eval { $self->handle_request($cgi) };
    if ($@) {
        my $error = $@;
        warn $error;
    }
}

=head2 handle_request

Implementation of dispatch logic

=cut

sub handle_request {
        my ($self, $cgi) = @_;
                                                                    
        #... do something, print output to default
        # selected filehandle...

        warn "<<< " . localtime() . " " . $ENV{REMOTE_ADDR} . "\n";

        warn "not SOAP request" unless defined ( $cgi->header('SOAPAction') );

        my $state;

        if ( my $payload = $cgi->param('POSTDATA') ) {
                warn "request payload:\n$payload\n" if $self->debug;

                $state = CWMP::Request->parse( $payload );

                warn "acquired state = ", dump( $state );
        
        } else {
                warn "empty request\n";
        }

        my $response = CWMP::Response->new({ debug => $self->debug });

        print "Content-Type: text/xml\r\n\r\n";

        if ( my $dispatch = $state->{_dispatch} ) {
                if ( $response->can( $dispatch ) ) {
                        warn ">>> dispatching to $dispatch\n";
                        print $response->$dispatch;
                } else {
                        confess "can't dispatch to $dispatch";
                }
        } else {
                warn ">>> empty response\n";
        }
        
};

1;

1	dpavlin	30	# Dobrica Pavlinusic, <dpavlin@rot13.org> 06/18/07 10:19:50 CEST
2			package CWMP::Server;
3
4			use strict;
5			use warnings;
6
7			use base qw/HTTP::Server::Simple::CGI Class::Accessor/;
8			__PACKAGE__->mk_accessors( qw/
9			debug
10			/ );
11
12			use Data::Dump qw/dump/;
13	dpavlin	35	use CWMP::Request;
14			use CWMP::Response;
15	dpavlin	36	use Carp qw/confess/;
16	dpavlin	30
17	dpavlin	34	=head1 NAME
18
19			CWMP::Server - implement logic of CWMP protocol
20
21			=head1 METHODS
22
23			=head2 handler
24
25			We override L<HTTP::Server::Simple::CGI/handler> so that we can support
26			chunked transfer encoding.
27
28			=cut
29
30	dpavlin	30	sub handler {
31			my $self = shift;
32
33			my $chunk;
34
35			my $transfer_encoding = $self->header('Transfer-Encoding');
36
37			if ( $transfer_encoding && $transfer_encoding =~ qr/^chunked/i ) {
38
39	dpavlin	31	my $len = 0;
40	dpavlin	35	my $hex;
41	dpavlin	30	do {
42	dpavlin	35	$hex = <STDIN>; # get chunk length
43			$hex =~ s/[\n\r]*$//s;
44			$len = hex( $hex );
45	dpavlin	30
46	dpavlin	35	warn "getting chunk of 0x$hex $len bytes\n" if $self->debug;
47	dpavlin	30
48			while( $len > 0 ) {
49			my $line = <STDIN>;
50			$chunk .= $line;
51			$len -= length( $line );
52			}
53
54	dpavlin	35	} while ( hex( $hex ) != 0 );
55	dpavlin	30	}
56
57	dpavlin	35	warn "handler got ", length($chunk), " bytes\n" if $self->debug;
58	dpavlin	30
59			my $cgi = new CGI( $chunk );
60
61			eval { $self->handle_request($cgi) };
62			if ($@) {
63			my $error = $@;
64			warn $error;
65			}
66			}
67
68	dpavlin	34	=head2 handle_request
69
70			Implementation of dispatch logic
71
72			=cut
73
74	dpavlin	30	sub handle_request {
75			my ($self, $cgi) = @_;
76
77			#... do something, print output to default
78			# selected filehandle...
79
80	dpavlin	36	warn "<<< " . localtime() . " " . $ENV{REMOTE_ADDR} . "\n";
81	dpavlin	30
82			warn "not SOAP request" unless defined ( $cgi->header('SOAPAction') );
83
84	dpavlin	36	my $state;
85
86	dpavlin	34	if ( my $payload = $cgi->param('POSTDATA') ) {
87			warn "request payload:\n$payload\n" if $self->debug;
88	dpavlin	30
89	dpavlin	36	$state = CWMP::Request->parse( $payload );
90	dpavlin	34
91			warn "acquired state = ", dump( $state );
92
93	dpavlin	36	} else {
94			warn "empty request\n";
95	dpavlin	34	}
96
97	dpavlin	35	my $response = CWMP::Response->new({ debug => $self->debug });
98	dpavlin	34
99	dpavlin	30	print "Content-Type: text/xml\r\n\r\n";
100
101	dpavlin	36	if ( my $dispatch = $state->{_dispatch} ) {
102			if ( $response->can( $dispatch ) ) {
103			warn ">>> dispatching to $dispatch\n";
104			print $response->$dispatch;
105			} else {
106			confess "can't dispatch to $dispatch";
107			}
108			} else {
109			warn ">>> empty response\n";
110			}
111	dpavlin	34
112	dpavlin	30	};
113
114			1;
115