File Coverage

blib/lib/Net/ICAP/Server.pm

Criterion	Covered	Total	%
statement	33	179	18.4
branch	0	42	0.0
condition	0	15	0.0
subroutine	11	19	57.8
pod	2	2	100.0
total	46	257	17.9

# Net::ICAP::Server -- ICAP Server Implementation
#
# (c) 2014, Arthur Corliss
#
# $Id: lib/Net/ICAP/Server.pm, v0.03 $
#
#    This software is licensed under the same terms as Perl, itself.
#    Please see http://dev.perl.org/licenses/ for more information.
#
#####################################################################

#####################################################################
#
# Environment definitions
#
#####################################################################

package Net::ICAP::Server;

use 5.006;

use strict;
use warnings;
use vars qw($VERSION @ISA @_properties @_methods);

($VERSION) = ( q$Revision: 0.03 $ =~ /(\d+(?:\.(\d+))+)/sm );

@ISA         = qw(Class::EHierarchy);

use Socket;
use IO::Socket::INET;
use Class::EHierarchy qw(:all);
use Net::ICAP;
use Net::ICAP::Common qw(:all);
use Paranoid::Debug;
use Paranoid::Process qw(:all);

@_properties = (
    [ CEH_RESTR | CEH_SCALAR, '_addr',         '0.0.0.0' ],
    [ CEH_RESTR | CEH_SCALAR, '_port',         ICAP_DEF_PORT ],
    [ CEH_RESTR | CEH_SCALAR, '_time-out',     60 ],
    [ CEH_RESTR | CEH_SCALAR, '_max_requests', 0 ],
    [ CEH_RESTR | CEH_SCALAR, '_max_children', 0 ],
    [ CEH_RESTR | CEH_SCALAR, '_options_ttl',  0 ],
    [ CEH_RESTR | CEH_HASH,   '_services' ],
    [ CEH_RESTR | CEH_CODE,   '_reqmod' ],
    [ CEH_RESTR | CEH_CODE,   '_respmod' ],
    [ CEH_RESTR | CEH_CODE,   '_logger' ],
    [ CEH_RESTR | CEH_CODE, '_istag', sub { return time } ],
    );
@_methods = ();

#####################################################################
#
# Net::ICAP::Server code follows
#
#####################################################################

sub _initialize {
    my $obj   = shift;
    my %args  = @_;
    my $rv    = 1;
    my @props = $obj->propertyNames;
    my $a;

    pdebug( "entering w/$obj and @{[ scalar keys %args ]}", ICAPDEBUG1 );
    pIn();

    # Set internal state
    foreach $a ( keys %args ) {
        if ( grep { $_ eq "_$a" } @props ) {
            unless (
                $obj->property(
                    "_$a", $a eq 'services'
                    ? %{ $args{$a} }
                    : $args{$a} )
                ) {
                pdebug( "failed to set $a", ICAPDEBUG1 );
                $rv = 0;
                last;
            }
        } else {
            pdebug( "unknown argument: $a", ICAPDEBUG1 );
            $rv = 0;
            last;
        }
    }

    pOut();
    pdebug( "leaving w/rv: $rv", ICAPDEBUG1 );

    return $rv;
}

sub istag ($) {

    # Purpose:  Returns code ref to ISTag generation function
    # Returns:  Code ref
    # Usage:    $code = $obj->istag;

    my $obj = shift;
    return $obj->property('_istag');
}

sub _drain ($$) {

    # Purpose:  Drains input buffer until the connection is silent for 5s
    # Returns:  Boolean
    # Usage:    $rv = $obj->_drain($client);

    my $obj    = shift;
    my $client = shift;
    my $rv     = 1;
    my ( $line, $lastInput );

    pdebug( "entering w/$client", ICAPDEBUG1 );
    pIn();

    if ( defined $client ) {
        $client->blocking(0);
        $lastInput = time;
        while ( time - $lastInput < 5 ) {
            while ( defined( $line = $client->getline ) ) {
                $lastInput = time;
            }
            sleep 0.1;
        }
    }

    pOut();
    pdebug( "leaving w/rv: $rv", ICAPDEBUG1 );

    return $rv;
}

sub _error ($;$) {

    # Purpose:  Writes an error response to client
    # Returns:  Boolean
    # Usage:    $rv = $obj->_error($client);

    my $obj    = shift;
    my $status = shift;
    my $s      = defined $status ? $status : 'undef';
    my $resp;

    pdebug( "entering w/$s", ICAPDEBUG1 );
    pIn();

    $status = ICAP_BAD_REQUEST unless defined $status;
    $resp = Net::ICAP::Response->new(
        status  => $status,
        headers => {
            ISTag      => &{ $obj->istag },
            Connection => 'close',
            },
            );

    pOut();
    pdebug( "leaving w/rv: $resp", ICAPDEBUG1 );

    return $resp;
}

