File Coverage

blib/lib/HTTP/Server/Encrypt.pm

Criterion	Covered	Total	%
statement	197	284	69.3
branch	46	138	33.3
condition	25	77	32.4
subroutine	27	27	100.0
pod	1	5	20.0
total	296	531	55.7

package HTTP::Server::Encrypt;
use 5.008008;
use strict;
use warnings;
use Carp qw(croak);
use HTTP::Server::Daemon qw(become_daemon server_perfork_dynamic peer_info get_msg send_msg);
use HTTP::Status qw(status_message);
use HTTP::Date qw(time2str);
use MIME::Base64 qw(encode_base64);
use File::Basename qw(dirname basename);
use Sys::Sendfile qw(sendfile);
use Log::Lite qw(log logpath);
use Crypt::CBC;
use Digest::MD5 qw(md5_hex);
use Data::Dump qw(ddx);
use Sys::Hostname;
use LWP::MediaTypes qw(guess_media_type);
use vars qw(@ISA @EXPORT_OK $right_auth $username $script_base_dir $peer_port $peer_ip $script %data $body %header $file %_GET %_POST %_HEAD %res $send_bytes $static_expires_secs $blowfish $blowfish_key $blowfish_encrypt $blowfish_decrypt $_POST %ip_allow %ip_deny $log_dir $port $colonel_version);

require Exporter;
@ISA = qw(Exporter);
@EXPORT_OK = qw(http_server_start);

our $VERSION = '0.12';

sub http_server_start
{
    my $ref_http_conf = shift;
    my %http_conf = %$ref_http_conf;
    our $port = $http_conf{'port'} || 80;
    my $protocol = $http_conf{'protocol'} || 'http';
    my $min_spare = $http_conf{'min_spare'} || 10;
    my $max_spare = $http_conf{'max_spare'} || 20;
    our $script_base_dir = $http_conf{'docroot'} || 'htdoc';
    our $static_expires_secs = $http_conf{'cache_expires_secs'} || 3600;
    our $username = $http_conf{'username'};
    my $passwd = $http_conf{'passwd'};
    my $blowfish_key = $http_conf{'blowfish_key'};
    our $blowfish_encrypt = $http_conf{'blowfish_encrypt'};
    our $blowfish_decrypt = $http_conf{'blowfish_decrypt'};
    our %ip_allow = %{$http_conf{'ip_allow'}} if $http_conf{'ip_allow'};
    our %ip_deny = %{$http_conf{'ip_deny'}} if $http_conf{'ip_deny'};
    our $log_dir = $http_conf{'log_dir'} if $http_conf{'log_dir'};
    $log_dir = '' if defined $log_dir and $log_dir eq 'no';
    logpath($log_dir) if defined $log_dir and $log_dir;
    our $colonel_version = 'Colonel/0.9';

    if ($blowfish_key)
    {
        our $blowfish = Crypt::CBC->new(
                            -key    => $blowfish_key ,
                            -cipher => 'Blowfish',
        );
    }

    if ($username or $passwd)
    {
        our $right_auth = $username if $username;
        $right_auth.= ":";
        $right_auth.= $passwd if $passwd;
        $right_auth = encode_base64($right_auth);
        chomp $right_auth;
    }

    my ($package, $invoker) = caller;
    chdir( dirname($invoker) );

    my $pidfile = become_daemon($invoker);
    $SIG{TERM} = sub { unlink $pidfile; kill HUP => $$; };

    if (lc($protocol) eq 'perl')
    {
        server_perfork_dynamic(\&do_child_perl, $port, $min_spare, $max_spare);
    }
    else
    {
        server_perfork_dynamic(\&do_child_http, $port, $min_spare, $max_spare);
    }
    return $pidfile;
}

