diff --git a/bin/mh b/bin/mh index fc38d6565..03a661a80 100755 --- a/bin/mh +++ b/bin/mh @@ -808,6 +808,7 @@ sub setup { use EIB_Items; use EIB_Device; use ajax; + use AlexaBridge; eval "use BSC"; # Base_Items @@ -978,6 +979,7 @@ sub setup { &socket_open($port_name); } + &AlexaBridge::startup; # Start the AlexaBridge sockets, in lib/AlexaBridge.pm &xAP::startup; # Start the xAP sockets, in lib/xAP_Items.pm &xPL::startup; # Start the xPL sockets, in lib/xPL_Items.pm &EIB_Device::startup; # Start the EIB device, in lib/EIB_Device.pm @@ -2935,6 +2937,7 @@ sub check_for_socket_data { { ( my $from_port, my $from_ip ) = sockaddr_in($from_saddr) if $from_saddr; + $Socket_Ports{$port_name}{from_ipport} = $from_saddr; $Socket_Ports{$port_name}{from_port} = $from_port; $Socket_Ports{$port_name}{from_ip} = $from_ip; } diff --git a/lib/AlexaBridge.pm b/lib/AlexaBridge.pm new file mode 100644 index 000000000..468501321 --- /dev/null +++ b/lib/AlexaBridge.pm @@ -0,0 +1,1229 @@ +=head1 B + +=head2 DESCRIPTION + +Module emulates the HUE to allow for direct connectivity from the Amazon Echo, Google Home, and any other devices that support the HUE bridge. + +=head2 CONFIGURATION + + +The AlexaBridge_Item object holds the configured Misterhouse objects that are presented to the Amazon Echo or Google Home. +See + +=head2 mh.private.ini Configuration + +Note: +You must use port 80 for Google Home, it is locked down to port 80. +The user running MH must be root to run on port 80 or you have to give the MH user rights to use the port. + +For Google Home and a reverse proxy (Apache/IIS/etc): + + alexa_enable = 1 + alexaHttpPortCount = 0 # disables all proxy ports + alexaHttpPort = 80 # tells the module to send port 80 in the SSDP response and look for port 80 in the HTTP host header + alexaObjectsPerGet = 300 # Google Home can handle us returning all objects in a single response + +For Google Home using the builtin proxy port: + + alexa_enable = 1 + alexaHttpPortCount = 1 # Open 1 proxy port on port 80 (We default to port 80 so no need to define it) + alexaNoDefaultHttp = 1 # Disable responding on the default MH web port because Google Home will not use it any way. + alexaObjectsPerGet = 300 # Google Home can handle us returning all objects in a single response + + +For Echo (Chunked method): + + alexa_enable = 1 + alexaEnableChunked = 1 + + +For Echo (Multi-port method): +This method should not be needed unless for some reason your Echo does not work with the Chunked method. + + alexa_enable = 1 + alexaHttpPortCount = 1 # Open 1 proxy port for a total of 2 ports including the default MH web port. We only support 1 for now unless I see a need for more. + alexaHttpPort=8085 # The proxy port will be on port 8085, this port should be higher than the MH web port so it is used first. + + +# All options + + alexa_enable # Enable the module + alexaEnableChunked # Enable chunked return method (For the Echo) + alexaHttpPortCount # Amount of proxy ports to open + alexaNoDefaultHttp # Disable responding on the default MH web port + alexaObjectsPerGet # Amount of MH objects we return per GET from the Echo/GH + alexaHttpPort # First proxy port number + alexaMac # This is used in the SSDP response, We discover it so it does not need to be defined unless something goes wrong + alexaHttpIp # This is the IP of the local MH server, We discover it so it does not need to be defined unless something goes wrong + +=head2 Defining the Primary Object + +The object can be defined in the user code or in a .mht file. + +In mht: + + ALEX_BRIDGE, Alexa + + +Or in user code: + + $Alexa = new AlexaBridge(); # parent object + + +=head2 NOTES + +The most important part of the configuration is mapping the objects/code you want to present to the module (Echo/Google Home/Etc.). +This allows the user to map pretty much anything in MH to a Echo/GH command. + + ALEXABRIDGE_ADD, , , , + , , + + - This is the only required parameter. If you are +good with the defaults, you can add an object like: +# In MHT + + ALEXABRIDGE_ADD, AlexaItems, light1 + +# or in user code + + $AlexaItems->add('$light1'); + + - This defaults to using the without the $. If want to change the name you say to the +Echo/GH to control the object, you can define it here. You can also make +aliases for objects so it's easier to remember. + + - This defaults to 'set' which +works for most objects. You can also put a code reference or +'run_voice_cmd'. + + - If you want to set an object to +something other than 'on' when you say 'on' to the Echo/GH, you can define +it here. Defaults to 'on'. + + - If you want to set an object to +something other than 'off' when you say 'off' to the Echo/GH, you can +define it here. Defaults to 'off'. + + - If your object uses a custom sub to +get the state, define it here. Defaults to 'state' which works for most +objects. + + +The dim % is the actual number you say to Alexa, so if you say "Alexa,Set +Light 1 to 75 %" then the dim % value will be 75. + + +The module supports 300 devices which is the max supported by the Echo + + + +=head2 Complete Examples + + +MHT examples: + + ALEX_BRIDGE, Alexa + ALEXABRIDGE_ITEM, AlexaItems, Alexa + ALEXABRIDGE_ADD, AlexaItems, light1 light1, set, on, off, state # these are the defaults + ALEXABRIDGE_ADD, AlexaItems, light1 # same as the line above + ALEXABRIDGE_ADD, AlexaItems, light3, Test_Light_3 # if you want to change the name you say + ALEXABRIDGE_ADD, AlexaItems, testsub, Test_Sub, \&testsub +# "!" will be replaced with the action ( on/off/ ), so if you say "turn on test voice" then the module will run run_voice_cmd("test voice on") + ALEXABRIDGE_ADD, AlexaItems, test_voice_!, Test_Voice, run_voice_cmd + + +User code examples: + + $Alexa = new AlexaBridge(); # parent object + $AlexaItems = new AlexaBridge_Item($Alexa); # child object + + $AlexaItems->add('$light1','light1','set','on','off','state'); # This is the same as $AlexaItems->add('$light1') + + + +To change the name of an object to a more natural name that you would say to the Echo/GH: + + $AlexaItems->add('$GarageHall_light_front','Garage_Hall_light'); + + +To map a voice command, # is replaced by the Echo/GH command (on/off/dim%). +My actual voice command in MH is "set night mode on", so I configure it like: + + $AlexaItems->add('set night mode !','NightMode','run_voice_cmd'); + + If I say "Alexa, Turn on Night Mode", run_voice_cmd("set night mode on") is run in MH. + + +To configure a user code sub: +The actual name (argument 1) can be anything. +A code ref must be used. +When the sub is run 2 arguments are passed to it: Argument 1 is (state or set) Argument 2 is: (on/off/). + +# Mht file + + ALEXABRIDGE_ADD, AlexaItems, testsub, Test_Sub, &testsub + +# User Code + + $AlexaItems->add('testsub','Test_Sub',\&testsub); # say "Alexa, Turn on Test Sub", &testsub('set','on') is run in MH. + + +# I have an Insteon thermostat, the Insteon object name is $thermostat and I configured it like: + + ALEXABRIDGE_ADD, AlexaItems, thermostat, Heat, heat_setpoint, on, off, get_heat_sp + +# say "Alexa, Set Heat to 73", $thermostat->heat_setpoint("73") is run in MH. + + ALEXABRIDGE_ADD, AlexaItems, thermostat, Cool, cool_setpoint, on, off, get_cool_sp + + +In order to be able to say things like "Alexa, set thermostat up by 2", a sub must be created in user code +When the above is said to the Echo, it first gets the current state, then subtracts or adds the amount that was said. + + sub temperature { + my ($type, $state) = @_; + + # $type is state or set + # $state is the number, on, off, etc + + # we are changing heat and cool so just return a static number, we just need the diff + # because the Echo will add or subtact the amount that was said to it. + # so if we say "set thermostat up by 2", 52 will be returned in $state + if ($type eq 'state') { return 50; } + + return '' unless ($state =~ /\d+/); Make sure we have a number + return '' if ($state > 65); # Dont allow changes over 15 + return '' if ($state < 35); # Dont allow changes over 15 + my ( $heatsp, $coolsp ); + $state = ($state - 50); # subtract the amount we return above to get the actual amount to change. + $coolsp = ((state $thermo_setpoint_c) + $state); + $heatsp = ((state $thermo_setpoint_h) + $state); + # The Insteon thermostat has an issue when setting both heat and cool at the same time, so the timer is a work around. + $alexa_temp_timer = new Timer; + $thermostat->cool_setpoint($coolsp); + set $alexa_temp_timer '7', sub { $thermostat->heat_setpoint($heatsp) } + } + +# Map our new temperature sub in the .mht file so the Echo/Google Home can discover it + + ALEXABRIDGE_ADD, AlexaItems, thermostat, thermostat, &temperature + + + +I have a script that I use to control my AV equipment and I can run it via +ssh, so I made a voice command in MH: + + $v_set_tv_mode = new Voice_Cmd("set tv mode [on,off,hbo,netflix,roku,directtv,xbmc,wii]"); + $p_set_tv_mode = new Process_Item; + if (my $state = said $v_set_tv_mode) { + set $p_set_tv_mode "/usr/bin/ssh wayne\@192.168.1.10 \"sudo /usr/local/HomeAVControl/bin/input_change $state\""; + start $p_set_tv_mode; + } + +I added the following to my .mht file: + + ALEXABRIDGE_ADD, AlexaItems, set_tv_mode_!, DirectTv, run_voice_cmd, directtv, directtv + ALEXABRIDGE_ADD, AlexaItems, set_tv_mode_!, Roku, run_voice_cmd, roku, roku + ALEXABRIDGE_ADD, AlexaItems, set_tv_mode_!, xbmc, run_voice_cmd, xbmc, xbmc + ALEXABRIDGE_ADD, AlexaItems, set_tv_mode_!, wii, run_voice_cmd, wii, wii + ALEXABRIDGE_ADD, AlexaItems, set_tv_mode_!, Hbo, run_voice_cmd, hbo, hbo + ALEXABRIDGE_ADD, AlexaItems, set_tv_mode_!, Netflix, run_voice_cmd, netflix, netflix + + + +=head2 INHERITS + +L + +HTTP::Date +IO::Compress::Gzip +Time::HiRes +Net::Address::Ethernet +Storable +Socket +IO::Socket::INET +IO::Socket::Multicast + +=over + +=cut + +package AlexaBridge; + +@AlexaBridge::ISA = ('Generic_Item'); + +use Carp; +use IO::Socket::INET; +use Socket; +use IO::Socket::Multicast; + + +my ($LOCAL_IP, $LOCAL_MAC) = &DiscoverAddy unless ( (defined($::config_parms{'alexaMac'})) && (defined($::config_parms{'alexaHttpIp'})) ); +$LOCAL_IP = $::config_parms{'alexaHttpIp'} if defined($::config_parms{'alexaHttpIp'}); +$LOCAL_MAC = $::config_parms{'alexaMac'} if defined($::config_parms{'alexaMac'}); + +my $AlexaGlobal; + +sub startup { + unless ($::config_parms{'alexa_enable'}) { return } + &open_port(); + &::MainLoop_pre_add_hook( \&AlexaBridge::check_for_data, 1 ); +} + +sub open_port { + + my $SSDP_PORT = '1900'; + my $AlexaHttpPortCount = $::config_parms{'alexaHttpPortCount'} || '0'; + if ($AlexaHttpPortCount) { + $AlexaHttpPortCount = ($AlexaHttpPortCount - 1); + for my $count (0..$AlexaHttpPortCount) { + my $AlexaHttpPort = $::config_parms{'alexaHttpPort'} || '80'; + $AlexaHttpPort = ($AlexaHttpPort + $count); + my $AlexaHttpName = 'alexaServer'.$count; + &http_ports($AlexaHttpName, $AlexaHttpPort); + $AlexaGlobal->{http_sockets}->{$AlexaHttpName} = new Socket_Item( undef, undef, $AlexaHttpName ); + $AlexaGlobal->{http_sockets}->{$AlexaHttpName}->{port} = $AlexaHttpPort; + &main::print_log ("Alexa open_port: p=$AlexaHttpPort pn=$AlexaHttpName s=$AlexaHttpName\n") + if $main::Debug{alexa}; + } + + $AlexaGlobal->{http_sender}->{'alexa_http_sender'} = new Socket_Item('alexa_http_sender', undef, $::config_parms{'http_server'}.':'.$::config_parms{'http_port'}, 'alexa_http_sender', 'tcp', 'raw'); + } + + my $notificationPort = $::config_parms{'alexa_notification_port'} || '50000'; + + + my $ssdpNotificationName = 'alexaSsdpNotification'; + $ssdpNotificationSocket = new IO::Socket::INET->new( + Proto => 'udp', + LocalPort => $notificationPort) + || &main::print_log( "\nError: Could not start a udp alexa multicast notification sender on $notificationPort: $@\n\n" ) && return; + + setsockopt($ssdpNotificationSocket, + getprotobyname('ip'), + IP_MULTICAST_TTL, + pack 'I', 4); + $::Socket_Ports{$ssdpNotificationName}{protocol} = 'udp'; + $::Socket_Ports{$ssdpNotificationName}{datatype} = 'raw'; + $::Socket_Ports{$ssdpNotificationName}{port} = $notificationPort; + $::Socket_Ports{$ssdpNotificationName}{sock} = $ssdpNotificationSocket; + $::Socket_Ports{$ssdpNotificationName}{socka} = $ssdpNotificationSocket; # UDP ports are always "active" + $AlexaGlobal->{'ssdp_send'} = new Socket_Item( undef, undef, $ssdpNotificationName ); + + printf " - creating %-15s on %3s %5s %s\n", $ssdpNotificationName, 'udp', $notificationPort; + &main::print_log ("Alexa open_port: p=$notificationPort pn=$ssdpNotificationName s=".$AlexaGlobal->{'ssdp_send'} ."\n") + if $main::Debug{alexa}; + + + my $ssdpListenName = 'alexaSsdpListen'; + my $ssdpListenSocket = new IO::Socket::Multicast->new( + LocalPort => $SSDP_PORT, + Proto => 'udp', + Reuse => 1) + || &main::print_log( "\nError: Could not start a udp alexa multicast listen server on ". $SSDP_PORT .$@ ."\n\n" ) && return; + $ssdpListenSocket->mcast_add('239.255.255.250'); + $::Socket_Ports{$ssdpListenName}{protocol} = 'udp'; + $::Socket_Ports{$ssdpListenName}{datatype} = 'raw'; + $::Socket_Ports{$ssdpListenName}{port} = $SSDP_PORT; + $::Socket_Ports{$ssdpListenName}{sock} = $ssdpListenSocket; + $::Socket_Ports{$ssdpListenName}{socka} = $ssdpListenSocket; # UDP ports are always "active" + $AlexaGlobal->{'ssdp_listen'} = new Socket_Item( undef, undef, $ssdpListenName ); + + printf " - creating %-15s on %3s %5s %s\n", $ssdpListenName, 'udp', $SSDP_PORT; + &main::print_log ("Alexa open_port: p=$ssdpPort pn=$ssdpListenName s=" .$AlexaGlobal->{'ssdp_listen'} ."\n") + if $main::Debug{alexa}; + + return 1; +} + + +sub http_ports { + my ( $AlexaHttpName, $AlexaHttpPort ) = @_; + my $AlexaHttpSocket = new IO::Socket::INET->new( + Proto => 'tcp', + LocalPort => $AlexaHttpPort, + Reuse => 1, + Listen => 10) + || &main::print_log( "\nError: Could not start a tcp $AlexaHttpName on $AlexaHttpPort: $@\n\n" ) && return; + + $::Socket_Ports{$AlexaHttpName}{protocol} = 'tcp'; + $::Socket_Ports{$AlexaHttpName}{datatype} = 'raw'; + $::Socket_Ports{$AlexaHttpName}{port} = $AlexaHttpPort; + $::Socket_Ports{$AlexaHttpName}{sock} = $AlexaHttpSocket; + $::Socket_Ports{$AlexaHttpName}{socka} = $AlexaHttpSocket; + printf " - creating %-15s on %3s %5s %s\n", $AlexaHttpName, 'tcp', $AlexaHttpPort; +} + +sub check_for_data { + my $alexa_http_sender = $AlexaGlobal->{http_sender}->{'alexa_http_sender'}; + my $alexa_ssdp_listen = $AlexaGlobal->{ssdp_listen}; + #foreach my $AlexaHttpName ( keys %{$AlexaGlobal->{http_sockets}} ) { + my $AlexaHttpName = 'alexaServer0'; + my $alexa_listen = $AlexaGlobal->{http_sockets}{$AlexaHttpName}; + + if ( $alexa_listen && ( my $alexa_data = said $alexa_listen ) ) { + my $client_ip_address = $alexa_listen->peer; + &main::print_log( "[Alexa] Debug: Peer: $client_ip_address Sent Data" ) if $main::Debug{'alexa'} >= 2; + &main::print_log( "[Alexa] Debug: Peer: $client_ip_address Data IN - $alexa_data" ) if $main::Debug{'alexa'} >= 5; + $client_ip_address =~ s/:.*//; + my $client_port = $alexa_listen->peer; + $client_port =~ s/.*\://; + $AlexaGlobal->{http_client}->{$client_ip_address}->{$client_port}->{time} = time; + $alexa_http_sender->start unless $alexa_http_sender->active; + $alexa_http_sender->set($alexa_data); + + } + &_sendHttpData($alexa_listen, $alexa_http_sender); + &close_stuck_sockets($alexa_listen, $AlexaHttpName) if ($alexa_listen); #This closes the oldest connection from a source IP if a second one is made. Fix for GH stuck connections + + # } + + + + my $alexa_ssdp_listen = $AlexaGlobal->{ssdp_listen}; + if ( $alexa_ssdp_listen && ( my $ssdp_data = said $alexa_ssdp_listen) ) { + my $peer = $::Socket_Ports{'alexaSsdpListen'}{from_ipport}; + &_receiveSSDPEvent($ssdp_data, $peer); + } +} + + +sub _sendHttpData { + my ($alexa_listen, $alexa_http_sender) = @_; + if ( $alexa_http_sender && ( my $alexa_sender_data = said $alexa_http_sender ) ) { + my $client_ip_address = $alexa_listen->peer; + &main::print_log( "[Alexa] Debug: Peer: $client_ip_address Data OUT - $alexa_sender_data" ) if $main::Debug{'alexa'} >= 5; + $client_ip_address =~ s/:.*//; + my $client_port = $alexa_listen->peer; + $client_port =~ s/.*\://; + + delete $AlexaGlobal->{http_client}->{$client_ip_address}->{$client_port} if $AlexaGlobal->{http_client}->{$client_ip_address}->{$client_port}; + $alexa_listen->set($alexa_sender_data); + } +} + +sub _receiveSSDPEvent { + my ( $buf, $peer ) = @_; + + + if ($buf !~ /\015?\012\015?\012/) { + return; + } + + $buf =~ s/^(?:\015?\012)+//; # ignore leading blank lines + if (!($buf =~ s/^(\S+)[ \t]+(\S+)(?:[ \t]+(HTTP\/\d+\.\d+))?[^\012]*\012//)) { + # Bad header + return; + } + + my $method = $1; + if ($method ne 'M-SEARCH') { + # We only care about searches + return; + } + + my $target; + $buf =~ s/ST: /ST:/g; + &main::print_log ("[Alexa] Debug: SSDP IN - $buf \n") if $main::Debug{'alexa'} >= 3; + if ( $buf =~ /ST:urn:Belkin:device:\*\*.*/ ) { &_sendSearchResponse($peer) } + elsif ( $buf =~ /ST:urn:schemas-upnp-org:device:basic:1.*/ ) { &_sendSearchResponse($peer) } + elsif ( $buf =~ /ST:ssdp:all.*/ ) { &_sendSearchResponse($peer,'all') } + #elsif ( $buf =~ /ST:ssdp:all.*/ ) { &_sendSearchResponse($peer,'all') } +} + + + +sub _sendSearchResponse { + my ($peer,$type) = @_; + my $count = 0; + my $selfname = (&main::list_objects_by_type('AlexaBridge'))[0]; + my $self = ::get_object_by_name($selfname); + my $alexa_ssdp_send = $AlexaGlobal->{'ssdp_send'}; + my $mac = $LOCAL_MAC; + + + foreach my $port ( (sort keys %{$self->{child}->{'ports'}}) ) { + #next unless ( $self->{child}->{$port} ); + my $socket = handle $alexa_ssdp_send; + my $output; + if ($type eq 'all') { + $output = "HTTP/1.1 200 OK\r\n"; + $output .= 'HOST: 239.255.255.250:1900'."\r\n"; + $output .= 'CACHE-CONTROL: max-age=100'."\r\n"; + $output .= 'EXT: '."\r\n"; + $output .= 'LOCATION: http://'.$LOCAL_IP.':'.$port.'/description.xml' ."\r\n"; + $output .= 'SERVER: Linux/3.14.0 UPnP/1.0 IpBridge/1.15.0' ."\r\n"; + $output .= 'hue-bridgeid: B827EBFFFE'.uc((substr $mac, -6))."\r\n"; + $output .= 'ST: upnp:rootdevice' ."\r\n"; + $output .= 'USN: uuid:'.$mac.'::upnp:rootdevice' ."\r\n"; + $output .= "\r\n"; + &main::print_log ("[Alexa] Debug: SSDP OUT - $output \n") if $main::Debug{'alexa'} >= 3; + send($socket, $output, 0, $peer); + + $output = "HTTP/1.1 200 OK\r\n"; + $output .= 'HOST: 239.255.255.250:1900'."\r\n"; + $output .= 'CACHE-CONTROL: max-age=100'."\r\n"; + $output .= 'EXT: '."\r\n"; + $output .= 'LOCATION: http://'.$LOCAL_IP.':'.$port.'/description.xml' ."\r\n"; + $output .= 'SERVER: Linux/3.14.0 UPnP/1.0 IpBridge/1.15.0' ."\r\n"; + $output .= 'hue-bridgeid: B827EBFFFE'.uc((substr $mac, -6))."\r\n"; + $output .= 'ST: uuid:2f402f80-da50-11e1-9b23-'.lc($mac)."\r\n"; + $output .= 'USN: uuid:2f402f80-da50-11e1-9b23-001e06'.$mac."\r\n"; + $output .= "\r\n"; + &main::print_log ("[Alexa] Debug: SSDP OUT - $output \n") if $main::Debug{'alexa'} >= 3; + send($socket, $output, 0, $peer); + } + + $output = "HTTP/1.1 200 OK\r\n"; + $output .= 'HOST: 239.255.255.250:1900'."\r\n"; + $output .= 'CACHE-CONTROL: max-age=100'."\r\n"; + $output .= 'EXT: '."\r\n"; + $output .= 'LOCATION: http://'.$LOCAL_IP.':'.$port.'/description.xml' ."\r\n"; + $output .= 'SERVER: Linux/3.14.0 UPnP/1.0 IpBridge/1.15.0' ."\r\n"; + $output .= 'hue-bridgeid: B827EBFFFE'.uc((substr $mac, -6))."\r\n"; + $output .= 'ST: urn:schemas-upnp-org:device:basic:1'."\r\n"; + $output .= 'USN: uuid:2f402f80-da50-11e1-9b23-'.lc($mac)."\r\n"; + $output .= "\r\n"; + &main::print_log ("[Alexa] Debug: SSDP OUT - $output \n") if $main::Debug{'alexa'} >= 3; + send($socket, $output, 0, $peer); + + $count++; + } +} + + +sub close_stuck_sockets_old { +my ($alexa_listen, $AlexaHttpName) = @_; + return unless $alexa_listen; + my $current_client_ip = $alexa_listen->peer; + $current_client_ip =~ s/:.*//; + my $current_client_port = $alexa_listen->peer; + $current_client_port =~ s/.*\://; + if ( (scalar @{ $::Socket_Ports{$AlexaHttpName}{clients} }) > 1 ) { + for my $ptr ( @{ $::Socket_Ports{$AlexaHttpName}{clients} } ) { + my ( $socka, $client_ip_address, $client_port, $data ) = @{$ptr}; + next if ( ($client_ip_address eq $current_client_ip) && ($client_port eq $current_client_port)); + if ($client_ip_address eq $current_client_ip) { + $AlexaGlobal->{http_client}->{$client_ip_address}->{$client_port}->{time} = time unless $AlexaGlobal->{http_client}->{$client_ip_address}->{$client_port}->{time}; + if ( (time - $AlexaGlobal->{http_client}->{$client_ip_address}->{$client_port}->{time}) ge 60 ) { + close $socka if $socka; + delete $AlexaGlobal->{http_client}->{$client_ip_address}; + &main::print_log( "[Alexa] Debug: Client count: ".(scalar @{ $::Socket_Ports{$AlexaHttpName}{clients} }) ." closing $client_ip_address : $client_port") if $main::Debug{'alexa'} >= 2; + } + } + } + + } +} + + +sub close_stuck_sockets { +my ($alexa_listen, $AlexaHttpName) = @_; + return unless $alexa_listen; + my $current_client_ip = $alexa_listen->peer; + $current_client_ip =~ s/:.*//; + my $current_client_port = $alexa_listen->peer; + $current_client_port =~ s/.*\://; + for my $ptr ( @{ $::Socket_Ports{$AlexaHttpName}{clients} } ) { + my ( $socka, $client_ip_address, $client_port, $data ) = @{$ptr}; + next if ( ($client_ip_address eq $current_client_ip) && ($client_port eq $current_client_port)); + next unless $AlexaGlobal->{http_client}->{$client_ip_address}->{$client_port}->{time}; + my $timediff = (time - $AlexaGlobal->{http_client}->{$client_ip_address}->{$client_port}->{time}); + if ( $timediff >= 20 ) { + $output = "HTTP/1.1 404 Not Found\r\nServer: MisterHouse\r\nCache-Control: no-cache\r\nContent-Length: 2\r\nDate: ". time2str(time)."\r\n\r\n.."; + print $socka $output; + delete $AlexaGlobal->{http_client}->{$client_ip_address}->{$client_port}; + &main::print_log( "[Alexa] Debug: Sending 404 to $client_ip_address:$client_port socket has been open for $timediff with no response") if $main::Debug{'alexa'} >= 2; + } + } + +} + + +sub process_http { + + unless ($::config_parms{'alexa_enable'}) { return 0 } + my ( $uri, $request_type, $body, $socket, %Http ) = @_; + + unless ( ($uri =~ /^\/api/ ) || ($uri =~ /^\/description.xml$/) ) { return 0 } # Added for performance + + my $selfname = (&main::list_objects_by_type('AlexaBridge'))[0]; + my $self = ::get_object_by_name($selfname); + unless ($self) { &main::print_log( "[Alexa] Error: No AlexaBridge parent object found" ); return 0 } + + + use HTTP::Date qw(time2str); + use IO::Compress::Gzip qw(gzip); + + #get the port from the host header + my @uris = split(/\//, $uri); + my $host = $Http{'Host'}; + my $port; + if ( $host =~ /(.*):(\d+)/ ) { + $host = $1; + $port = $2; + } + elsif ( $host =~ /(\d+)/ ) { + $host = $1; + $port = '80'; + } + elsif ( $host =~ /(\w+)/ ) { + $host = $1; + $port = '80'; + } + +my $xmlmessage = qq[ + + +1 +0 + +http://$LOCAL_IP:$port/ + +urn:schemas-upnp-org:device:basic:1 +Amazon-Echo-MH-Bridge ($LOCAL_IP) +Royal Philips Electronics +http://misterhouse.sourceforge.net/ +Hue Emulator for Amazon Echo bridge +Philips hue bridge 2012 +929000226503 +https://github.com/hollie/misterhouse +amazon-mh-bridge0 +uuid:amazon-mh-bridge0 + + +(null) +(null) +(null) +(null) +(null) + + +index.html + + +image/png +48 +48 +24 +hue_logo_0.png + + +image/png +120 +120 +24 +hue_logo_3.png + + + +]; + + +my ($AlexaObjects,$AlexaObjChunk); + if ( $::config_parms{'alexaEnableChunked'} ) { + $AlexaObjects = $self->{child}->{fulllist}; + } + elsif ( $self->{child}->{$port} ) { + # use Data::Dumper; + $AlexaObjects = $self->{child}->{$port}; + $AlexaObjChunk = $self->{child}->{$port}; + #&main::print_log( Data::Dumper->Dumper($AlexaObjects) ); + } + else { + &main::print_log( "[Alexa] Error: No Matching object for port ( $port )" ); + $output = "HTTP/1.1 404 Not Found\r\nServer: MisterHouse\r\nCache-Control: no-cache\r\nContent-Length: 2\r\nDate: ". time2str(time)."\r\n\r\n.."; + return $output; + } + +&main::print_log ("[Alexa] Debug: Port: ( $port ) URI: ( $uri ) Body: ( $body ) Type: ( $request_type ) \n") if $main::Debug{'alexa'}; + + if ( ($uri =~ /^\/description.xml$/) && (lc($request_type) eq "get") ) { + my $output = "HTTP/1.1 200 OK\r\n"; + $output .= "Server: MisterHouse\r\n"; + $output .= 'Access-Control-Allow-Origin: *'."\r\n"; + $output .= 'Access-Control-Allow-Methods: POST, GET, OPTIONS, DELETE, PUT'."\r\n"; + $output .= 'Access-Control-Max-Age: 3600'."\r\n"; + $output .= 'Access-Control-Allow-Headers: Origin, X-Requested-With, Content-Type, Accept'."\r\n"; + $output .= 'X-Application-Context: application'."\r\n"; + $output .= 'Content-Type: application/xml;charset=UTF-8'."\r\n"; + $output .= "Content-Length: ". (length $xmlmessage) ."\r\n"; + $output .= "Date: ". time2str(time)."\r\n"; + $output .= "\r\n"; + $output .= $xmlmessage; + &main::print_log ("[Alexa] Debug: MH Response $xmlmessage \n") if $main::Debug{'alexa'} >= 2; + return $output; + } + elsif ( ($uri =~ /^\/api/) && (lc($request_type) eq "post") ) { + my $content = qq[\[{"success":{"username":"lights"}}\]]; + my $output = "HTTP/1.1 200 OK\r\n"; + $output .= "Server: MisterHouse\r\n"; + $output .= 'Access-Control-Allow-Origin: *'."\r\n"; + $output .= 'Access-Control-Allow-Methods: POST, GET, OPTIONS, DELETE, PUT'."\r\n"; + $output .= 'Access-Control-Max-Age: 3600'."\r\n"; + $output .= 'Access-Control-Allow-Headers: Origin, X-Requested-With, Content-Type, Accept'."\r\n"; + $output .= 'X-Application-Context: application'."\r\n"; + $output .= 'Content-Type: application/json;charset=UTF-8'."\r\n"; + $output .= "Content-Length: ". (length $content) ."\r\n"; + $output .= "Date: ". time2str(time)."\r\n"; + $output .= "\r\n"; + $output .= $content; + &main::print_log ("[Alexa] Debug: MH Response $output \n") if $main::Debug{'alexa'} >= 2; + return $output; + } + elsif ( ($uri =~ /^\/api\/.*\/lights\/(.*)\/state$/) && (lc($request_type) eq "put") ) { + my $output; + my $deviceID = $1; + my $state = undef; + $body =~ s/: /:/g; + if ( $body =~ /\"(on)\":(true)/ ) { $state = 'on' } + elsif ( $body =~ /\"(on)\":(false)/ ) { $state = 'off' } + elsif ( $body =~ /\"(off)\":(true)/ ) { $state = 'off' } + elsif ( $body =~ /\"(off)\":(false)/ ) { $state = 'on' } + if ( $body =~ /\"(bri)\":(\d+)/ ) { $state = $2 } + my $content = qq[\[{"success":{"/lights/$deviceID/state/$1":$2}}\]]; + &main::print_log ("[Alexa] Debug: MH Got request ( $1 - $2 ) to Set device ( $deviceID ) to ( $state )\n") if $main::Debug{'alexa'}; + + if ( ($AlexaObjects->{'uuid'}->{$deviceID}) && (defined($state)) ) { + &get_set_state($self, $AlexaObjects, $deviceID, 'set', $state); + + $output = "HTTP/1.1 200 OK\r\n"; + $output .= "Server: MisterHouse\r\n"; + $output .= 'Access-Control-Allow-Origin: *'."\r\n"; + $output .= 'Access-Control-Allow-Methods: POST, GET, OPTIONS, DELETE, PUT'."\r\n"; + $output .= 'Access-Control-Max-Age: 3600'."\r\n"; + $output .= 'Access-Control-Allow-Headers: Origin, X-Requested-With, Content-Type, Accept'."\r\n"; + $output .= 'X-Application-Context: application'."\r\n"; + $output .= 'Content-Type: text/plain;charset=UTF-8'."\r\n"; + $output .= "Content-Length: ". (length $content) ."\r\n"; + $output .= "Date: ". time2str(time)."\r\n"; + $output .= "\r\n"; + $output .= $content; + } else { + $output = "HTTP/1.1 404 Not Found\r\nServer: MisterHouse\r\nCache-Control: no-cache\r\nContent-Length: 2\r\nDate: ". time2str(time)."\r\n\r\n.."; + &main::print_log("[Alexa] Error: No Matching object for UUID ( $deviceID )") unless ($AlexaObjects->{'uuid'}->{$deviceID}); + &main::print_log("[Alexa] Error: Missing State from PUT for object with UUID ( $deviceID )") unless (defined($state)); + &main::print_log ("[Alexa] Debug: MH Response $output \n") if $main::Debug{'alexa'}; + return $output; + } + &main::print_log ("[Alexa] Debug: MH Response $output \n") if $main::Debug{'alexa'} >= 2; + return $output; + #print $socket $output; # print direct to the socket so it does not close. + #&main::http_process_request($socket); # we know there will be another request so get it in the same tcp session. + #return ' '; + } + elsif ( ($uri =~ /^\/api\/.*/) && (lc($request_type) eq "get") ) { + my $count = 0; + my $content; my $name; my $statep1; my $statep2; my $statep3; my $statep4; my $delm; my $output; + my $end = ''; + if (defined $uris[4]) { + if ( ($uris[3] eq 'lights') && ($AlexaObjects->{'uuid'}->{$uris[4]}) ) { + $uuid = $uris[4]; + $name = $AlexaObjects->{'uuid'}->{$uuid}->{'name'}; + my $state = &get_set_state($self, $AlexaObjects, $uuid,'get'); + $statep1 = qq[{"state":{$state,"hue":15823,"sat":88,"effect":"none","ct":313,"alert":"none","colormode":"ct","reachable":true,"xy":\[0.4255,0.3998\]},"type":"Extended color light","name":"]; + $statep2 = qq[","modelid":"LCT001","manufacturername":"Philips","uniqueid":"$uuid","swversion":"65003148","pointsymbol":{"1":"none","2":"none","3":"none","4":"none","5":"none","6":"none","7":"none","8":"none"}}]; + $content = $statep1.$name.$statep2; + $count = 1; + } + elsif ( $uris[3] eq 'lights' ) { + &main::print_log("[Alexa] Error: No Matching object for UUID ( $uris[4] )"); + $output = "HTTP/1.1 404 Not Found\r\nServer: MisterHouse\r\nCache-Control: no-cache\r\nContent-Length: 2\r\nDate: ". time2str(time)."\r\n\r\n.."; + &main::print_log ("[Alexa] Debug: MH Response $output \n") if $main::Debug{'alexa'}; + return $output; + } + elsif ( ($uris[3] eq 'groups') && ($AlexaObjects->{'groups'}->{$uris[4]}) ) { + $name = $AlexaObjects->{'groups'}->{$uris[4]}->{'name'}; + $content = qq[{"action": {"on": true,"hue": 0,"effect": "none","bri": 100,"sat": 100,"ct": 500,"xy": \[0.5, 0.5\]},"lights": \["1","2"\],"state":{"any_on":true,"all_on":true}"type":"Room","class":"Other","name":"$name"}]; + $count = 1; + } + } + elsif (defined $uris[3]) { + if ( $uris[3] eq 'lights' ) { + $AlexaObjChunk = $self->_GetChunk($uris[3]) if ( $::config_parms{'alexaEnableChunked'} ); + foreach my $uuid ( keys %{$AlexaObjChunk->{'uuid'}} ) { + $name = $AlexaObjChunk->{'uuid'}->{$uuid}->{'name'}; + next unless $name; + my $state = &get_set_state($self, $AlexaObjects, $uuid,'get'); + $statep1 = qq[{"]; + $statep2 = qq[":{"state":{$state,"reachable":true},"type":"Extended color light","name":"]; + $statep3 = qq[","modelid":"LCT001","manufacturername":"Philips","swversion":"65003148"}]; + $end = qq[}]; + $delm = qq[,"]; + if ($count >= 1) { $content = $content.$delm.$uuid.$statep2.$name.$statep3 } + else { $content = $statep1.$uuid.$statep2.$name.$statep3 } + $count++; + } + } + elsif ( $uris[3] eq 'groups' ) { + $statep1 = qq[{"]; + $statep2 = qq[":"]; + $end = qq["}]; + $delm = qq[","]; + $AlexaObjChunk = $self->_GetChunk($uris[3]) if ( $::config_parms{'alexaEnableChunked'} ); + foreach my $id ( keys %{$AlexaObjChunk->{'groups'}} ) { + $name = $AlexaObjChunk->{'groups'}->{$id}->{'name'}; + next unless $name; + $statep1 = qq[{"$id": {"name": "$name","lights": \["1","2"\],"type": "LightGroup","action": {"on": true,"bri": 254,"hue": 10000,"sat": 254,"effect": "none","xy": \[0.5,0.5\],"ct": 250,"alert": "select","colormode": "ct"}}]; + $delim = qq[,]; + $statep2 = qq["$id": {"name": "$name","lights": \["3","4"\],"type": "LightGroup","action": {"on": true,"bri": 153,"hue": 4345,"sat": 254,"effect": "none","xy": \[0.5,0.5\],"ct": 250,"alert": "select","colormode": "ct"}}]; + $end = qq[}]; + if ($count >= 1) { $content = $content.$delim.$statep2 } + else { $content = $statep1 } + $count++; + } + } + } + elsif (defined $uris[2]) { + $AlexaObjChunk = $self->_GetChunk('all') if ( $::config_parms{'alexaEnableChunked'} ); + foreach my $uuid ( keys %{$AlexaObjChunk->{'uuid'}} ) { + $name = $AlexaObjChunk->{'uuid'}->{$uuid}->{'name'}; + next unless $name; + my $state = &get_set_state($self, $AlexaObjects, $uuid,'get'); + $statep1 = qq[{"lights":{"]; + $statep2 = qq[":{"state":{$state,"reachable":true},"type":"Extended color light","name":"]; # dis + $statep3 = qq[","modelid":"LCT001","manufacturername":"Philips","swversion":"65003148"}]; # + $end = qq[}}]; + $delm = qq[,"]; + if ($count >= 1) { $content = $content.$delm.$uuid.$statep2.$name.$statep3 } + else { $content = $statep1.$uuid.$statep2.$name.$statep3 } + $count++; + } + } + if ($count >= 1) { + $content = $content.$end; + $debugcontent = $content if $main::Debug{'alexa'} >= 2; + $content = &_Gzip($content,$Http{'Accept-Encoding'}); + $output = "HTTP/1.1 200 OK\r\n"; + $output .= "Server: MisterHouse\r\n"; + $output .= 'Access-Control-Allow-Origin: *'."\r\n"; + $output .= 'Access-Control-Allow-Methods: POST, GET, OPTIONS, DELETE, PUT'."\r\n"; + $output .= 'Access-Control-Max-Age: 3600'."\r\n"; + $output .= 'Access-Control-Allow-Headers: Origin, X-Requested-With, Content-Type, Accept'."\r\n"; + $output .= 'X-Application-Context: application'."\r\n"; + $output .= 'Content-Type: application/json;charset=UTF-8'."\r\n"; + $output .= "Content-Encoding: gzip\r\n" if ($Http{'Accept-Encoding'} =~ m/gzip/); + $output .= "Content-Length: ". (length $content) ."\r\n"; + $output .= "Date: ". time2str(time)."\r\n"; + $output .= "\r\n"; + $debugcontent = $output.$debugcontent if $main::Debug{'alexa'} >= 2; + $output .= $content; + } else { + $output = "HTTP/1.1 404 Not Found\r\nServer: MisterHouse\r\nCache-Control: no-cache\r\nContent-Length: 2\r\nDate: ". time2str(time)."\r\n\r\n.."; + } + &main::print_log ("[Alexa] Debug: MH Response $debugcontent \n") if $main::Debug{'alexa'} >= 2; + return $output; + } + else { return 0 } +} + +sub _Gzip { + my ($content_raw, $Encoding) = @_; + my $content; + if ( $Encoding =~ m/gzip/ && ((length $content_raw) >= 1) ) { + gzip \$content_raw => \$content; + } + else { $content = $content_raw; } + return $content; +} + + +sub _GetChunk { + my ( $self,$uri ) = @_; + #use Time::HiRes qw(clock_gettime); + use Time::HiRes qw(time); + #my $realtime = clock_gettime(CLOCK_REALTIME); + my $realtime = time; + #$self->{'conn'}->{$uri}->{time} = clock_gettime(CLOCK_REALTIME) unless $self->{'conn'}->{$uri}->{time}; + $self->{'conn'}->{$uri}->{time} = time unless $self->{'conn'}->{$uri}->{time}; + $self->{'conn'}->{$uri}->{count} = 0 unless defined($self->{'conn'}->{$uri}->{count}); + + if ( ($realtime - $self->{'conn'}->{$uri}->{time}) <= .7 ) { + my $size = $self->{child}->{ChkCnt}; + if ( $self->{'conn'}->{$uri}->{count} eq $size ) { $ChkCnt = $size; $self->{'conn'}->{$uri}->{count} = 0 } + elsif ( defined($self->{'conn'}->{$uri}->{count}) ) { $ChkCnt = $self->{'conn'}->{$uri}->{count}; $self->{'conn'}->{$uri}->{count}++ } + &main::print_log ("[Alexa] Debug: GetChunk - Time ( $realtime ) ChunkSize: ( $size ) Count: ( $ChkCnt ) CountHash: ( $self->{'conn'}->{$uri}->{count} )\n") if $main::Debug{'alexa'}; + } + else { undef $self->{'conn'}->{$uri}->{time}; undef $self->{'conn'}->{$uri}->{count} } + my $AlexaObjChunk = $self->{child}->{$ChkCnt}; + return $AlexaObjChunk; +} + + +sub DiscoverAddy { + use Net::Address::Ethernet qw( :all ); + my @a = get_addresses(@_); + foreach my $adapter (@a) { + next unless ($adapter->{iActive} eq 1); + next if ($adapter->{sEthernet} eq ''); + next if ($adapter->{sIP} =~ /127\.0\.0\.1/); + my $Mac = $adapter->{sEthernet}; + $Mac =~ s/://g; + return ($adapter->{sIP},$Mac); + } +} + +sub get_set_state { + my ( $self, $AlexaObjects, $uuid, $action, $state ) = @_; + my $name = $AlexaObjects->{'uuid'}->{$uuid}->{'name'}; + my $realname = $AlexaObjects->{'uuid'}->{$uuid}->{'realname'}; + my $sub = $AlexaObjects->{'uuid'}->{$uuid}->{'sub'}; + my $statesub = $AlexaObjects->{'uuid'}->{$uuid}->{'statesub'}; + $state = $AlexaObjects->{'uuid'}->{$uuid}->{lc($state)} if $AlexaObjects->{'uuid'}->{$uuid}->{lc($state)}; + if ( $state =~ /\d+/ ) { $state = &roundoff($state / 2.54) } + &main::print_log ("[Alexa] Debug: get_set_state ($uuid $action $state) : name: $name realname: $realname sub: $sub state: $state\n") if $main::Debug{'alexa'}; + if ( $realname =~ /^\$/ ) { + my $object = ::get_object_by_name( $realname ); + return qq["on":true,"bri":254] unless defined $object; + if ( $action eq 'get' ) { + my $cstate = $object->$statesub; + $cstate =~ s/\%//; + my $level = '254'; + my $type = $object->get_type(); + my $debug = "[Alexa] Debug: get_state (actual object state: $cstate) - (object type: $type) - "; + my $return; + if ( $object->can('state_level') ) { + my $l = $object->level; + $l =~ s/\%//; + if ( $l =~ /\d+/ ) { + $level = ( &roundoff(($l) * 2.54) ); + $debug .= "(level: $level) - "; + } + } + if ( lc($type) =~ /x10/ ) { + if ( ($cstate =~ /\d+/) || ($cstate =~ /dim/) || ($cstate =~ /bright/) ) { $cstate = 'on' } + $debug .= "(determined state: $cstate) - "; + } + if ( lc($AlexaObjects->{'uuid'}->{$uuid}->{'on'}) eq lc($cstate) ) { $return = qq["on":true,"bri":$level] } + elsif ( lc($AlexaObjects->{'uuid'}->{$uuid}->{'off'}) eq lc($cstate) ) { $return = qq["on":false,"bri":$level] } + elsif ( $cstate =~ /\d+/ ) { $return = qq["on":true,"bri":].&roundoff($cstate * 2.54) } + else { $return = qq["on":true,"bri":$level] } + &main::print_log ( "$debug returning - $return\n" ) if $main::Debug{'alexa'}; + return $return; + } + elsif ( $action eq 'set' ) { + if ( $object->can('state_level') && $state =~ /\d+/ ) { $state = $state.'%'} + &main::print_log ("[Alexa] Debug: setting object ( $realname ) to state ( $state )\n") if $main::Debug{'alexa'}; + if ( lc($type) =~ /clipsal_cbus/ ) { $object->$sub($state,'Alexa') } + else { $object->$sub($state,'Alexa') } + return; + } + } + elsif ( $sub =~ /^run_voice_cmd$/ ) { + if ( $action eq 'set' ) { + $realname =~ s/#/$state/; + $realname =~ s/!/$state/; + &main::print_log ("[Alexa] Debug: running voice command: ( $realname )\n") if $main::Debug{'alexa'}; + &main::run_voice_cmd("$realname"); + return; + } + elsif ( $action eq 'get' ) { + return qq["on":true,"bri":254]; + } + + } + elsif ( ref($sub) eq 'CODE' ) { + if ( $action eq 'set' ) { + &main::print_log ("[Alexa] Debug: running sub: $sub( set, $state ) \n") if $main::Debug{'alexa'}; + &{$sub}('set',$state); + return; + } + elsif ( $action eq 'get' ) { + my $debug = "[Alexa] Debug: get_state running sub: $sub( state, $state ) - "; + my $state = &{$sub}('state'); + if ( $state =~ /\d+/ ) { + $state = ( &roundoff( ($state * 2.54) ) ); + my $return = qq["on":true,"bri":$state]; + &main::print_log ("$debug returning - $return\n" ) if $main::Debug{'alexa'}; + return $return; + } + return qq["on":true,"bri":254]; + } + } + +} + +sub get_state { +my ( $self, $object, $statesub ) = @_; + my $cstate = $object->$statesub; + $cstate =~ s/\%//; + my $type = $object->get_type(); + my $debug = "[Alexa] Debug: get_state (actual object state: $cstate) - (object type: $type) - "; + if ( lc($type) =~ /x10/ ) { + if ( ($state =~ /\d+/) || ($state =~ /dim/) || ($state =~ /bright/) ) { $cstate = 'on' } + } + $debug .= "(determined state: $cstate) - "; + return $cstate; +} + + +sub roundoff +{ + my $num = shift; + my $roundto = shift || 1; + + return int($num/$roundto+0.5)*$roundto; +} + +sub new { + my ($class) = @_; + my $self = new Generic_Item(); + bless $self, $class; + return $self; +} + +sub register { + my ( $self, $child ) = @_; + $self->{child} = $child; +} + +=back + +=head1 B + +=head2 DESCRIPTION + +The AlexaBridge_Item object holds the configured Misterhouse objects that are presented to the Amazon Echo or Google Home + +=head2 mh.private.ini Configuration + +See L + +=head2 Defining the Child object + +The object can be defined in the user code or in a .mht file. + +In mht: + +ALEXABRIDGE_ITEM, , + +ie: + + ALEXABRIDGE_ITEM, AlexaItems, Alexa + + +Or in user code: + + = new AlexaBridge_Item(); + +ie: + + $AlexaItems = new AlexaBridge_Item($Alexa); + + +=head2 NOTES + +See L for complete examples + +=head2 INHERITS + +L + +=head2 METHODS + +=over + +=cut + + +package AlexaBridge_Item; + +@AlexaBridge_Item::ISA = ('Generic_Item'); +use Storable; + +sub new { + my ($class, $parent) = @_; + my $self = new Generic_Item(); + my $file = $::config_parms{'data_dir'}.'/alexa_temp.saved_id'; + bless $self, $class; + $parent->register($self); + foreach my $AlexaHttpName ( keys %{$AlexaGlobal->{http_sockets}} ) { + my $AlexaHttpPort = $AlexaGlobal->{http_sockets}->{$AlexaHttpName}->{port}; + $self->{'ports'}->{$AlexaHttpPort} = 0; + &main::print_log ("[Alexa] Debug: Configured for port $AlexaHttpPort\n") if $main::Debug{'alexa'}; + } + if ( ($::config_parms{'alexaHttpPortCount'} eq 0) && ($::config_parms{'alexaHttpPort'}) ) { + $self->{'ports'}->{$::config_parms{'alexaHttpPort'}} = 0; # This is to disable all MH proxy ports and use an external proxy port via Apache + &main::print_log ("[Alexa] Debug: Configured for a EXTERNAL proxy on port $::config_parms{'alexaHttpPort'}\n") if $main::Debug{'alexa'}; + } + elsif ( ($::config_parms{'alexaNoDefaultHttp'}) && ($::config_parms{'alexaHttpPort'}) ) { + #this is to disable the default MH web port and only use a proxy port + &main::print_log ("[Alexa] Debug: Configured to disable port $::config_parms{'http_port'} and proxy port $::config_parms{'alexaHttpPort'}\n") if $main::Debug{'alexa'}; + } + else { + $self->{'ports'}->{$::config_parms{'http_port'}} = 0; + &main::print_log ("[Alexa] Debug: Configured for port $::config_parms{'http_port'}\n") if $main::Debug{'alexa'}; + } + if (-e $file) { + my $restoredhash = retrieve($file); + $self->{idmap} = $restoredhash->{idmap}; + } else { $self->{idmap} } + return $self; +} + +=item C + +Presents misterhouse objects, subs, or voice coommands to the Echo, Google Home, or any thing that supports +the HUE bridge. + +add('','', +'','', +'',''); + +=cut + +sub add { + my ($self, $realname, $name, $sub, $on, $off, $statesub) = @_; + + return unless defined $realname; + my $fullname; + my $cleanname = $realname; + $cleanname =~ s/\$//g; + $cleanname =~ s/ //g; + $cleanname =~ s/#//g; + $cleanname =~ s/\\//g; + $cleanname =~ s/&//g; + + if ( defined($name) ) { + $fullname = $cleanname.'.'.$name; + } + else { + $fullname = $cleanname.'.'.$cleanname; + } + #use Data::Dumper; + my $uuid = $self->uuid($fullname); + my $alexaObjectsPerGet = $::config_parms{'alexaObjectsPerGet'} || '60'; + + if ( $::config_parms{'alexaEnableChunked'} ) { + $self->{fulllist}->{'uuid'}->{$uuid}->{'realname'}=$realname; + $self->{fulllist}->{'uuid'}->{$uuid}->{'name'}=$name || $cleanname; + $self->{fulllist}->{'uuid'}->{$uuid}->{'sub'}=$sub || 'set'; + $self->{fulllist}->{'uuid'}->{$uuid}->{'on'}=lc($on) || 'on'; + $self->{fulllist}->{'uuid'}->{$uuid}->{'off'}=lc($off) || 'off'; + $self->{fulllist}->{'uuid'}->{$uuid}->{'statesub'}=$statesub || 'state'; + for my $count (0..5) { + my $size = keys %{$self->{$count}->{'uuid'}}; + next if ($size eq $alexaObjectsPerGet); + $self->{$count}->{'uuid'}->{$uuid}->{'realname'}=$realname; + $self->{$count}->{'uuid'}->{$uuid}->{'name'}=$name || $cleanname; + $self->{$count}->{'uuid'}->{$uuid}->{'sub'}=$sub || 'set'; + $self->{$count}->{'uuid'}->{$uuid}->{'on'}=lc($on) || 'on'; + $self->{$count}->{'uuid'}->{$uuid}->{'off'}=lc($off) || 'off'; + $self->{$count}->{'uuid'}->{$uuid}->{'statesub'}=$statesub || 'state'; + $self->{ChkCnt} = $count; + &main::print_log ("[Alexa] Debug: UUID:( $uuid ) Count: ( $count ) \n") if $main::Debug{'alexa'}; + last; + } + } + else { + foreach my $port ( (sort keys %{$self->{'ports'}}) ) { + my $size = keys %{$self->{$port}->{'uuid'}}; + next if ($size eq $alexaObjectsPerGet); + $self->{$port}->{'uuid'}->{$uuid}->{'realname'}=$realname; + $self->{$port}->{'uuid'}->{$uuid}->{'name'}=$name || $cleanname; + $self->{$port}->{'uuid'}->{$uuid}->{'sub'}=$sub || 'set'; + $self->{$port}->{'uuid'}->{$uuid}->{'on'}=lc($on) || 'on'; + $self->{$port}->{'uuid'}->{$uuid}->{'off'}=lc($off) || 'off'; + $self->{$port}->{'uuid'}->{$uuid}->{'statesub'}=$statesub || 'state'; + last; + } +} + # $self->{8080}->{'uuid'}->{3}->{'realname'}=$realname; + # $self->{8080}->{'uuid'}->{3}->{'name'}=$name || $cleanname; + # $self->{8080}->{'uuid'}->{3}->{'sub'}=$sub || 'set'; + # $self->{8080}->{'uuid'}->{3}->{'on'}=$on || 'on'; + # $self->{8080}->{'uuid'}->{3}->{'off'}=$off || 'off'; + # $self->{8080}->{'uuid'}->{3}->{'statesub'}=$statesub || 'state'; + +# Testing groups, saw the Echo hit /api/odtQdwTaiTjPgURo4ZyEtGfIqRgfSeCm1fl2AMG2/groups/0 +#$self->{'groups'}->{0}->{'name'}='group0'; +#$self->{'groups'}->{0}->{'realname'}='$light0'; +#$self->{'groups'}->{0}->{'sub'}='set'; +#$self->{'groups'}->{0}->{'on'}='on'; +#$self->{'groups'}->{0}->{'off'}='off'; +#$self->{'groups'}->{1}->{'name'}='group1'; +#$self->{'groups'}->{1}->{'realname'}='$light1'; +#$self->{'groups'}->{1}->{'sub'}='set'; +#$self->{'groups'}->{1}->{'on'}='on'; +#$self->{'groups'}->{1}->{'off'}='off'; +#$self->{'groups'}->{2}->{'name'}='group2'; +#$self->{'groups'}->{2}->{'realname'}='$light2'; +#$self->{'groups'}->{2}->{'sub'}='set'; +#$self->{'groups'}->{2}->{'on'}='on'; +#$self->{'groups'}->{2}->{'off'}='off'; + #&main::print_log( Data::Dumper->Dumper($self->{'uuid'}) ); +} + +sub get_objects { + my ($self) = @_; + return $self->{'uuid'}; +} + +sub uuid { + my ($self, $name) = @_; + my $file = $::config_parms{'data_dir'}.'/alexa_temp.saved_id'; + return $self->{'idmap'}->{objects}->{$name} if ($self->{'idmap'}->{objects}->{$name}); + + my $highid; + my $missing; + my $count = $::config_parms{'alexaUuidStart'} || 1; + foreach my $object (keys %{$self->{idmap}->{objects}}) { + my $currentid = $self->{idmap}->{objects}->{$object}; + $highid = $currentid if ( $currentid > $highid ); + $missing = $count unless ( $self->{'idmap'}->{ids}->{$count} ); #We have a number that has no value + $count++; + } + $highid++; + +$highid = $missing if ( defined($missing) ); # Reuse numbers for deleted objects to keep the count from growning for ever. + +$self->{'idmap'}->{objects}->{$name} = $highid; +$self->{'idmap'}->{ids}->{$highid} = $name; + +my $idmap->{'idmap'} = $self->{'idmap'}; +store $idmap, $file; +return $highid; + +# use Data::UUID; +# $ug = Data::UUID->new; +# $uuid = $ug->to_string( ( $ug->create_from_name(NameSpace_DNS, $name) ) ); +# $uuid =~ s/\D//g; +# $uuid =~ s/-//g; +# $uuid = (substr $uuid, 0, 9); +# return lc($uuid); +} + +sub isDeleted { + my ($self, $uuid) = @_; + my $count; + foreach my $port ( (sort keys %{$self->{'ports'}}) ) { + $count++ if ( $self->{$port}->{'uuid'}->{$uuid} ); + } + return 1 unless $count; + return 0; +} + +1; + +=back + +=head2 NOTES + +=head2 AUTHOR + +Wayne Gatlin + +=head2 SEE ALSO + +=head2 LICENSE + +This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. + +This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. + +You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. + +=cut + + diff --git a/lib/http_server.pl b/lib/http_server.pl index ce03d8df2..8bf29069a 100644 --- a/lib/http_server.pl +++ b/lib/http_server.pl @@ -7,7 +7,9 @@ use strict; use Text::ParseWords; +use AlexaBridge; require 'http_utils.pl'; +#require 'alexa_server.pl'; #use Data::Dumper; #$main::Debug{http} = 4; @@ -550,6 +552,10 @@ sub http_process_request { return; } + if ( my $alexa_response = &AlexaBridge::process_http($get_req, $req_typ, $HTTP_BODY, $socket, %Http) ) { + print $socket $alexa_response unless $alexa_response eq ' '; + return; + } # See if the request was for a file if ( &test_for_file( $socket, $get_req, $get_arg ) ) { } diff --git a/lib/read_table_A.pl b/lib/read_table_A.pl index a3e04e19a..5718ce038 100644 --- a/lib/read_table_A.pl +++ b/lib/read_table_A.pl @@ -1616,6 +1616,34 @@ sub read_table_A { } #-------------- End AD2 Objects ------------- + #-------------- Alexa Objects ----------------- + elsif ( $type eq "ALEX_BRIDGE" ) { + require 'AlexaBridge.pm'; + ( $name ) = @item_info; + $object = "AlexaBridge('$other')"; + } + elsif ( $type eq "ALEXABRIDGE_ITEM" ) { + require 'AlexaBridge.pm'; + my ( $parent ); + ( $name, $parent ) = @item_info; + $object = "AlexaBridge_Item(\$$parent)"; + } + elsif ( $type eq "ALEXABRIDGE_ADD" ) { + my ( $parent, $realname, $name, $sub, $on, $off, $statesub, @other ) = @item_info; + if ($sub =~ /^&/) { $sub =~ s/&/\\&/ } + if ($sub =~ /^\\\\&/) { $sub =~ s/\\// } + if ($sub =~ /run_voice_cmd/) { $realname =~ s/_/ /g } + unless ( ($sub =~ /run_voice_cmd/) || ($sub =~ /&/) ) { $realname = "\$$realname" } + unless ( $sub =~ /&/ ) { $sub = "'".$sub."'" } + my $other = join ', ', ( map { "'$_'" } @other ); # Quote data + if ( !$packages{AlexaBridge}++ ) { # first time for this object type? + $code .= "use AlexaBridge;\n"; + } + $code .= sprintf "\$%-35s -> add('$realname','$name',$sub,'$on','$off','$statesub',$other);\n", $parent; + $object = ''; + } + #-------------- End Alexa Objects ---------------- + elsif ( $type =~ /PLCBUS_.*/ ) { require PLCBUS; ( $address, $name, $grouplist, @other ) = @item_info; diff --git a/lib/site/IO/Interface.pm b/lib/site/IO/Interface.pm new file mode 100644 index 000000000..419aa004b --- /dev/null +++ b/lib/site/IO/Interface.pm @@ -0,0 +1,303 @@ +package IO::Interface; + +require 5.005; +use strict; +use Carp; +use vars qw(@EXPORT @EXPORT_OK @ISA %EXPORT_TAGS $VERSION $AUTOLOAD); + +use IO::Socket; + +require Exporter; +require DynaLoader; + +my @functions = qw(if_addr if_broadcast if_netmask if_dstaddr if_hwaddr if_flags if_list if_mtu if_metric + addr_to_interface if_index if_indextoname ); +my @flags = qw(IFF_ALLMULTI IFF_AUTOMEDIA IFF_BROADCAST + IFF_DEBUG IFF_LOOPBACK IFF_MASTER + IFF_MULTICAST IFF_NOARP IFF_NOTRAILERS + IFF_POINTOPOINT IFF_PORTSEL IFF_PROMISC + IFF_RUNNING IFF_SLAVE IFF_UP); +%EXPORT_TAGS = ( 'all' => [@functions,@flags], + 'functions' => \@functions, + 'flags' => \@flags, + ); + +@EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } ); + +@EXPORT = qw( ); + +@ISA = qw(Exporter DynaLoader); +$VERSION = '1.09'; + +sub AUTOLOAD { + # This AUTOLOAD is used to 'autoload' constants from the constant() + # XS function. If a constant is not found then control is passed + # to the AUTOLOAD in AutoLoader. + + my $constname; + ($constname = $AUTOLOAD) =~ s/.*:://; + croak "&constant not defined" if $constname eq 'constant'; + my $val = constant($constname, @_ ? $_[0] : 0); + if ($! != 0) { + if ($! =~ /Invalid/ || $!{EINVAL}) { + $AutoLoader::AUTOLOAD = $AUTOLOAD; + goto &AutoLoader::AUTOLOAD; + } + else { + croak "Your vendor has not defined IO::Interface macro $constname"; + } + } + { + no strict 'refs'; + *$AUTOLOAD = sub { $val }; # *$AUTOLOAD = sub() { $val }; + } + goto &$AUTOLOAD; +} + +bootstrap IO::Interface $VERSION; + +# copy routines into IO::Socket +{ + no strict 'refs'; + *{"IO\:\:Socket\:\:$_"} = \&$_ foreach @functions; +} + +# Preloaded methods go here. + +sub if_list { + my %hash = map {$_=>undef} &_if_list; + sort keys %hash; +} + +sub addr_to_interface { + my ($sock,$addr) = @_; + return "any" if $addr eq '0.0.0.0'; + my @interfaces = $sock->if_list; + foreach (@interfaces) { + my $if_addr = $sock->if_addr($_) or next; + return $_ if $if_addr eq $addr; + } + return; # couldn't find it +} + +# Autoload methods go after =cut, and are processed by the autosplit program. +1; +__END__ + +=head1 NAME + +IO::Interface - Perl extension for access to network card configuration information + +=head1 SYNOPSIS + + # ====================== + # the new, preferred API + # ====================== + + use IO::Interface::Simple; + + my $if1 = IO::Interface::Simple->new('eth0'); + my $if2 = IO::Interface::Simple->new_from_address('127.0.0.1'); + my $if3 = IO::Interface::Simple->new_from_index(1); + + my @interfaces = IO::Interface::Simple->interfaces; + + for my $if (@interfaces) { + print "interface = $if\n"; + print "addr = ",$if->address,"\n", + "broadcast = ",$if->broadcast,"\n", + "netmask = ",$if->netmask,"\n", + "dstaddr = ",$if->dstaddr,"\n", + "hwaddr = ",$if->hwaddr,"\n", + "mtu = ",$if->mtu,"\n", + "metric = ",$if->metric,"\n", + "index = ",$if->index,"\n"; + + print "is running\n" if $if->is_running; + print "is broadcast\n" if $if->is_broadcast; + print "is p-to-p\n" if $if->is_pt2pt; + print "is loopback\n" if $if->is_loopback; + print "is promiscuous\n" if $if->is_promiscuous; + print "is multicast\n" if $if->is_multicast; + print "is notrailers\n" if $if->is_notrailers; + print "is noarp\n" if $if->is_noarp; + } + + + # =========== + # the old API + # =========== + + use IO::Socket; + use IO::Interface qw(:flags); + + my $s = IO::Socket::INET->new(Proto => 'udp'); + my @interfaces = $s->if_list; + + for my $if (@interfaces) { + print "interface = $if\n"; + my $flags = $s->if_flags($if); + print "addr = ",$s->if_addr($if),"\n", + "broadcast = ",$s->if_broadcast($if),"\n", + "netmask = ",$s->if_netmask($if),"\n", + "dstaddr = ",$s->if_dstaddr($if),"\n", + "hwaddr = ",$s->if_hwaddr($if),"\n"; + + print "is running\n" if $flags & IFF_RUNNING; + print "is broadcast\n" if $flags & IFF_BROADCAST; + print "is p-to-p\n" if $flags & IFF_POINTOPOINT; + print "is loopback\n" if $flags & IFF_LOOPBACK; + print "is promiscuous\n" if $flags & IFF_PROMISC; + print "is multicast\n" if $flags & IFF_MULTICAST; + print "is notrailers\n" if $flags & IFF_NOTRAILERS; + print "is noarp\n" if $flags & IFF_NOARP; + } + + my $interface = $s->addr_to_interface('127.0.0.1'); + + +=head1 DESCRIPTION + +IO::Interface adds methods to IO::Socket objects that allows them to +be used to retrieve and change information about the network +interfaces on your system. In addition to the object-oriented access +methods, you can use a function-oriented style. + +THIS API IS DEPRECATED. Please see L for the +preferred way to get and set interface configuration information. + +=head2 Creating a Socket to Access Interface Information + +You must create a socket before you can access interface +information. The socket does not have to be connected to a remote +site, or even used for communication. The simplest procedure is to +create a UDP protocol socket: + + my $s = IO::Socket::INET->new(Proto => 'udp'); + +The various IO::Interface functions will now be available as methods +on this socket. + +=head2 Methods + +=over 4 + +=item @iflist = $s->if_list + +The if_list() method will return a list of active interface names, for +example "eth0" or "tu0". If no interfaces are configured and running, +returns an empty list. + +=item $addr = $s->if_addr($ifname [,$newaddr]) + +if_addr() gets or sets the interface address. Call with the interface +name to retrieve the address (in dotted decimal format). Call with a +new address to set the interface. In the latter case, the routine +will return a true value if the operation was successful. + + my $oldaddr = $s->if_addr('eth0'); + $s->if_addr('eth0','192.168.8.10') || die "couldn't set address: $!"; + +Special case: the address of the pseudo-device "any" will return the +IP address "0.0.0.0", which corresponds to the INADDR_ANY constant. + +=item $broadcast = $s->if_broadcast($ifname [,$newbroadcast] + +Get or set the interface broadcast address. If the interface does not +have a broadcast address, returns undef. + +=item $mask = $s->if_netmask($ifname [,$newmask]) + +Get or set the interface netmask. + +=item $dstaddr = $s->if_dstaddr($ifname [,$newdest]) + +Get or set the destination address for point-to-point interfaces. + +=item $hwaddr = $s->if_hwaddr($ifname [,$newhwaddr]) + +Get or set the hardware address for the interface. Currently only +ethernet addresses in the form "00:60:2D:2D:51:70" are accepted. + +=item $flags = $s->if_flags($ifname [,$newflags]) + +Get or set the flags for the interface. The flags are a bitmask +formed from a series of constants. See L below. + +=item $ifname = $s->addr_to_interface($ifaddr) + +Given an interface address in dotted form, returns the name of the +interface associated with it. Special case: the INADDR_ANY address, +0.0.0.0 will return a pseudo-interface name of "any". + +=back + +=head2 EXPORT + +IO::Interface exports nothing by default. However, you can import the +following symbol groups into your namespace: + + :functions Function-oriented interface (see below) + :flags Flag constants (see below) + :all All of the above + +=head2 Function-Oriented Interface + +By importing the ":functions" set, you can access IO::Interface in a +function-oriented manner. This imports all the methods described +above into your namespace. Example: + + use IO::Socket; + use IO::Interface ':functions'; + + my $sock = IO::Socket::INET->new(Proto=>'udp'); + my @interfaces = if_list($sock); + print "address = ",if_addr($sock,$interfaces[0]); + +=head2 Exportable constants + +The ":flags" constant imports the following constants for use with the +flags returned by if_flags(): + + IFF_ALLMULTI + IFF_AUTOMEDIA + IFF_BROADCAST + IFF_DEBUG + IFF_LOOPBACK + IFF_MASTER + IFF_MULTICAST + IFF_NOARP + IFF_NOTRAILERS + IFF_POINTOPOINT + IFF_PORTSEL + IFF_PROMISC + IFF_RUNNING + IFF_SLAVE + IFF_UP + +This example determines whether interface 'tu0' supports multicasting: + + use IO::Socket; + use IO::Interface ':flags'; + my $sock = IO::Socket::INET->new(Proto=>'udp'); + print "can multicast!\n" if $sock->if_flags & IFF_MULTICAST. + +=head1 AUTHOR + +Lincoln D. Stein +Copyright 2001-2014, Lincoln D. Stein. + +This library is distributed under the Perl Artistic License +2.0. Please see LICENSE for more information. + +=head1 SUPPORT + +For feature requests, bug reports and code contributions, please use +the GitHub repository at +https://github.com/lstein/LibIO-Interface-Perl + +=head1 SEE ALSO + +perl(1), IO::Socket(3), IO::Multicast(3), L + +=cut diff --git a/lib/site/IO/Interface/Simple.pm b/lib/site/IO/Interface/Simple.pm new file mode 100644 index 000000000..def0b1ebf --- /dev/null +++ b/lib/site/IO/Interface/Simple.pm @@ -0,0 +1,287 @@ +package IO::Interface::Simple; +use strict; +use IO::Socket; +use IO::Interface; + +use overload '""' => \&as_string, + eq => '_eq_', + fallback => 1; + +# class variable +my $socket; + +# class methods +sub interfaces { + my $class = shift; + my $s = $class->sock; + return sort {($a->index||0) <=> ($b->index||0) } map {$class->new($_)} $s->if_list; +} + +sub new { + my $class = shift; + my $if_name = shift; + my $s = $class->sock; + return unless defined $s->if_mtu($if_name); + return bless {s => $s, + name => $if_name},ref $class || $class; +} + +sub new_from_address { + my $class = shift; + my $addr = shift; + my $s = $class->sock; + my $name = $s->addr_to_interface($addr) or return; + return $class->new($name); +} + +sub new_from_index { + my $class = shift; + my $index = shift; + my $s = $class->sock; + my $name = $s->if_indextoname($index) or return; + return $class->new($name); +} + +sub sock { + my $self = shift; + if (ref $self) { + return $self->{s} ||= $socket; + } else { + return $socket ||= IO::Socket::INET->new(Proto=>'udp'); + } +} + +sub _eq_ { + return shift->name eq shift; +} + +sub as_string { + shift->name; +} + +sub name { + shift->{name}; +} + +sub address { + my $self = shift; + $self->sock->if_addr($self->name,@_); +} + +sub broadcast { + my $self = shift; + $self->sock->if_broadcast($self->name,@_); +} + +sub netmask { + my $self = shift; + $self->sock->if_netmask($self->name,@_); +} + +sub dstaddr { + my $self = shift; + $self->sock->if_dstaddr($self->name,@_); +} + +sub hwaddr { + my $self = shift; + $self->sock->if_hwaddr($self->name,@_); +} + +sub flags { + my $self = shift; + $self->sock->if_flags($self->name,@_); +} + +sub mtu { + my $self = shift; + $self->sock->if_mtu($self->name,@_); +} + +sub metric { + my $self = shift; + $self->sock->if_metric($self->name,@_); +} + +sub index { + my $self = shift; + return $self->sock->if_index($self->name); +} + +sub is_running { shift->_gettestflag(IO::Interface::IFF_RUNNING(),@_) } +sub is_broadcast { shift->_gettestflag(IO::Interface::IFF_BROADCAST(),@_) } +sub is_pt2pt { shift->_gettestflag(IO::Interface::IFF_POINTOPOINT(),@_) } +sub is_loopback { shift->_gettestflag(IO::Interface::IFF_LOOPBACK(),@_) } +sub is_promiscuous { shift->_gettestflag(IO::Interface::IFF_PROMISC(),@_) } +sub is_multicast { shift->_gettestflag(IO::Interface::IFF_MULTICAST(),@_) } +sub is_notrailers { shift->_gettestflag(IO::Interface::IFF_NOTRAILERS(),@_) } +sub is_noarp { shift->_gettestflag(IO::Interface::IFF_NOARP(),@_) } + +sub _gettestflag { + my $self = shift; + my $bitmask = shift; + my $flags = $self->flags; + if (@_) { + $flags |= $bitmask; + $self->flags($flags); + } else { + return ($flags & $bitmask) != 0; + } +} + +1; + +=head1 NAME + +IO::Interface::Simple - Perl extension for access to network card configuration information + +=head1 SYNOPSIS + + use IO::Interface::Simple; + + my $if1 = IO::Interface::Simple->new('eth0'); + my $if2 = IO::Interface::Simple->new_from_address('127.0.0.1'); + my $if3 = IO::Interface::Simple->new_from_index(1); + + my @interfaces = IO::Interface::Simple->interfaces; + + for my $if (@interfaces) { + print "interface = $if\n"; + print "addr = ",$if->address,"\n", + "broadcast = ",$if->broadcast,"\n", + "netmask = ",$if->netmask,"\n", + "dstaddr = ",$if->dstaddr,"\n", + "hwaddr = ",$if->hwaddr,"\n", + "mtu = ",$if->mtu,"\n", + "metric = ",$if->metric,"\n", + "index = ",$if->index,"\n"; + + print "is running\n" if $if->is_running; + print "is broadcast\n" if $if->is_broadcast; + print "is p-to-p\n" if $if->is_pt2pt; + print "is loopback\n" if $if->is_loopback; + print "is promiscuous\n" if $if->is_promiscuous; + print "is multicast\n" if $if->is_multicast; + print "is notrailers\n" if $if->is_notrailers; + print "is noarp\n" if $if->is_noarp; + } + + +=head1 DESCRIPTION + +IO::Interface::Simple allows you to interrogate and change network +interfaces. It has overlapping functionality with Net::Interface, but +might compile and run on more platforms. + +=head2 Class Methods + +=over 4 + +=item $interface = IO::Interface::Simple->new('eth0') + +Given an interface name, new() creates an interface object. + +=item @iflist = IO::Interface::Simple->interfaces; + +Returns a list of active interface objects. + +=item $interface = IO::Interface::Simple->new_from_address('192.168.0.1') + +Returns the interface object corresponding to the given address. + +=item $interface = IO::Interface::Simple->new_from_index(2) + +Returns the interface object corresponding to the given numeric +index. This is only supported on BSD-ish platforms. + +=back + +=head2 Object Methods + +=over 4 + +=item $name = $interface->name + +Get the name of the interface. The interface object is also overloaded +so that if you use it in a string context it is the same as calling +name(). + +=item $index = $interface->index + +Get the index of the interface. This is only supported on BSD-like +platforms. + +=item $addr = $interface->address([$newaddr]) + +Get or set the interface's address. + + +=item $addr = $interface->broadcast([$newaddr]) + +Get or set the interface's broadcast address. + +=item $addr = $interface->netmask([$newmask]) + +Get or set the interface's netmask. + +=item $addr = $interface->hwaddr([$newaddr]) + +Get or set the interface's hardware address. + +=item $addr = $interface->mtu([$newmtu]) + +Get or set the interface's MTU. + +=item $addr = $interface->metric([$newmetric]) + +Get or set the interface's metric. + +=item $flags = $interface->flags([$newflags]) + +Get or set the interface's flags. These can be ANDed with the IFF +constants exported by IO::Interface or Net::Interface in order to +interrogate the state and capabilities of the interface. However, it +is probably more convenient to use the broken-out methods listed +below. + +=item $flag = $interface->is_running([$newflag]) + +=item $flag = $interface->is_broadcast([$newflag]) + +=item $flag = $interface->is_pt2pt([$newflag]) + +=item $flag = $interface->is_loopback([$newflag]) + +=item $flag = $interface->is_promiscuous([$newflag]) + +=item $flag = $interface->is_multicast([$newflag]) + +=item $flag = $interface->is_notrailers([$newflag]) + +=item $flag = $interface->is_noarp([$newflag]) + +Get or set the corresponding configuration parameters. Note that the +operating system may not let you set some of these. + +=back + +=head1 AUTHOR + +Lincoln D. Stein +Copyright 2001-2014, Lincoln D. Stein. + +This library is distributed under the Perl Artistic License +2.0. Please see LICENSE for more information. + +=head1 SUPPORT + +For feature requests, bug reports and code contributions, please use +the GitHub repository at +https://github.com/lstein/LibIO-Interface-Perl + +=head1 SEE ALSO + +L, L, L), L, L + +=cut + diff --git a/lib/site/IO/Socket/Multicast.pm b/lib/site/IO/Socket/Multicast.pm new file mode 100644 index 000000000..d69edb17a --- /dev/null +++ b/lib/site/IO/Socket/Multicast.pm @@ -0,0 +1,426 @@ +package IO::Socket::Multicast; + +use 5.005; +use strict; +use Carp 'croak'; +use Exporter (); +use DynaLoader (); +use IO::Socket; +BEGIN { + eval "use IO::Interface 0.94 'IFF_MULTICAST';"; +} +use vars qw(@ISA @EXPORT_OK @EXPORT %EXPORT_TAGS $VERSION); +BEGIN { + my @functions = qw( + mcast_add + mcast_drop + mcast_if + mcast_loopback + mcast_ttl + mcast_dest + mcast_send + ); + $VERSION = '1.12'; + @ISA = qw( + Exporter + DynaLoader + IO::Socket::INET + ); + @EXPORT = ( ); + %EXPORT_TAGS = ( + 'all' => \@functions, + 'functions' => \@functions, + ); + @EXPORT_OK = @{ $EXPORT_TAGS{'all'} }; +} + +my $IP = '\d+\.\d+\.\d+\.\d+'; + +sub import { + Socket->export_to_level(1,@_); + IO::Socket::Multicast->export_to_level(1,@_); +} + +sub new { + my $class = shift; + unshift @_,(Proto => 'udp') unless @_; + $class->SUPER::new(@_); +} + +sub configure { + my($self,$arg) = @_; + $arg->{Proto} ||= 'udp'; + $self->SUPER::configure($arg); +} + +sub mcast_add { + my $sock = shift; + my $group = shift || croak 'usage: $sock->mcast_add($mcast_addr [,$interface])'; + $group = inet_ntoa($group) unless $group =~ /^$IP$/o; + my $interface = get_if_addr($sock,shift); + return $sock->_mcast_add($group,$interface); +} + +sub mcast_drop { + my $sock = shift; + my $group = shift || croak 'usage: $sock->mcast_add($mcast_addr [,$interface])'; + $group = inet_ntoa($group) unless $group =~ /^$IP$/o; + my $interface = get_if_addr($sock,shift); + return $sock->_mcast_drop($group,$interface); +} + +sub mcast_if { + my $sock = shift; + + my $previous = $sock->_mcast_if; + $previous = $sock->addr_to_interface($previous) + if $sock->can('addr_to_interface'); + return $previous unless @_; + + my $interface = get_if_addr($sock,shift); + return $sock->_mcast_if($interface) ? $previous : undef; +} + +sub get_if_addr { + my $sock = shift; + return '0.0.0.0' unless defined (my $interface = shift); + return $interface if $interface =~ /^$IP$/; + return $interface if length $interface == 16; + croak "IO::Interface module not available; use IP addr for interface" + unless $sock->can('if_addr'); + croak "unknown or unconfigured interace $interface" + unless my $addr = $sock->if_addr($interface); + croak "interface is not multicast capable" + unless $interface eq 'any' or ($sock->if_flags($interface) & IFF_MULTICAST()); + return $addr; +} + +sub mcast_dest { + my $sock = shift; + my $prev = ${*$sock}{'io_socket_mcast_dest'}; + if (my $dest = shift) { + $dest = sockaddr_in($2,inet_aton($1)) if $dest =~ /^($IP):(\d+)$/; + croak "invalid destination address" unless length($dest) == 16; + ${*$sock}{'io_socket_mcast_dest'} = $dest; + } + return $prev; +} + +sub mcast_send { + my $sock = shift; + my $data = shift || croak 'usage: $sock->mcast_send($data [,$address])'; + $sock->mcast_dest(shift) if @_; + my $dest = $sock->mcast_dest || croak "no destination specified with mcast_send() or mcast_dest()"; + return send($sock,$data,0,$dest); +} + +bootstrap IO::Socket::Multicast $VERSION; + +1; + +__END__ + +=pod + +=head1 NAME + +IO::Socket::Multicast - Send and receive multicast messages + +=head1 SYNOPSIS + + use IO::Socket::Multicast; + + # create a new UDP socket ready to read datagrams on port 1100 + my $s = IO::Socket::Multicast->new(LocalPort=>1100); + + # Add a multicast group + $s->mcast_add('225.0.1.1'); + + # Add a multicast group to eth0 device + $s->mcast_add('225.0.0.2','eth0'); + + # now receive some multicast data + $s->recv($data,1024); + + # Drop a multicast group + $s->mcast_drop('225.0.0.1'); + + # Set outgoing interface to eth0 + $s->mcast_if('eth0'); + + # Set time to live on outgoing multicast packets + $s->mcast_ttl(10); + + # Turn off loopbacking + $s->mcast_loopback(0); + + # Multicast a message to group 225.0.0.1 + $s->mcast_send('hello world!','225.0.0.1:1200'); + $s->mcast_set('225.0.0.2:1200'); + $s->mcast_send('hello again!'); + +=head1 DESCRIPTION + +The IO::Socket::Multicast module subclasses IO::Socket::INET to enable +you to manipulate multicast groups. With this module (and an +operating system that supports multicasting), you will be able to +receive incoming multicast transmissions and generate your own +outgoing multicast packets. + +This module requires IO::Interface version 0.94 or higher. + +=head2 INTRODUCTION + +Multicasting is designed for streaming multimedia applications and for +conferencing systems in which one transmitting machines needs to +distribute data to a large number of clients. + +IP addresses in the range 224.0.0.0 and 239.255.255.255 are reserved +for multicasting. These addresses do not correspond to individual +machines, but to multicast groups. Messages sent to these addresses +will be delivered to a potentially large number of machines that have +registered their interest in receiving transmissions on these groups. +They work like TV channels. A program tunes in to a multicast group +to receive transmissions to it, and tunes out when it no longer +wishes to receive the transmissions. + +To receive transmissions B a multicast group, you will use +IO::Socket::Multicast->new() to create a UDP socket and bind it to a local +network port. You will then subscribe one or more multicast groups +using the mcast_add() method. Subsequent calls to the standard recv() +method will now receive messages incoming messages transmitted to the +subscribed groups using the selected port number. + +To send transmissions B a multicast group, you can use the +standard send() method to send messages to the multicast group and +port of your choice. The mcast_set() and mcast_send() methods are +provided as convenience functions. Mcast_set() will set a default +multicast destination for messages which you then send with +mcast_send(). + +To set the number of hops (routers) that outgoing multicast messages +will cross, call mcast_ttl(). To activate or deactivate the looping +back of multicast messages (in which a copy of the transmitted +messages is received by the local machine), call mcast_loopback(). + +=head2 CONSTRUCTORS + +=over 4 + +=item $socket = IO::Socket::Multicast->new([LocalPort=>$port,...]) + +The new() method is the constructor for the IO::Socket::Multicast +class. It takes the same arguments as IO::Socket::INET, except that +the B argument, rather than defaulting to "tcp", will default +to "udp", which is more appropriate for multicasting. + +To create a UDP socket suitable for sending outgoing multicast +messages, call new() without arguments (or with +C'udp'>). To create a UDP socket that can also receive +incoming multicast transmissions on a specific port, call new() with +the B argument. + +If you plan to run the client and server on the same machine, you may +wish to set the IO::Socket B argument to a true value. +This allows multiple multicast sockets to bind to the same address. + +=back + +=head2 METHODS + +=over 4 + +=item $success = $socket->mcast_add($multicast_address [,$interface]) + +The mcast_add() method will add the provided multicast address to the +list of subscribed multicast groups. The address may be provided +either as a dotted-quad decimal, or as a packed IP address (such as +produced by the inet_aton() function). On success, the method will +return a true value. + +The optional $interface argument can be used to specify on which +network interface to listen for incoming multicast messages. If the +IO::Interface module is installed, you may use the device name for the +interface (e.g. "tu0"). Otherwise, you must use the IP address of the +desired network interface. Either dotted quad form or packed IP +address is acceptable. If no interface is specified, then the +multicast group is joined on INADDR_ANY, meaning that multicast +transmissions received on B of the host's network interfaces will +be forwarded to the socket. + +Note that mcast_add() operates on the underlying interface(s) and not +on the socket. If you have multiple sockets listening on a port, and +you mcast_add() a group to one of those sockets, subsequently B +the sockets will receive mcast messages on this group. To filter +messages that can be received by a socket so that only those sent to a +particular multicast address are received, pass the B +option to the socket at the time you create it: + + my $socket = IO::Socket::Multicast->new(LocalPort=>2000, + LocalAddr=>226.1.1.2', + ReuseAddr=>1); + $socket->mcast_add('226.1.1.2'); + +By combining this technique with IO::Select, you can write +applications that listen to multiple multicast groups and distinguish +which group a message was addressed to by identifying which socket it +was received on. + +=item $success = $socket->mcast_drop($multicast_address) + +This reverses the action of mcast_add(), removing the indicated +multicast address from the list of subscribed groups. + +=item $loopback = $socket->mcast_loopback + +=item $previous = $socket->mcast_loopback($new) + +The mcast_loopback() method controls whether the socket will receive +its own multicast transmissions (default yes). Called without +arguments, the method returns the current state of the loopback +flag. Called with a boolean argument, the method will set the loopback +flag, and return its previous value. + +=item $ttl = $socket->mcast_ttl + +=item $previous = $socket->mcast_ttl($new) + +The mcast_ttl() method examines or sets the time to live (TTL) for +outgoing multicast messages. The TTL controls the numbers of routers +the packet can cross before being expired. The default TTL is 1, +meaning that the message is confined to the local area network. +Values between 0 and 255 are valid. + +Called without arguments, this method returns the socket's current +TTL. Called with a value, this method sets the TTL and returns its +previous value. + +=item $interface = $socket->mcast_if + +=item $previous = $socket->mcast_if($new) + +By default, the OS will pick the network interface to use for outgoing +multicasts automatically. You can control this process by using the +mcast_if() method to set the outgoing network interface explicitly. +Called without arguments, returns the current interface. Called with +the name of an interface, sets the outgoing interface and returns its +previous value. + +You can use the device name for the interface (e.g. "tu0") if the +IO::Interface module is present. Otherwise, you must use the +interface's dotted IP address. + +B: To set the interface used for B multicasts, use the +mcast_add() method. + +=item $dest = $socket->mcast_dest + +=item $previous = $socket->mcast_dest($new) + +The mcast_dest() method is a convenience function that allows you to +set the default destination group for outgoing multicasts. Called +without arguments, returns the current destination as a packed binary +sockaddr_in data structure. Called with a new destination address, +the method sets the default destination and returns the previous one, +if any. + +Destination addresses may be provided as packed sockaddr_in +structures, or in the form "XX.XX.XX.XX:YY" where the first part is +the IP address, and the second the port number. + +=item $bytes = $socket->mcast_send($data [,$dest]) + +Mcast_send() is a convenience function that simplifies the sending of +multicast messages. C<$data> is the message contents, and C<$dest> is +an optional destination group. You can use either the dotted IP form +of the destination address and its port number, or a packed +sockaddr_in structure. If the destination is not supplied, it will +default to the most recent value set in mcast_dest() or a previous +call to mcast_send(). + +The method returns the number of bytes successfully queued for +delivery. + +As a side-effect, the method will call mcast_dest() to remember the +destination address. + +Example: + + $socket->mcast_send('Hi there group members!','225.0.1.1:1900') || die; + $socket->mcast_send("How's the weather?") || die; + +Note that you may still call IO::Socket::Multicast->new() with a +B, and IO::Socket::INET will perform a connect(), creating a +default destination for calls to send(). + +=back + +=head1 EXAMPLE + +The following is an example of a multicast server. Every 10 seconds +it transmits the current time and the list of logged-in users to the +local network using multicast group 226.1.1.2, port 2000 (these are +chosen arbitrarily). + + #!/usr/bin/perl + # server + use strict; + use IO::Socket::Multicast; + + use constant DESTINATION => '226.1.1.2:2000'; + my $sock = IO::Socket::Multicast->new(Proto=>'udp',PeerAddr=>DESTINATION); + + while (1) { + my $message = localtime; + $message .= "\n" . `who`; + $sock->send($message) || die "Couldn't send: $!"; + } continue { + sleep 10; + } + +This is the corresponding client. It listens for transmissions on +group 226.1.1.2, port 2000, and echoes the messages to standard +output. + + #!/usr/bin/perl + # client + + use strict; + use IO::Socket::Multicast; + + use constant GROUP => '226.1.1.2'; + use constant PORT => '2000'; + + my $sock = IO::Socket::Multicast->new(Proto=>'udp',LocalPort=>PORT); + $sock->mcast_add(GROUP) || die "Couldn't set group: $!\n"; + + while (1) { + my $data; + next unless $sock->recv($data,1024); + print $data; + } + +=head2 EXPORT + +None by default. However, if you wish to call mcast_add(), +mcast_drop(), mcast_if(), mcast_loopback(), mcast_ttl, mcast_dest() +and mcast_send() as functions you may import them explicitly on the +B line or by importing the tag ":functions". + +=head2 BUGS + +The mcast_if(), mcast_ttl() and mcast_loopback() methods will cause a +crash on versions of Linux earlier than 2.2.0 because of a kernel bug +in the implementation of the multicast socket options. + +=head1 AUTHOR + +Lincoln Stein, lstein@cshl.org. + +This module is distributed under the same terms as Perl itself. + +=head1 SEE ALSO + +perl(1), IO::Socket(3), IO::Socket::INET(3). + +=cut