ip-camera-relay.pl

#!/usr/bin/perl
################################################################################
# IP camera relay (Webcam/VAPIX relay)		 (C)2015-2019 nabe@abk
################################################################################
# This program is licensed under GPLv2 or later.
#
use strict;
use Socket qw(:all);
use Fcntl;
################################################################################
print "IP camera relay	2019/12/19 (C)nabe\@abk\n\n";
################################################################################
my $DEBUG = 0;

my $TIMEOUT     = 1;		# [sec] Connection Timeout in parse header
my $RETRY_WAIT  = 1;		# [sec] IP Camera reconnect time
my $SELECT_WAIT = 0.1;		# [sec]
my $BIND_PORT   = 8888;
my $BOUNDARY    = 'IPCameraRelayPlBboundary';
################################################################################
# Options
################################################################################
my $BLANK_IMG;
my @CAMERAS;
{
	my $black;
	my @ary = @ARGV;
	while(@ary) {
		my $opt = shift(@ary);
		if ($opt eq '-i') {
			my $file = shift(@ary);
			$BLANK_IMG = &load_jpeg_file( $file );
			if (!$BLANK_IMG) {
				print STDERR "Can't read jpeg : $file\n";
			}
			next;
		}
		if ($opt eq '-p') {
			$BIND_PORT = int(shift(@ary));
			next;
		}
		if ($opt eq '-r') {
			$RETRY_WAIT = shift(@ary) + 0;
			if ($RETRY_WAIT < 1) { $RETRY_WAIT = 1; }
			next;
		}
		if ($opt eq '-b') {
			$black = 1;
			next;
		}
		if ($opt eq '-d') {
			$DEBUG = 1;
			$TIMEOUT = 999;
			next;
		}

		if ($opt !~ m|^(?:http://)?([\w\-\.]+)(?:\:(\d+))?(.*)|i) {
			print STDERR "Unknown option : $opt\n";
			next;
		}
		my $host = $1;
		my $port = $2 || 80;
		my $path = $3 || '/';
		my $num  = $#CAMERAS+1;
		print "Camera_$num http://$host:$port$path\n";
		my $addr = pack_sockaddr_in($port, inet_aton($host));
		push(@CAMERAS,{
			host => $host,
			port => $port,
			path => $path,
			addr => $addr
		});
	}
	$BLANK_IMG ||= $black ? &load_blank_image_black_640x480() : &load_blank_image_blue_640x480();
	$BLANK_IMG   = &image2block( $BLANK_IMG );

	if (!@CAMERAS) {
		print <<HELP;
Usage:	$0 [options] Camera-Stream-URL [Stream-URL2] ...
Available options are:
	-p port	bind port for client
	-r sec	retry interval time(sec). default 1 sec
	-i file	blank jpeg image. Is the same as camera's image size(pixel)
	  	(default) 640x480 blue image
	-b	blank image set to 640x480 pixel black image
	-d	debug mode

(Camera-Stream-URL examples)
	http://192.168.1.101/video
	http://192.168.1.102:8080/mjpeg
	192.168.1.110:8080/path
	192.168.1.120:8080

	If exists multiple URL, try connect round robin URL.
	This software works only Motion JPEG stream.
HELP
		exit(0);
	}
}

################################################################################
# Create Server sock
################################################################################
my $srv;
socket($srv, PF_INET, SOCK_STREAM, 0) || die "Can't open socket";
setsockopt($srv, SOL_SOCKET, SO_REUSEADDR, 1);
bind($srv, sockaddr_in($BIND_PORT, INADDR_ANY)) || die("bind failed: port=$BIND_PORT");
listen($srv, SOMAXCONN);
print "Bind port  : $BIND_PORT\n";
print "Retry wait : $RETRY_WAIT sec\n";

$RETRY_WAIT /= ($#CAMERAS+1);

################################################################################
# Create Video IP receive sock
################################################################################
my $rec;
my $CAMERA;
my $camera_c = 0;
sub connect_receiver {
	$CAMERA = $CAMERAS[ $camera_c ];
	$camera_c++;
	if ($#CAMERAS < $camera_c) { $camera_c=0; }

	socket($rec, PF_INET, SOCK_STREAM, 0) || die "Can't open socket";
	&set_nonblock($rec);
	connect($rec, $CAMERA->{addr});
	&set_block($rec);
	$DEBUG && print "[IP Camera] Try connect $CAMERA->{host}:$CAMERA->{port}\n";
}
&connect_receiver();

################################################################################
# Main Loop
################################################################################
my @clients;
my $read_bits;
my $wri_bits;
my $err_bits;
my $state;
my %hosts;

$SIG{PIPE} = sub { };
$SIG{INT}  = sub {
	close($srv);
	close($rec);
	foreach(@clients) { close($_); }
	exit(-1);
};

&set_bit($read_bits, $srv);
my $rec_state;
my $rec_boundary;
my $rec_wait = 0;
sub close_receiver {
	$rec_wait = $RETRY_WAIT;
	close($rec);
}

while (1) {
	my $r = $read_bits;
	my $w;
	if ($rec_wait <= 0) {
		&set_bit($r, $rec);
		&set_bit($w, $rec);
	}
	select($r, $w, undef, $SELECT_WAIT);

	# receiver connect wait
	if ($rec_wait > 0) { $rec_wait -= $SELECT_WAIT; }

	# new client
	while(&check_bit($r, $srv)) {
		my $client;
		my $addr = accept($client, $srv);
		if (!$addr) { last; }
		setsockopt($client, IPPROTO_TCP, TCP_NODELAY, 1);

		my($port, $ip_bin) = sockaddr_in($addr);
		my $ip   = inet_ntoa($ip_bin);
		$DEBUG && print "Connection from $ip:$port\n";
		$hosts{$client} = "$ip:$port";

		local $SIG{ALRM} = sub { close($client); };
		alarm( $TIMEOUT );
		while (my $buf = <$client>) {
			if ($buf =~ m/^\r?\n$/) { last; }
		}
		&send_response_header($client);
		alarm(0);

		push(@clients, $client);
		last;
	}

	#----------------------------------------------------------------
	# ip stream receive
	#----------------------------------------------------------------
	while(!$rec_state && &check_bit($w, $rec)) {
		local $SIG{ALRM} = sub { close($rec); };
		alarm( $TIMEOUT );

		my $size = &send_request_header($rec, $CAMERA);
		if (!$size) {
			&close_receiver();
			&connect_receiver();
			alarm(0);
			last;
		}

		$rec_state = 1;
		while ((my $line = <$rec>) || 1) {
			$line =~ s/[\r\n]//g;
			if ($line =~ m|^Content-Type:\s*[\w/-]+\s*;\s*boundary=(.*)|) {
				$rec_boundary = "--$1\r\n";
				next;
			}
			if ($line eq '') { last; }
		}
		alarm(0);

		$DEBUG && print "[IP Camera] Connected $CAMERA->{host}:$CAMERA->{port}\n";
		next;
	}

	my $img;
	if ($rec_state && &check_bit($r, $rec)) {
		$img = &read_one_block($rec, $rec_boundary);
		if (!$img) {
			&close_receiver();
			&connect_receiver();
			$rec_state = 0;
			next;
		}
		$DEBUG && print "[IP Camera] Receive one block\n";
	}
	if ($rec_state && !$img) { next; }

	#----------------------------------------------------------------
	# Stream send
	#----------------------------------------------------------------
	foreach(@clients) {
		my $size = &socket_out($_, $img ? "--$BOUNDARY\r\n$img" : $BLANK_IMG);
		if (!$size) {
			$DEBUG && print "Connection close $hosts{$_}\n";
			close($_);
			$_ = undef;
		}
	}
	@clients = grep { $_ } @clients;
}
exit(0);

################################################################################
# network subroutine
################################################################################
sub set_bit	{        vec($_[0], fileno($_[1]), 1) = 1; }
sub check_bit	{ return vec($_[0], fileno($_[1]), 1); }

sub socket_out {
	my $sock = shift;
	return syswrite($sock, $_[0], length($_[0]) );
}

sub set_block {
	my $sock = shift;
	return &set_nonblock($sock, 1);
}
sub set_nonblock {
	my $sock  = shift;
	my $block = shift;
	if ($^O eq 'MSWin32') {
	      my $f = 0x8004667e;	# FIONBIO for windows
	      my $v = pack("L", $block ? 0 : 1);
	      ioctl($sock, $f, $v);
	      return;
	}
	my $flags = fcntl($sock, F_GETFL, 0);
	if ($block) {
		$flags &= ~O_NONBLOCK;
	} else {
		$flags |=  O_NONBLOCK;
	}
	fcntl($sock, F_SETFL, $flags);
}
################################################################################
# print_response_header
################################################################################
sub send_request_header {
	my $sock = shift;
	my $info = shift;
	my $p = ($info->{port} == 80) ? '' : ":$info->{port}";
	my $request = <<REQUEST;
GET $info->{path} HTTP/1.1
Host: $info->{host}$p

REQUEST
	$request =~ s/\r?\n/\r\n/g;
	return &socket_out($sock, $request);
}

sub send_response_header {
	my $sock = shift;
	my $response = <<RESPONSE;
HTTP/1.1 200 OK
Connection: close
Server: IP Camera Relay Server
Cache-Control: no-store, no-cache, must-revalidate, pre-check=0, post-check=0, max-age=0
Pragma: no-cache
Expires: -1
Access-Control-Allow-Origin: *
Content-Type: multipart/x-mixed-replace;boundary=$BOUNDARY

RESPONSE
	$response =~ s/\r?\n/\r\n/g;
	return &socket_out($sock, $response);
}

################################################################################
# recieve packet
################################################################################
sub read_one_block {
	my $sock  = shift;
	my $bound = shift;
	while(my $line = <$sock>) {
		if ($line eq $bound) { last; }
	}

	# (Example)
	# --Ba4oTvQMY8ew04N8dcnM
	# Content-Type: image/jpeg
	# Content-Length: 22534
	my $img = "";
	my $len;
	while(my $line = <$sock>) {
		$img .= $line;
		if ($line =~ /^Content-Length:\s*(\d+)/) {
			$len = $1;
			next;
		}
		if ($line eq "\r\n") { last; }
	}

	my $size = $len && read($sock, $img, $len, length($img));
	if ($len == 0 || $size != $len) {
		return;
	}
	return $img;
}

################################################################################
# blank images
################################################################################
sub image2block {
	my $img = shift;
	my $len = length($img);
	my $header = <<HEADER;
--$BOUNDARY
Content-Type: image/jpeg
Content-Length: $len

HEADER
	$header =~ s/\r?\n/\r\n/g;
	return "$header$img";
}

sub load_blank_image_black_640x480 {
  return  "\xff\xd8\xff\xe0\x00\x10\x4a\x46\x49\x46\x00\x01\x01\x00\x00\x01"
	. "\x00\x01\x00\x00\xff\xdb\x00\x43\x00\x02\x02\x02\x02\x02\x01\x02"
	. "\x02\x02\x02\x03\x02\x02\x03\x03\x06\x04\x03\x03\x03\x03\x07\x05"
	. "\x05\x04\x06\x08\x07\x09\x08\x08\x07\x08\x08\x09\x0a\x0d\x0b\x09"
	. "\x0a\x0c\x0a\x08\x08\x0b\x0f\x0b\x0c\x0d\x0e\x0e\x0f\x0e\x09\x0b"
	. "\x10\x11\x10\x0e\x11\x0d\x0e\x0e\x0e\xff\xdb\x00\x43\x01\x02\x03"
	. "\x03\x03\x03\x03\x07\x04\x04\x07\x0e\x09\x08\x09\x0e\x0e\x0e\x0e"
	. "\x0e\x0e\x0e\x0e\x0e\x0e\x0e\x0e\x0e\x0e\x0e\x0e\x0e\x0e\x0e\x0e"
	. "\x0e\x0e\x0e\x0e\x0e\x0e\x0e\x0e\x0e\x0e\x0e\x0e\x0e\x0e\x0e\x0e"
	. "\x0e\x0e\x0e\x0e\x0e\x0e\x0e\x0e\x0e\x0e\x0e\x0e\x0e\x0e\xff\xc0"
	. "\x00\x11\x08\x01\xe0\x02\x80\x03\x01\x22\x00\x02\x11\x01\x03\x11"
	. "\x01\xff\xc4\x00\x15\x00\x01\x01\x00\x00\x00\x00\x00\x00\x00\x00"
	. "\x00\x00\x00\x00\x00\x00\x00\x0a\xff\xc4\x00\x14\x10\x01\x00\x00"
	. "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xc4"
	. "\x00\x14\x01\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"
	. "\x00\x00\x00\x00\xff\xc4\x00\x14\x11\x01\x00\x00\x00\x00\x00\x00"
	. "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xda\x00\x0c\x03\x01"
	. "\x00\x02\x11\x03\x11\x00\x3f\x00\x9f\xf0\x00\x00\x00\x00\x00\x00"
	.("\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00" x 112)
	. "\x00\x1f\xff\xd9";
}

sub load_blank_image_blue_640x480 {
  return  "\xff\xd8\xff\xe0\x00\x10\x4a\x46\x49\x46\x00\x01\x01\x00\x00\x01"
	. "\x00\x01\x00\x00\xff\xdb\x00\x43\x00\x02\x02\x02\x02\x02\x01\x02"
	. "\x02\x02\x02\x03\x02\x02\x03\x03\x06\x04\x03\x03\x03\x03\x07\x05"
	. "\x05\x04\x06\x08\x07\x09\x08\x08\x07\x08\x08\x09\x0a\x0d\x0b\x09"
	. "\x0a\x0c\x0a\x08\x08\x0b\x0f\x0b\x0c\x0d\x0e\x0e\x0f\x0e\x09\x0b"
	. "\x10\x11\x10\x0e\x11\x0d\x0e\x0e\x0e\xff\xdb\x00\x43\x01\x02\x03"
	. "\x03\x03\x03\x03\x07\x04\x04\x07\x0e\x09\x08\x09\x0e\x0e\x0e\x0e"
	. "\x0e\x0e\x0e\x0e\x0e\x0e\x0e\x0e\x0e\x0e\x0e\x0e\x0e\x0e\x0e\x0e"
	. "\x0e\x0e\x0e\x0e\x0e\x0e\x0e\x0e\x0e\x0e\x0e\x0e\x0e\x0e\x0e\x0e"
	. "\x0e\x0e\x0e\x0e\x0e\x0e\x0e\x0e\x0e\x0e\x0e\x0e\x0e\x0e\xff\xc0"
	. "\x00\x11\x08\x01\xe0\x02\x80\x03\x01\x22\x00\x02\x11\x01\x03\x11"
	. "\x01\xff\xc4\x00\x15\x00\x01\x01\x00\x00\x00\x00\x00\x00\x00\x00"
	. "\x00\x00\x00\x00\x00\x00\x00\x09\xff\xc4\x00\x14\x10\x01\x00\x00"
	. "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xc4"
	. "\x00\x16\x01\x01\x01\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"
	. "\x00\x00\x00\x00\x07\x09\xff\xc4\x00\x14\x11\x01\x00\x00\x00\x00"
	. "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xda\x00\x0c"
	. "\x03\x01\x00\x02\x11\x03\x11\x00\x3f\x00\x8e\x60\x37\xf1\x2b\x00"
	.("\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00" x 112)
	. "\x00\x00\x00\x00\x00\x07\xff\xd9";
}

################################################################################
# load jpeg file
################################################################################
sub load_jpeg_file {
	my $file = shift;

	my $fh;
	my $data;
	sysopen($fh, $file, O_RDONLY);
	binmode($fh);
	read($fh, $data, -s $fh);
	close($fh);

	# check JPEG header
	if ($data !~ /^\xFF\xD8\xFF\xE0..JFIF/s) { return ; }
	return $data;
}