sub do_child_http
{
	no warnings 'uninitialized';
    my $sock = shift;
    local ($peer_port, $peer_ip) = peer_info($sock);
    if (%ip_allow) {return unless $ip_allow{$peer_ip};}
    if (%ip_deny)  {return if $ip_deny{$peer_ip};}
    my $status = 100;
    my $send_bytes;
    my $method;
    my $request_uri;
    my $protocol;
    my %header;
    local %ENV;
    $ENV{'AUTH_TYPE'} = "Basic" if $username;
    $ENV{'GATEWAY_INTERFACE'} = "CGI/1.1";
    $ENV{'HTTP'} = '';
    $ENV{'REMOTE_ADDR'} = $peer_ip;
    $ENV{'REMOTE_HOST'} = $peer_ip;
    $ENV{'REMOTE_IDENT'} = "";
    $ENV{'REMOTE_USER'} = $username if $username;
    $ENV{'SERVER_NAME'} = hostname;
    $ENV{'SERVER_PORT'} = $port;
    $ENV{'SERVER_PROTOCOL'} = "HTTP/1.0";
    $ENV{'SERVER_SOFTWARE'} = $colonel_version;

    my $chunk = http_readline($sock);
    if (!$chunk or length($chunk) > 16*1024)
    {
        $status = 414;
        goto HTTP_RESP;
    }

    ($method, $request_uri, $protocol) = $chunk =~ m/^(\w+)\s+(\S+)(?:\s+(\S+))?\r?$/;
    if ($method !~ /^(?:GET|POST)$/ or $request_uri =~ /\.\./)
    {
        $status = 405;
        goto HTTP_RESP;
    }
    $ENV{'REQUEST_METHOD'} = $method;

    my ($script, $query_string ) = $request_uri =~ /([^?]*)(?:\?(.*))?/s;
    $ENV{'PATH_INFO'} = $script;
    $ENV{'PATH_TRANSLATED'} = $script;
    $ENV{'QUERY_STRING'} = $query_string;
    $ENV{'SCRIPT_NAME'} = $script;

    local %_GET;
    if($query_string)
    {
        my @query = split /\&/, $query_string;
        foreach (@query)
        {
            my ($k, $v) = $_ =~ /(.*)\=(.*)/;
            next unless defined $k and $k and defined $v and $v;
            if (!$_GET{$k})
            {
                $_GET{$k} = $v;
            }
            elsif (!ref($_GET{$k}))
            {
                my $tmp_value = $_GET{$k};
                undef $_GET{$k};
                push @{$_GET{$k}} , $tmp_value;
                push @{$_GET{$k}} , $v;
            }
            elsif (ref($_GET{$k}) eq 'ARRAY')
            {
                push @{$_GET{$k}} , $v;
            }
            else
            {
                next;
            }
        }
    }
    local %_HEAD = http_get_header($sock);
    $ENV{'CONTENT_LENGTH'} = $_HEAD{'Content-Length'};
    $ENV{'CONTENT_TYPE'} = $_HEAD{'Content-Type'};

    if( -d "$script_base_dir$script" )
    {
        if (substr($script, -1) ne '/')
        {
            $status = 301;
            $header{'Location'} = "http://" . $_HEAD{'Host'} . "$script/$query_string";
            goto HTTP_RESP;
        }

        if (-e "$script_base_dir$script/index.html")
        {
            $script .= '/' if substr($script,-1) ne '/';
            $script .= 'index.html';
        }
        elsif (-e "$script_base_dir$script/index.htm")
        {
            $script .= '/' if substr($script,-1) ne '/';
            $script .= 'index.htm';
        }
        elsif (-e "$script_base_dir$script/index.pl")
        {
            $script .= '/' if substr($script,-1) ne '/';
            $script .= 'index.pl';
        }
    }
    my $script_file = "$script_base_dir$script";

    if ($right_auth)
    {
        my ($client_auth) = $_HEAD{'Authorization'} =~ /Basic\s*([\w\+\=]+)/ if $_HEAD{'Authorization'};
        unless (defined $client_auth and $client_auth eq $right_auth)
        {
            $status = 401;
            goto HTTP_RESP;
        }
    }

    local %_POST;
    local $_POST;
    if ($method eq 'POST')
    {
        use bytes;
        my $post_data = '';
        if(defined $_HEAD{'Content-Length'})
        {
            read($sock, $post_data, $_HEAD{'Content-Length'});
        }
        else
        {
            my $i = 0;
            while( substr($post_data, -2) ne "\015\012" )
            {
                read($sock, my $buf, 1);
                $post_data .= $buf;
                $i++;
                if ($i > 4096)
                {
                    $status = 411;
                    goto HTTP_RESP;
                }
            }
        }
        last unless $post_data;

        $post_data = $blowfish->decrypt($post_data) if $blowfish_decrypt;
        $_POST = $post_data;
        my @post_query = split /\&/, $post_data;
        foreach (@post_query)
        {
            my ($k_post, $v_post) = $_ =~ /(.*)\=(.*)/;
            next unless defined $k_post and $k_post and defined $v_post and $v_post;
            if (!$_POST{$k_post})
            {
                $_POST{$k_post} = $v_post;
            }
            elsif (!ref($_POST{$k_post}))
            {
                my $tmp_value = $_POST{$k_post};
                undef $_POST{$k_post};
                push @{$_POST{$k_post}} , $tmp_value;
                push @{$_POST{$k_post}} , $v_post;
            }
            elsif (ref($_POST{$k_post}) eq 'ARRAY')
            {
                push @{$_POST{$k_post}} , $v_post;
            }
            else
            {
                next;
            }
        }
    }

    my $boolen_sendfile;
    my $body = '';
    if (-e $script_file and -r $script_file and -s $script_file)
    {
        eval
        {
            $status = 200;
            if ( substr( $script_file, -3) eq '.pl' )
            {
                no warnings;
                close STDOUT;
                open STDOUT,">",\$body or die "couldn`t open memory file: $!";
                unless (my $return = do $script_file)
                {
                    die "couldn`t parse $script_file: $@" if $@;
                    die "couldn`t do $script_file: $!"    unless defined $return ;
                    die "couldn`t run $script_file"       unless $return;
                }
            }
            else
            {
                open my $fh,"<",$script_file or die "couldn`t open file";
                binmode $fh;

				my($ct,$ce) = guess_media_type($script_file);
                if(!$blowfish_encrypt and $^O eq 'linux')
                {
					syswrite $sock, "HTTP/1.0 $status " . status_message($status) . "\015\012";
					syswrite $sock, "Content-Type: $ct\015\012" if $ct;
					syswrite $sock, "Content-Encoding: $ce\015\012" if $ce;
					syswrite $sock, "Cache-Control: max-age=$static_expires_secs\015\012";
					syswrite $sock, "\015\012";
                    $send_bytes = sendfile($sock, $fh);
                    $boolen_sendfile = 1;
                    goto HTTP_RESP;
                }
                else
                {
                    $body = do {local $/; <$fh>};
					$header{'Content-Type'} = $ct if $ct;
					$header{'Content-Encoding'} = $ce if $ce;
                }
                close $fh;
            }

            if($blowfish_encrypt)
            {
                $body = $blowfish->encrypt($body);
                $header{'Content-Type'} = "application/octet-stream";
            }
        };
        if($@)
        {
            $status = 500;
            $body = $@;
            goto HTTP_RESP;
        }
    }
    else
    {
        $status = 404;
        goto HTTP_RESP;
    }

    HTTP_RESP: $send_bytes = http_response($sock, $status, $body, %header) unless $boolen_sendfile;
    log('http_access', $peer_ip, $status, $method, $request_uri, $send_bytes, status_message($status), $@) if $log_dir;
    return $send_bytes;
}

