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 =head1 NAME
  29
  30 CWMP::Server - description
  31
  32 =head1 METHODS
  33
  34 =head2 new
  35
  36   my $server = CWMP::Server->new({
  37         port => 3333,
  38         session => { ... },
  39         background => 1,
  40         debug => 1
  41   });
  42
  43 Options:
  44
  45 =over 4
  46
  47 =item port
  48
  49 port to listen on
  50
  51 =item session
  52
  53 hash with key C<module> with value C<DBMDeep> if L<CWMP::Store::DBMDeep>
  54 is used. Other parametars are optional.
  55
  56 =back
  57
  58 =cut
  59
  60 sub new {
  61         my $class = shift;
  62         my $self = $class->SUPER::new( @_ );
  63
  64         warn "created ", __PACKAGE__, "(", dump( @_ ), ") object\n" if $self->debug;
  65
  66         $self->debug( 0 ) unless $self->debug;
  67         warn "## debug level: ", $self->debug, "\n" if $self->debug;
  68
  69         return $self;
  70 }
  71
  72 =head2 run
  73
  74 =cut
  75
  76 sub run {
  77         my $self = shift;
  78
  79         my $server = IO::Socket::INET->new(
  80                         Proto     => 'tcp',
  81                         LocalPort => $self->port,
  82                         Listen    => SOMAXCONN,
  83                         Reuse     => 1
  84         ) || die "can't start server on ", $self->port, ": $!";
  85
  86         warn "ACS waiting for request on port ", $self->port, "\n";
  87
  88         while (1) {
  89                 my $client = $server->accept() || next; # ALARM trickle us
  90
  91                 my $count = 0;
  92
  93                 my $session = CWMP::Session->new( $self->session ) || confess "can't create sessision";
  94
  95                 while ( $self->sock_session( $client, $session ) ) {
  96                         $count++;
  97                         warn "# finished request $count, waiting for next one\n";
  98                 }
  99
 100                 warn "# connection to ", $client->peerhost, " closed\n";
 101         }
 102
 103 }
 104
 105 my $dump_by_ip;
 106
 107 sub sock_session {
 108         my ( $self, $sock, $session ) = @_;
 109
 110         my $request = <$sock>;
 111         return unless $request;
 112         my $ip = $sock->peerhost;
 113
 114         my $headers;
 115
 116         while ( my $header = <$sock> ) {
 117                 $request .= $header;
 118                 chomp $header;
 119                 last if $header =~ m{^\s*$};
 120                 my ( $n, $v ) = split(/:\s*/, $header);
 121                 $v =~ s/[\r\n]+$//;
 122                 $headers->{ lc $n } = $v;
 123         }
 124
 125         warn "<<<< $ip START\n$request\n";
 126
 127         return $sock->connected unless $headers;
 128
 129         warn "missing $_ header\n" foreach grep { ! defined $headers->{ lc $_ } } ( 'SOAPAction' );
 130
 131         my $body;
 132         if ( my $len = $headers->{'content-length'} ) {
 133                 read( $sock, $body, $len );
 134         } elsif ( $headers->{'transfer-encoding'} =~ m/^chunked/i ) {
 135                 while ( my $len = <$sock> ) {
 136                         $len =~ s/[\r\n]+$//;
 137                         $len = hex($len);
 138                         last if $len == 0;
 139                         read( $sock, my $chunk, $len );
 140                         $body .= $chunk;
 141                         my $padding = <$sock>;
 142                 }
 143         } else {
 144                 warn "empty request\n";
 145         }
 146
 147         warn "$body\n<<<< $ip END\n";
 148
 149         my $response = $session->process_request( $ip, $body );
 150
 151         my $dump_nr = $dump_by_ip->{$ip}++;
 152
 153         if ( $self->create_dump ) {
 154                 mkpath "dump/$ip" unless -e "dump/$ip";
 155                 write_file( sprintf("dump/%s/%04d.request", $ip, $dump_nr), "$request\r\n$body" );
 156                 write_file( sprintf("dump/%s/%04d.response", $ip, $dump_nr ), $response );
 157         }
 158
 159         warn ">>>> $ip START\n$response\n>>>> $ip END\n";
 160         print $sock $response;
 161
 162         return $sock->connected;
 163
 164 }
 165
 166
 167 1;