mirror of
https://github.com/fhem/fhem-mirror.git
synced 2024-06-17 05:40:11 +00:00
cb644ae7c7
git-svn-id: https://svn.fhem.de/fhem/trunk/fhem@23472 2b470e98-0d58-463d-a4d8-8e2adae1ed80
364 lines
9.1 KiB
Perl
364 lines
9.1 KiB
Perl
##############################################
|
|
# $Id$
|
|
|
|
package main;
|
|
use strict;
|
|
use warnings;
|
|
use IO::Socket;
|
|
use vars qw($SSL_ERROR);
|
|
|
|
sub
|
|
TcpServer_Open($$$)
|
|
{
|
|
my ($hash, $port, $global) = @_;
|
|
my $name = $hash->{NAME};
|
|
|
|
if($port =~ m/^IPV6:(\d+)$/i) {
|
|
$port = $1;
|
|
eval "require IO::Socket::INET6; use Socket6;";
|
|
if($@) {
|
|
Log3 $hash, 1, $@;
|
|
Log3 $hash, 1, "$name: Can't load INET6, falling back to IPV4";
|
|
} else {
|
|
$hash->{IPV6} = 1;
|
|
}
|
|
}
|
|
|
|
my $lh = ($global ? ($global eq "global"? undef : $global) :
|
|
($hash->{IPV6} ? "::1" : "127.0.0.1"));
|
|
my @opts = (
|
|
Domain => ($hash->{IPV6} ? AF_INET6() : AF_UNSPEC), # Linux bug
|
|
LocalHost => $lh,
|
|
LocalPort => $port,
|
|
Listen => 32, # For Windows
|
|
Blocking => ($^O =~ /Win/ ? 1 : 0), # Needed for .WRITEBUFFER@darwin
|
|
ReuseAddr => 1
|
|
);
|
|
readingsSingleUpdate($hash, "state", "Initialized", 0);
|
|
$hash->{SERVERSOCKET} = $hash->{IPV6} ?
|
|
IO::Socket::INET6->new(@opts) :
|
|
IO::Socket::INET->new(@opts);
|
|
|
|
if(!$hash->{SERVERSOCKET}) {
|
|
return "$name: Can't open server port at $port: $!";
|
|
}
|
|
|
|
$hash->{FD} = $hash->{SERVERSOCKET}->fileno();
|
|
$hash->{PORT} = $hash->{SERVERSOCKET}->sockport();
|
|
|
|
$selectlist{"$name.$port"} = $hash;
|
|
Log3 $hash, 3, "$name: port ". $hash->{PORT} ." opened";
|
|
return undef;
|
|
}
|
|
|
|
sub
|
|
TcpServer_Accept($$)
|
|
{
|
|
my ($hash, $type) = @_;
|
|
|
|
my $name = $hash->{NAME};
|
|
my @clientinfo = $hash->{SERVERSOCKET}->accept();
|
|
if(!@clientinfo) {
|
|
Log3 $name, 1, "Accept failed ($name: $!)" if($! != EAGAIN);
|
|
return undef;
|
|
}
|
|
$hash->{CONNECTS}++;
|
|
|
|
my ($port, $iaddr) = $hash->{IPV6} ?
|
|
sockaddr_in6($clientinfo[1]) :
|
|
sockaddr_in($clientinfo[1]);
|
|
my $caddr = $hash->{IPV6} ?
|
|
inet_ntop(AF_INET6(), $iaddr) :
|
|
inet_ntoa($iaddr);
|
|
|
|
my $af = $attr{$name}{allowfrom};
|
|
if(!$af) {
|
|
my $re ="^(::ffff:)?(127|192.168|172.(1[6-9]|2[0-9]|3[01])|10|169.254)\\.|".
|
|
"^(f[cde]|::1)";
|
|
if($caddr !~ m/$re/) {
|
|
my %empty;
|
|
$hash->{SNAME} = $hash->{NAME};
|
|
my $auth = Authenticate($hash, \%empty);
|
|
delete $hash->{SNAME};
|
|
if($auth == 0) {
|
|
Log3 $name, 1,
|
|
"Connection refused from the non-local address $caddr:$port, ".
|
|
"as there is no working allowed instance defined for it";
|
|
close($clientinfo[0]);
|
|
return undef;
|
|
}
|
|
}
|
|
}
|
|
|
|
if($af) {
|
|
if($caddr !~ m/$af/) {
|
|
my $hostname = gethostbyaddr($iaddr, AF_INET);
|
|
if(!$hostname || $hostname !~ m/$af/) {
|
|
Log3 $name, 1, "Connection refused from $caddr:$port";
|
|
close($clientinfo[0]);
|
|
return undef;
|
|
}
|
|
}
|
|
}
|
|
|
|
#$clientinfo[0]->blocking(0); # Forum #24799
|
|
|
|
if($hash->{SSL}) {
|
|
# Forum #27565: SSLv23:!SSLv3:!SSLv2', #35004: TLSv12:!SSLv3
|
|
my $sslVersion = AttrVal($hash->{NAME}, "sslVersion",
|
|
AttrVal("global", "sslVersion", undef));
|
|
|
|
# Certs directory must be in the modpath, i.e. at the same level as the
|
|
# FHEM directory
|
|
my $mp = AttrVal("global", "modpath", ".");
|
|
my $certPrefix = AttrVal($name, "sslCertPrefix", "certs/server-");
|
|
my $ret;
|
|
eval {
|
|
$ret = IO::Socket::SSL->start_SSL($clientinfo[0], {
|
|
SSL_server => 1,
|
|
SSL_key_file => "$mp/${certPrefix}key.pem",
|
|
SSL_cert_file => "$mp/${certPrefix}cert.pem",
|
|
SSL_version => $sslVersion,
|
|
SSL_cipher_list => 'HIGH:!RC4:!eNULL:!aNULL',
|
|
Timeout => 4,
|
|
});
|
|
$! = EINVAL if(!$clientinfo[0]->blocking() && $!==EWOULDBLOCK);
|
|
};
|
|
my $err = $!;
|
|
if( !$ret
|
|
&& $err != EWOULDBLOCK
|
|
&& $err ne "Socket is not connected") {
|
|
$err = "" if(!$err);
|
|
$err .= " ".($SSL_ERROR ? $SSL_ERROR : IO::Socket::SSL::errstr());
|
|
my $errLevel = ($err =~ m/error:14094416:SSL/ ? 5 : 1); # 61511
|
|
Log3 $name, $errLevel, "$type SSL/HTTPS error: $err (peer: $caddr)"
|
|
if($err !~ m/error:00000000:lib.0.:func.0.:reason.0./); #Forum 56364
|
|
close($clientinfo[0]);
|
|
return undef;
|
|
}
|
|
}
|
|
|
|
my $cname = "${name}_${caddr}_${port}";
|
|
my %nhash;
|
|
$nhash{NR} = $devcount++;
|
|
$nhash{NAME} = $cname;
|
|
$nhash{PEER} = $caddr;
|
|
$nhash{PORT} = $port;
|
|
$nhash{FD} = $clientinfo[0]->fileno();
|
|
$nhash{CD} = $clientinfo[0]; # sysread / close won't work on fileno
|
|
$nhash{TYPE} = $type;
|
|
$nhash{SSL} = $hash->{SSL};
|
|
readingsSingleUpdate(\%nhash, "state", "Connected", 0);
|
|
$nhash{SNAME} = $name;
|
|
$nhash{TEMPORARY} = 1; # Don't want to save it
|
|
$nhash{BUF} = "";
|
|
$attr{$cname}{room} = "hidden";
|
|
$defs{$cname} = \%nhash;
|
|
$selectlist{$nhash{NAME}} = \%nhash;
|
|
|
|
my $ret = $clientinfo[0]->setsockopt(SOL_SOCKET, SO_KEEPALIVE, 1);
|
|
|
|
Log3 $name, 4, "Connection accepted from $nhash{NAME}";
|
|
return \%nhash;
|
|
}
|
|
|
|
sub
|
|
TcpServer_SetSSL($)
|
|
{
|
|
my ($hash) = @_;
|
|
eval "require IO::Socket::SSL";
|
|
if($@) {
|
|
Log3 $hash, 1, $@;
|
|
Log3 $hash, 1, "Can't load IO::Socket::SSL, falling back to HTTP";
|
|
return;
|
|
}
|
|
|
|
my $name = $hash->{NAME};
|
|
my $cp = AttrVal("global", "modpath", ".")."/".
|
|
AttrVal($name, "sslCertPrefix", "certs/server-");
|
|
if(! -r "${cp}key.pem") {
|
|
|
|
Log 1, "$name: Server certificate missing, trying to create one";
|
|
if($cp =~ m,^(.*)/(.*?), && ! -d $1 && !mkdir($1)) {
|
|
Log 1, "$name: failed to create $1: $!, falling back to HTTP";
|
|
return;
|
|
}
|
|
|
|
if(!open(FH,">certreq.txt")) {
|
|
Log 1, "$name: failed to create certreq.txt: $!, falling back to HTTP";
|
|
return;
|
|
}
|
|
print FH "[ req ]\nprompt = no\ndistinguished_name = dn\n\n".
|
|
"[ dn ]\nC = DE\nO = FHEM\nCN = home.localhost\n\n";
|
|
close(FH);
|
|
|
|
my $cmd = "openssl req -new -x509 -days 3650 -nodes -newkey rsa:2048 ".
|
|
"-config certreq.txt -out ${cp}cert.pem -keyout ${cp}key.pem";
|
|
Log 1, "Executing $cmd";
|
|
`$cmd`;
|
|
unlink("certreq.txt");
|
|
}
|
|
$hash->{SSL} = 1;
|
|
}
|
|
|
|
|
|
sub
|
|
TcpServer_Close($@)
|
|
{
|
|
my ($hash, $dodel, $ignoreNtfy) = @_;
|
|
my $name = $hash->{NAME};
|
|
|
|
if(defined($hash->{CD})) { # Clients
|
|
close($hash->{CD});
|
|
delete($hash->{CD});
|
|
delete($selectlist{$name});
|
|
delete($hash->{FD}); # Avoid Read->Close->Write
|
|
removeFromNtfyHash($name) if(!$ignoreNtfy); # can be expensive
|
|
}
|
|
|
|
if(defined($hash->{SERVERSOCKET})) { # Server
|
|
close($hash->{SERVERSOCKET});
|
|
$name = $name . "." . $hash->{PORT};
|
|
delete($selectlist{$name});
|
|
delete($hash->{FD}); # Avoid Read->Close->Write
|
|
}
|
|
|
|
if($dodel) {
|
|
delete $attr{$name};
|
|
delete $defs{$name};
|
|
} else {
|
|
$hash->{stacktrace} = stacktraceAsString(1);
|
|
}
|
|
return undef;
|
|
}
|
|
|
|
# close a (SSL-)Socket in local process
|
|
# avoids interfering with other processes using it
|
|
# this is critical for SSL and helps with other issues, too
|
|
sub
|
|
TcpServer_Disown($)
|
|
{
|
|
my ($hash) = @_;
|
|
my $name = $hash->{NAME};
|
|
|
|
if( defined($hash->{CD}) ){
|
|
if( $hash->{SSL} ){
|
|
$hash->{CD}->close( SSL_no_shutdown => 1);
|
|
} else {
|
|
close( $hash->{CD} );
|
|
}
|
|
delete($hash->{CD});
|
|
delete($selectlist{$name});
|
|
delete($hash->{FD}); # Avoid Read->Close->Write
|
|
$hash->{stacktrace} = stacktraceAsString(1);
|
|
}
|
|
|
|
return;
|
|
}
|
|
|
|
# wait for a socket to become ready
|
|
# takes IO::Socket::SSL + non-blocking into account
|
|
sub
|
|
TcpServer_Wait($$)
|
|
{
|
|
my( $hash, $direction ) = @_;
|
|
|
|
my $read = '';
|
|
my $write ='';
|
|
|
|
if( $direction eq 'read' || $hash->{wantRead} ){
|
|
vec( $read, $hash->{FD}, 1) = 1;
|
|
} elsif( $direction eq 'write' || $hash->{wantWrite} ){
|
|
vec( $write, $hash->{FD}, 1) = 1;
|
|
} else {
|
|
return undef;
|
|
}
|
|
|
|
my $ret = select( $read, $write, undef, undef );
|
|
return if $ret == -1;
|
|
|
|
if( vec( $read, $hash->{FD}, 1) ){
|
|
delete $hash->{wantRead};
|
|
}
|
|
if( vec( $write, $hash->{FD}, 1) ){
|
|
delete $hash->{wantWrite};
|
|
}
|
|
|
|
# return true on success
|
|
return 1;
|
|
}
|
|
|
|
# WantRead/Write: keep ssl constants local
|
|
sub
|
|
TcpServer_WantRead($)
|
|
{
|
|
my( $hash ) = @_;
|
|
|
|
return $hash->{SSL}
|
|
&& $hash->{CD}
|
|
&& $hash->{CD}->errstr == &IO::Socket::SSL::SSL_WANT_READ;
|
|
}
|
|
|
|
sub
|
|
TcpServer_WantWrite($)
|
|
{
|
|
my( $hash ) = @_;
|
|
|
|
return $hash->{SSL}
|
|
&& $hash->{CD}
|
|
&& $hash->{CD}->errstr == &IO::Socket::SSL::SSL_WANT_WRITE;
|
|
}
|
|
|
|
# write until all data is done.
|
|
# hanldes both, blocking and non-blocking sockets
|
|
# ... with or without SSL
|
|
sub
|
|
TcpServer_WriteBlocking($$)
|
|
{
|
|
my( $hash, $txt ) = @_;
|
|
|
|
if($hash->{WriteFn}) { # FWTP needs it
|
|
no strict "refs";
|
|
return &{$hash->{WriteFn}}($hash, \$txt);
|
|
use strict "refs";
|
|
}
|
|
|
|
my $sock = $hash->{CD};
|
|
return undef if(!$sock);
|
|
my $off = 0;
|
|
my $len = length($txt);
|
|
|
|
while($off < $len) {
|
|
if(!TcpServer_Wait($hash, 'write')) {
|
|
TcpServer_Close($hash);
|
|
return undef;
|
|
}
|
|
|
|
my $ret;
|
|
eval { $ret = syswrite($sock, $txt, $len-$off, $off); }; # Wide character
|
|
if($@) {
|
|
Log 1, $@;
|
|
Log 1, "txt:".join(":",unpack("C*",$txt)).",len:$len,off:$off";
|
|
stacktrace();
|
|
}
|
|
|
|
if( defined $ret ){
|
|
$off += $ret;
|
|
my $sh = $defs{$hash->{SNAME}};
|
|
$sh->{BYTES_WRITTEN} += $ret if(defined($sh->{BYTES_WRITTEN}));
|
|
|
|
} elsif( $! == EWOULDBLOCK ){
|
|
$hash->{wantRead} = 1
|
|
if TcpServer_WantRead($hash);
|
|
|
|
} else {
|
|
TcpServer_Close($hash);
|
|
return undef; # error
|
|
}
|
|
}
|
|
|
|
return 1; # success
|
|
}
|
|
|
|
1;
|