Power module to talk to Jon's Awesome Arduino Power Controller

which I affectionately call "powduino".

tbsetup/GNUmakefile.in

@@ -106,7 +106,7 @@ LIBEXEC_STUFF	= wanlinksolve wanlinkinfo os_setup mkexpdir console_setup \
                   $(WEB_BIN_SCRIPTS) $(WEB_SBIN_SCRIPTS)
 
 LIB_STUFF       = libtbsetup.pm exitonwarn.pm libtestbed.pm \
-                  power_rpc27.pm power_apc.pm power_ue.pm \
+                  power_rpc27.pm power_apc.pm power_ue.pm power_powduino.pm \
 		  power_sgmote.pm power_racktivity.pm \
 		  libaudit.pm libreboot.pm libosload.pm libtestbed.py \
 		  libadminmfs.pm libtblog.pm libtblog_simple.pm libArchive.pm \

tbsetup/power.in

-#!/usr/bin/perl -wT
+#!/usr/bin/perl -w
 
 #
-# Copyright (c) 2000-2016 University of Utah and the Flux Group.
+# Copyright (c) 2000-2018 University of Utah and the Flux Group.
 # 
 # {{{EMULAB-LICENSE
 # 
@@ -55,6 +55,7 @@ use power_icebox;
 use power_apc;
 use power_racktivity;
 use power_ue;
+use power_powduino;
 use libtestbed;
 use User;
 use Node;