sub _options ($$) {

    # Purpose:  Returns an options response
    # Returns:  Response object
    # Usage:    $resp = _options($req);

    my $obj      = shift;
    my $request  = shift;
    my $response = Net::ICAP::Response->new(
        status  => ICAP_OK,
        headers => {
            ISTag             => &{ $obj->istag },
            'Max-Connections' => $obj->property('_max_children'),
            Allow             => 204,
            },
            );

    $response->header( 'Options-TTL', $obj->property('_options_ttl') )
        if $obj->property('_options_ttl');

    return $response;
}

sub _dispatch ($$$) {

    # Purpose:  Calls the applicable function depending on the method
    # Returns:  Boolean
    # Usage:    $rv = $obj->_dispatch($client, $r);

    my $obj      = shift;
    my $client   = shift;
    my $request  = shift;
    my $reqmod   = $obj->property('_reqmod');
    my $respmod  = $obj->property('_respmod');
    my $logger   = $obj->property('_logger');
    my %services = $obj->property('_services');
    my $rv       = 1;
    my ( $service, $method, $response, $r );

    pdebug( "entering w/$client, $request", ICAPDEBUG1 );
    pIn();

    $service = $request->service;
    if ( exists $services{$service} ) {
        $method = $request->method;
        if ( $method eq ICAP_OPTIONS or $services{$service} eq $method ) {
            if ( $method eq ICAP_REQMOD and defined $reqmod ) {
                $response = &$reqmod( $client, $request );
            } elsif ( $method eq ICAP_RESPMOD and defined $respmod ) {
                $response = &$respmod( $client, $request );
            } elsif ( $method eq ICAP_OPTIONS ) {
                $response = $obj->_options($request);
                $response->header( 'Methods', $services{$service} );
            } else {
                $response = $obj->_error(ICAP_METHOD_NOT_IMPLEMENTED);
                $rv       = 0;
            }
        } else {
            $response = $obj->_error(ICAP_METHOD_NOT_ALLOWED);
            $rv       = 0;
        }
    } else {
        $response = $obj->_error(ICAP_SERVICE_NOT_FOUND);
        $rv       = 0;
    }

    # Add ISTag
    $response->header( 'ISTag', &{ $obj->istag } );

    # Log transaction
    &$logger( $client, $request, $response ) if defined $logger;

    # Send the response to the client
    $r = $response->generate($client);
    $rv &= $r;

    pOut();
    pdebug( "leaving w/rv: $rv", ICAPDEBUG1 );

    return $rv;
}

sub _process ($$) {

    # Purpose:  Processes ICAP traffic on the connection
    # Returns:  Boolean
    # Usage:    $rv = $obj->_process($client);

    my $obj     = shift;
    my $client  = shift;
    my $rv      = 1;
    my $counter = 0;
    my $max_r   = $obj->property('_max_requests');
    my $logger  = $obj->property('_logger');
    my ( $req, $resp, $c );

    pdebug( "entering w/$client", ICAPDEBUG1 );
    pIn();

    while ( $max_r == 0 or $counter < $max_r ) {
        $req = new Net::ICAP::Request;
        if ( $req->parse($client) ) {

            # Send request to dispatcher
            $c = $req->header('Connection');
            if ( $obj->_dispatch( $client, $req ) ) {
                last if defined $c and $c eq 'close';
                $counter++;
            } else {
                $rv = 0;
                last;
            }
        } else {
            $obj->_drain($client);
            $resp = $obj->_error;
            $resp->generate($client);
            &$logger( $client, $req, $resp ) if defined $logger;
            $rv = 0;
            last;
        }
    }

    pOut();
    pdebug( "leaving w/rv: $rv", ICAPDEBUG1 );

    return $rv;
}

sub run ($) {

    # Purpose:  Opens the socket and runs
    # Returns:  Boolean
    # Usage:    $rv = $obj->run;

    my $obj         = shift;
    my $addr        = $obj->property('_addr');
    my $port        = $obj->property('_port');
    my $maxChildren = $obj->property('_max_children');
    my $queueSize   = $maxChildren * 2;
    my $rv          = 1;
    my ( $socket, $client, $cpid );

    pdebug( 'entering', ICAPDEBUG1 );
    pIn();

    MAXCHILDREN = $maxChildren;
    local $SIG{CHLD} = \&sigchld;

    # Open the socket
    $socket = IO::Socket::INET->new(
        ( $addr eq '0.0.0.0' ? (qw(MultiHomed 1)) : ( 'LocalAddr', $addr ) ),
        LocalPort => $port,
        Listen    => $queueSize,
        Type      => SOCK_STREAM,
        Reuse     => 1,
        );

    if ( defined $socket ) {
        while (1) {
            while ( $client = $socket->accept ) {
                if ( defined( $cpid = pfork() ) ) {
                    unless ($cpid) {
                        $obj->_process($client);
                        $client->close;
                        exit 0;
                    }
                } else {
                    pdebug(
                        "failed to fork child for incoming connection: $!",
                        ICAPDEBUG1 );
                    $rv = 0;
                }
            }
        }
    } else {
        $rv = 0;
        pdebug( "failed to open socket: $!", ICAPDEBUG1 );
    }

    pOut();
    pdebug( "leaving w/rv: $rv", ICAPDEBUG1 );

    return $rv;
}

1;

__END__