lib/CWMP/Server.pm

   1 # Dobrica Pavlinusic, <dpavlin@rot13.org> 06/22/07 14:35:38 CEST
   2 package CWMP::Server;
   3
   4 use strict;
   5 use warnings;
   6
   7 use base qw/Class::Accessor/;
   8 __PACKAGE__->mk_accessors( qw/
   9 port
  10 session
  11 background
  12 debug
  13 create_dump
  14
  15 server
  16 / );
  17
  18 use CWMP::Session;
  19 use CWMP::Queue;
  20
  21 use Carp qw/confess/;
  22 use Data::Dump qw/dump/;
  23
  24 use IO::Socket::INET;
  25 use File::Path qw/mkpath/;
  26 use File::Slurp;
  27
  28 use URI::Escape;
  29
  30 =head1 NAME
  31
  32 CWMP::Server - description
  33
  34 =head1 METHODS
  35
  36 =head2 new
  37
  38   my $server = CWMP::Server->new({
  39         port => 3333,
  40         session => { ... },
  41         background => 1,
  42         debug => 1
  43   });
  44
  45 Options:
  46
  47 =over 4
  48
  49 =item port
  50
  51 port to listen on
  52
  53 =item session
  54
  55 hash with key C<module> with value C<DBMDeep> if L<CWMP::Store::DBMDeep>
  56 is used. Other parametars are optional.
  57
  58 =back
  59
  60 =cut
  61
  62 sub new {
  63         my $class = shift;
  64         my $self = $class->SUPER::new( @_ );
  65
  66         warn "created ", __PACKAGE__, "(", dump( @_ ), ") object\n" if $self->debug;
  67
  68         $self->debug( 0 ) unless $self->debug;
  69         warn "## debug level: ", $self->debug, "\n" if $self->debug;
  70
  71         return $self;
  72 }
  73
  74 =head2 run
  75
  76 =cut
  77
  78 sub run {
  79         my $self = shift;
  80
  81         my $server = IO::Socket::INET->new(
  82                         Proto     => 'tcp',
  83                         LocalPort => $self->port,
  84                         Listen    => SOMAXCONN,
  85                         Reuse     => 1
  86         ) || die "can't start server on ", $self->port, ": $!";
  87
  88         warn "ACS waiting for request on port ", $self->port, "\n";
  89
  90         while (1) {
  91                 my $client = $server->accept() || next; # ALARM trickle us
  92
  93                 my $count = 0;
  94
  95                 my $session = CWMP::Session->new( $self->session ) || confess "can't create sessision";
  96
  97                 while ( $self->sock_session( $client, $session ) ) {
  98                         $count++;
  99                         warn "# finished request $count, waiting for next one\n";
 100                 }
 101
 102                 warn "# connection to ", $client->peerhost, " closed\n";
 103         }
 104
 105 }
 106
 107 my $dump_by_ip;
 108
 109 sub sock_session {
 110         my ( $self, $sock, $session ) = @_;
 111
 112         my $request = <$sock>;
 113         return unless $request;
 114         my $ip = $sock->peerhost;
 115
 116         my $headers;
 117
 118         while ( my $header = <$sock> ) {
 119                 $request .= $header;
 120                 chomp $header;
 121                 last if $header =~ m{^\s*$};
 122                 my ( $n, $v ) = split(/:\s*/, $header);
 123                 $v =~ s/[\r\n]+$//;
 124                 $headers->{ lc $n } = $v;
 125         }
 126
 127         warn "<<<< $ip START\n$request\n";
 128
 129         return $sock->connected unless $headers;
 130
 131         warn "missing $_ header\n" foreach grep { ! defined $headers->{ lc $_ } } ( 'SOAPAction' );
 132
 133         my $body;
 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]+$//;
 139                         $len = hex($len);
 140                         last if $len == 0;
 141                         read( $sock, my $chunk, $len );
 142                         $body .= $chunk;
 143                         my $padding = <$sock>;
 144                 }
 145         } else {
 146                 warn "empty request\n";
 147         }
 148
 149         warn "$body\n<<<< $ip END\n";
 150
 151
 152         # XXX evil security hole to eval code over web to inspect it
 153         if ( $self->debug && $headers->{'user-agent'} =~ m{Mozilla} ) {
 154                 my $out = '';
 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";
 160                 }
 161                 print $sock "HTTP/1.1 200 OK\r\nContent-type: text/plain\r\nConnection: close\r\n\r\n$out";
 162                 return 0;
 163         }
 164
 165         my $response = $session->process_request( $ip, $body );
 166
 167         my $dump_nr = $dump_by_ip->{$ip}++;
 168
 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 );
 173         }
 174
 175         warn ">>>> $ip START\n$response\n>>>> $ip END\n";
 176         print $sock $response;
 177
 178         return $sock->connected;
 179
 180 }
 181
 182
 183 1;