1 # Dobrica Pavlinusic, <dpavlin@rot13.org> 06/22/07 14:35:38 CEST
7 use base qw/Class::Accessor/;
8 __PACKAGE__->mk_accessors( qw/
22 use Data::Dump qw/dump/;
25 use File::Path qw/mkpath/;
32 CWMP::Server - description
38 my $server = CWMP::Server->new({
55 hash with key C<module> with value C<DBMDeep> if L<CWMP::Store::DBMDeep>
56 is used. Other parametars are optional.
64 my $self = $class->SUPER::new( @_ );
66 warn "created ", __PACKAGE__, "(", dump( @_ ), ") object\n" if $self->debug;
68 $self->debug( 0 ) unless $self->debug;
69 warn "## debug level: ", $self->debug, "\n" if $self->debug;
81 my $server = IO::Socket::INET->new(
83 LocalPort => $self->port,
86 ) || die "can't start server on ", $self->port, ": $!";
88 warn "ACS waiting for request on port ", $self->port, "\n";
91 my $client = $server->accept() || next; # ALARM trickle us
95 my $session = CWMP::Session->new( $self->session ) || confess "can't create sessision";
97 while ( $self->sock_session( $client, $session ) ) {
99 warn "# finished request $count, waiting for next one\n";
102 warn "# connection to ", $client->peerhost, " closed\n";
110 my ( $self, $sock, $session ) = @_;
112 my $request = <$sock>;
113 return unless $request;
114 my $ip = $sock->peerhost;
118 while ( my $header = <$sock> ) {
121 last if $header =~ m{^\s*$};
122 my ( $n, $v ) = split(/:\s*/, $header);
124 $headers->{ lc $n } = $v;
127 warn "<<<< $ip START\n$request\n";
129 return $sock->connected unless $headers;
131 warn "missing $_ header\n" foreach grep { ! defined $headers->{ lc $_ } } ( 'SOAPAction' );
134 if ( my $len = $headers->{'content-length'} ) {
135 read( $sock, $body, $len );
136 } elsif ( $headers->{'transfer-encoding'} =~ m/^chunked/i ) {
137 while ( my $len = <$sock> ) {
138 $len =~ s/[\r\n]+$//;
141 read( $sock, my $chunk, $len );
143 my $padding = <$sock>;
146 warn "empty request\n";
149 warn "$body\n<<<< $ip END\n";
152 # XXX evil security hole to eval code over web to inspect it
153 if ( $self->debug && $headers->{'user-agent'} =~ m{Mozilla} ) {
155 if ( $request =~ m{^GET /(\$.+) HTTP/} ) {
156 my $eval = uri_unescape $1;
157 $out = dump( eval $eval );
158 $out .= "ERROR: $@\n" if $@;
159 warn "EVAL $eval = $out\n";
161 print $sock "HTTP/1.1 200 OK\r\nContent-type: text/plain\r\nConnection: close\r\n\r\n$out";
165 my $response = $session->process_request( $ip, $body );
167 my $dump_nr = $dump_by_ip->{$ip}++;
169 if ( $self->create_dump ) {
170 mkpath "dump/$ip" unless -e "dump/$ip";
171 write_file( sprintf("dump/%s/%04d.request", $ip, $dump_nr), "$request\r\n$body" );
172 write_file( sprintf("dump/%s/%04d.response", $ip, $dump_nr ), $response );
175 warn ">>>> $ip START\n$response\n>>>> $ip END\n";
176 print $sock $response;
178 return $sock->connected;