sub http_get_header
{
    my $sock = shift;
    my @header;
    while ( my $line = http_readline($sock) )
    {
        last if ( $line =~ /^\s*$/ );
        my ($k, $v) = $line =~ /^([\w\-]+)\s*:\s*(.*)/;
        $v =~ s/[\015\012]//g;
        push @header, $k => $v;
    }
    return @header;
}

sub http_readline
{
    my $sock = shift;
    my $line;
    while ( read( $sock, my $buf, 1 ) )
    {
        last if $buf eq "\012";
        $line .= $buf;
    }
    return $line;
}

sub http_response
{
    my $sock = shift;
    my $status = shift || 200;
    my $body = shift;
    my %header = @_;

    my $status_msg = status_message($status);
    if (!$body and $status != 200 and $status != 301 and $status != 302 )
    {
        $body = "$status $status_msgColonel ERROR: $status $status_msg";
    }
    $header{'Date'} = time2str(time) unless defined $header{'Date'};
    $header{'Server'} = $colonel_version unless defined $header{'Server'};
    $header{'Content-Type'} = 'text/html' unless defined $header{'Content-Type'} ;
    use bytes;
    $header{'Content-Length'} = length($body) if defined $body and $body and !defined $header{'Content-Length'} ;
    $header{'WWW-Authenticate'} = 'Basic realm="Colonel Authentication System"' if $status == 401 ;

    my $head = "HTTP/1.0 $status $status_msg\015\012";
    foreach (keys %header)
    {
        $head .= "$_: " . $header{$_} . "\015\012";
    }

    my $output = $head . "\015\012";
    $output .= $body if defined $body and $body;
    print $sock $output;
    return length($output);
}

1;
__END__