@@ -452,6 +453,12 @@ foreach my $power_id (keys %outlets) {
     } elsif ($type =~ "RPC") {
 	if (rpc27ctrl($op,$power_id,@outlets)) {
 	    print "Control of $nodestr failed.\n"; $exitval++;
+	    $errors++;
+	}
+    } elsif ($type eq "powduino") {
+	if (powduinoctrl($op,$power_id,@outlets)) {
+	    print "Control of $nodestr failed.\n"; $exitval++;
+	    $errors++;
 	}
     } elsif (($class eq "sg") || ($type eq "garcia")) {
 	# XXX: 'garcia' is temporary until stargates are subnodes of

tbsetup/power_powduino.pm.in

+#!/usr/bin/perl -wT
+
+#
+# Copyright (c) 2000-2018 University of Utah and the Flux Group.
+# 
+# {{{EMULAB-LICENSE
+# 
+# This file is part of the Emulab network testbed software.
+# 
+# This file is free software: you can redistribute it and/or modify it
+# under the terms of the GNU Affero General Public License as published by
+# the Free Software Foundation, either version 3 of the License, or (at
+# your option) any later version.
+# 
+# This file 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 Affero General Public
+# License for more details.
+# 
+# You should have received a copy of the GNU Affero General Public License
+# along with this file.  If not, see <http://www.gnu.org/licenses/>.
+# 
+# }}}
+#
+
+
+package power_powduino;
+
+use Exporter;
+@ISA = ("Exporter");
+@EXPORT = qw( powduinoctrl );
+
+use Socket;
+use IO::Handle;
+use lib "@prefix@/lib";
+use libdb;
+use Node;
+use POSIX qw(strftime);
+
+#
+# A little perl module for using Jon's arduino relay on a Powder node.
+#
+
+# Turn off line buffering on output
+$| = 1;
+
+# Number of times to try sending command in the face of "Input error"
+my $ntries = 3;
+
+# Set for more output.
+my $debug = 0;
+
+# Prompt string
+my $PROMPT = 'power> ';
+
+my %CMDS =
+  ("cycle"  => "power cycle",
+   "on"     => "power on",
+   "off"    => "power off");
+
+# Main routine.
+# usage: powduinoctrl(cmd, controller, outlet)
+# cmd = { "cycle" | "on" | "off" }
+# controller = <node_id>
+# outlet = int, 0 <= outlet < N
+#
+# Returns 0 on success. Non-zero on failure.
+# 
+sub powduinoctrl {
+    my($cmd, $controller, @outlets) = @_;
+
+    #
+    # Check parameters
+    #
+    if (!defined($CMDS{$cmd})) {
+	print STDERR "*** Undefined command: '$cmd'\n";
+	return 1;
+    }
+    if (grep {$_ < 0 || $_ > 3} @outlets) {
+	print STDERR "*** Invalid outlet '$outlet': Must be 0-3\n";
+	return 1;
+    }
+
+    if ($debug) {
+	print "outlets: ", join(" ",map("($_)",@outlets)), "\n";
+    }
+
+    #
+    # Run the rest in a child process, protected by an alarm to ensure that
+    # we are not hung up forever if the controller is in some funky state.
+    #
+    my $syspid = fork();
+
+    if ($syspid) {
+	local $SIG{ALRM} = sub { kill("TERM", $syspid); };
+	#
+	# Give it 30 seconds for initial connect plus time per outlet.
+	# Probably too long.
+	#
+	alarm 30 + (10 * scalar(@outlets));
+	waitpid($syspid, 0);
+	alarm 0;
+	my $exitstatus = $?;
+
+	if ($exitstatus == 15) {
+	    print STDERR "*** power: $controller is wedged.\n";
+	}
+	return($exitstatus);
+    }
+    TBdbfork();
+
+    #
+    # Form the connection to the controller via a "tip" line to the
+    # capture process. Once we have that, we can just talk to the
+    # controller directly.
+    #
+    if (! ($TIP = tipconnect($controller))) {
+	print STDERR "*** Could not form TIP connection to $controller\n";
+	exit(1);
+    }
+
+    foreach my $outlet (@outlets) {
+	my $command = "$CMDS{$cmd} $outlet";
+	my $status;
+	for my $try (1..$ntries) {
+	    $status = syncandsend($controller, $TIP, $command);
+	    last
+		if $status >= 0;
+	}
+	if ($status) {
+	    close($TIP);
+	    exit(1);
+	}
+    }
+    close($TIP);
+    exit(0);
+}
+
+#
+# Sync up with the power controller, and set it a command. $controller is the
+# controller name, for error message purposes, $TIP is the connection to
+# the controller opened with tipconnect, and $command is the whole command
+# (ie. 'reboot 20,40') to send.
+#
+# Returns 0 if successful, -1 if the caller should try again,
+# 1 on an unexpected error.
+#
+sub syncandsend($$$) {
+    my ($controller,$TIP,$cmd) = @_;
+
+    #
+    # Send a newline to get the command prompt, and then wait
+    # for it to print out the command prompt. This loop is set for a small
+    # number since if it cannot get the prompt quickly, then something has
+    # gone wrong.
+    #
+    my $insync = 0;
+
+    for (my $i = 0; $i < 20; $i++) {
+	my $line;
+
+	if (syswrite($TIP, "\r") == 0) {
+	    print STDERR
+		"*** Power control sync write failed ($controller/$outlet)\n";
+	    return 1;
+	}
+
+	$line = rpc_readline($TIP);
+	if (!defined($line)) {
+	    print STDERR
+		"*** Power control sync read failed ".
+		    "($controller/$outlet)\n";
+	    return 1;
+	}
+	if ($debug) {
+	    print "Read: $line";
+	}
+	if ($line =~ /$PROMPT/) {
+	    if ($debug) {
+		print "Matched prompt 'PROMPT'!\n";
+	    }
+	    $insync = 1;
+	    last;
+	}
+    }
+    if (! $insync) {
+	print STDERR "*** Could not sync with power controller! ".
+	    "($controller)\n";
+	return 1;
+    }
+
+    if ($debug) {
+	print "Sending '$cmd' to $controller\n";
+    }
+
+    # Okay, got a prompt. Send it the string:
+    if (syswrite($TIP, "$cmd\r") == 0) {
+    	print STDERR "*** Power control write failed ($controller/$outlet)\n";
+    	return 1;
+    }
+
+    #
+    # Read and parse all the output until the next prompt to ensure that
+    # there was no read error.  
+    #
+    my $gotcmd = 0;
+    print "Reading output following command\n"
+	if ($debug);
+    while (my $line = rpc_readline($TIP)) {
+	print "Read: $line"
+	    if ($debug);
+	# skip echoed prompt+command
+	if ($line =~ /$cmd/) {
+	    $gotcmd = 1;
+	    print "GotCmd\n" if ($debug);
+	    next;
+	}
+	# didn't recognize our command for some reason, return failure
+	if ($line =~ /Invalid/) {
+	    print "Bad result\n" if ($debug);
+	    return -1;
+	}
+	#
+	# Got the following prompt, all done.
+	#
+	if ($gotcmd && $line =~ /$PROMPT/) {
+	    last;
+	}
+    }
+    return 0;
+}
+
+#
+# Connect up to the capture process. This should probably be in a library
+# someplace.
+#
+sub tipconnect($) {
+    my($controller) = $_[0];
+    my($server, $portnum, $keylen, $keydata, $capreturn);
+    my($inetaddr, $paddr, $proto);
+    my(%powerid_row);
+    local *TIP;
+
+    my $query_result =
+      DBQueryWarn("select * from tiplines where node_id='$controller'");
+
+    if ($query_result->numrows < 1) {
+	print STDERR "*** No such tipline: $controller\n";
+	return 0;
+    }
+    %powerid_row = $query_result->fetchhash();
+
+    $server  = $powerid_row{'server'};
+    $portnum = $powerid_row{'portnum'};
+    $keylen  = $powerid_row{'keylen'};
+    $keydata = $powerid_row{'keydata'};
+    $disabled= $powerid_row{'disabled'};
+
+    if ($disabled) {
+	print STDERR "*** $controller tipline is disabled\n";
+	return 0;
+    }
+
+    if ($debug) {
+	print "tipconnect: $server $portnum $keylen $keydata\n";
+    }
+
+    #
+    # We have to send over the key. This is a little hokey, since we have
+    # to make it look like the C struct.
+    #
+    my $secretkey = pack("iZ256", $keylen, $keydata);
+    my $capret    = pack("i", 0);
+
+    #
+    # This stuff from the PERLIPC manpage.
+    # 
+    if (! ($inetaddr = inet_aton($server))) {
+	print STDERR "*** Cannot map $server to IP address\n";
+	return 0;
+    }
+    $paddr    = sockaddr_in($portnum, $inetaddr);
+    $proto    = getprotobyname('tcp');
+
+    for (my $i = 0; $i < 20; $i++) {
+	if (! socket(TIP, PF_INET, SOCK_STREAM, $proto)) {
+	    print STDERR "*** Cannot create socket.\n";
+	    return 0;
+	}
+
+	if (! connect(TIP, $paddr)) {
+	    print STDERR
+		"*** Cannot connect to $controller on $server($portnum)\n";
+	    close(TIP);
+	    return 0;
+	}
+	TIP->autoflush(1);
+
+	#
+	# While its a fatal error if the connect fails, the write and the
+	# read that follows might fail because the tip is currently is
+	# active. The handshake writes back a value and then immediately
+	# closes the socket, which could manifest itself as a closed
+	# connection on this end, even before we get a change to do these.
+	# operations. In that case, just go around the loop again. We hope
+	# to succeed at some point. 
+	# 
+	if (! syswrite(TIP, $secretkey)) {
+	    print STDERR
+		"*** Cannot write to $controller on $server($portnum)\n";
+	    goto again;
+	}
+	if (! sysread(TIP, $capret, length($capret))) {
+	    print STDERR
+		"*** Cannot read from $controller on $server($portnum)\n";
+	    goto again;
+	}
+
+	my $foo = unpack("i", $capret);
+	if ($debug) {
+	    print "Capture returned $foo\n";
+	}
+	if ($foo == 0) {
+	    return(*TIP);
+	}
+	
+      again:
+	close(TIP);
+
+	if ($i && (($i % 5) == 0)) {
+	    printf STDERR
+		"*** WARNING: $controller on $server($portnum) is busy\n".
+		"    Waiting a bit before trying again. Pass $i.\n";
+	}
+	sleep(5);
+    }
+    
+    print STDERR
+	"*** $controller on $server($portnum) was busy for too long\n";
+    return 0;
+}
+
+sub rpc_readline($)
+{
+    my ($TIP) = @_;
+    my $line;
+
+    my $cc = 0;
+    while (1) {
+	if (sysread($TIP, $line, 1, $cc) == 0) {
+	    return undef;
+	}
+	print "got: =$line=\n" if ($debug > 1);
+	$cc++;
+	last if ($line =~ /\n/ || $line =~ /$PROMPT/ || $cc > 1023);
+    }
+    return $line;
+}
+
+1;