1 files changed, 347 insertions, 0 deletions
diff --git a/debian/tests/utils/mock.pm b/debian/tests/utils/mock.pm
new file mode 100644
index 0000000..10db3e6
--- /dev/null
+++ b/debian/tests/utils/mock.pm
@@ -0,0 +1,347 @@
+# Mock terminal interaction on a guest system
+#
+# Copyright © 2021-2022 Guilhem Moulin <guilhem@debian.org>
+#
+# 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 3 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, see <http://www.gnu.org/licenses/>.
+
+use v5.14.2;
+use warnings;
+use strict;
+
+our ($SERIAL, $CONSOLE, $MONITOR);
+our $PS1 = qr/root\@[\-\.0-9A-Z_a-z]+ : [~\/][\-\.\/0-9A-Z_a-z]* [\#\$]\ /aax;
+
+package CryptrootTest::Utils;
+
+use Socket qw/PF_UNIX SOCK_STREAM SOCK_CLOEXEC SOCK_NONBLOCK SHUT_RD SHUT_WR/;
+use Errno qw/EINTR ENOENT ECONNREFUSED/;
+use Time::HiRes ();
+
+my (%SOCKET, %BUFFER, $WBITS, $RBITS);
+
+BEGIN {
+    ($SERIAL, $CONSOLE, $MONITOR) = qw/ttyS0 hvc0 mon0/;
+    my $dir = $ARGV[1] =~ m#\A(/\p{Print}+)\z# ? $1 : die "Invalid base directory\n"; # untaint
+    my $epoch = Time::HiRes::time();
+    foreach my $id ($SERIAL, $CONSOLE, $MONITOR) {
+        my $path = $dir . "/" . $id;
+        my $sockaddr = Socket::pack_sockaddr_un($path) // die;
+        socket(my $socket, PF_UNIX, SOCK_STREAM|SOCK_CLOEXEC|SOCK_NONBLOCK, 0) or die "socket: $!";
+
+        until (connect($socket, $sockaddr)) {
+            if ($! == EINTR) {
+                # try again immediatly if connect(2) was interrupted by a signal
+            } elsif (($! == ENOENT or $! == ECONNREFUSED) and Time::HiRes::time() - $epoch < 30) {
+                # wait a bit to give QEMU time to create the socket and mark it at listening
+                Time::HiRes::usleep(100_000);
+            } else {
+                die "connect($path): $!";
+            }
+        }
+
+        my $fd = fileno($socket) // die;
+        vec($WBITS, $fd, 1) = 1;
+        vec($RBITS, $fd, 1) = 1;
+        $SOCKET{$id} = $socket;
+        $BUFFER{$id} = "";
+    }
+}
+
+sub read_data($) {
+    my $bits = shift;
+    while (my ($chan, $fh) = each %SOCKET) {
+        next unless vec($bits, fileno($fh), 1); # nothing to read here
+        my $n = sysread($fh, my $buf, 4096) // die "read: $!";
+        if ($n > 0) {
+            STDOUT->printflush($buf);
+            $BUFFER{$chan} .= $buf;
+        } else {
+            #print STDERR "INFO done reading from $chan\n";
+            shutdown($fh, SHUT_RD) or die "shutdown: $!";
+            vec($RBITS, fileno($fh), 1) = 0;
+        }
+    }
+}
+
+sub expect(;$$) {
+    my ($chan, $prompt) = @_;
+
+    my $buffer = defined $chan ? \$BUFFER{$chan} : undef;
+    if (defined $buffer and $$buffer =~ $prompt) {
+        $$buffer = $' // die;
+        return %+;
+    }
+
+    while(unpack("b*", $RBITS) != 0) {
+        my $rout = $RBITS;
+        while (select($rout, undef, undef, undef) == -1) {
+            die "select: $!" unless $! == EINTR; # try again immediately if select(2) was interrupted
+        }
+        read_data($rout);
+        if (defined $buffer and $$buffer =~ $prompt) {
+            $$buffer = $' // die;
+            return %+;
+        }
+    }
+    #print STDERR "INFO done reading\n";
+}
+
+sub write_data($$%) {
+    my $chan = shift;
+    my $data = shift;
+
+    my %options = @_;
+    $options{echo} //= 1;
+    $options{eol} //= "\r";
+    $options{reol} //= "\r\n";
+    my $wdata = $data . $options{eol};
+
+    my $wfh = $SOCKET{$chan} // die;
+    my $wfd = fileno($wfh) // die;
+    vec(my $win, $wfd, 1) = 1;
+
+    for (my $offset = 0, my $length = length($wdata); $offset < $length;) {
+        my $wout = $win;
+        while (select(undef, $wout, undef, undef) == -1) {
+            die "select: $!" unless $! == EINTR; # try again immediately if select(2) was interrupted
+        }
+        if (vec($wout, $wfd, 1)) {
+            my $n = syswrite($wfh, $wdata, $length - $offset, $offset) // die "write: $!";
+            $offset += $n;
+        }
+    }
+
+    my $rdata = $options{echo} ? $data : "";
+    $rdata .= $options{reol};
+
+    if ($rdata ne "") {
+        my $buf = \$BUFFER{$chan};
+        my $rfh = $SOCKET{$chan} // die;
+        my $rfd = fileno($rfh) // die;
+        vec(my $rin, $rfd, 1) = 1;
+
+        my $rlen = length($rdata);
+        while($rlen > 0) {
+            my $rout = $rin;
+            while (select($rout, undef, undef, undef) == -1) {
+                die "select: $!" unless $! == EINTR; # try again immediately if select(2) was interrupted
+            }
+            read_data($rout);
+
+            my $got = substr($$buf, 0, $rlen);
+            my $n = length($got);
+            if ($got eq substr($rdata, -$rlen, $n)) {
+                $$buf = substr($$buf, $n); # consume the command
+                $rlen -= $n;
+            } else {
+                my $a = substr($rdata, 0, -$rlen) . substr($rdata, -$rlen, $n);
+                my $b = substr($rdata, 0, -$rlen) . $got;
+                s/[^\p{Graph} ]/"\\x".unpack("H*",$&)/ge foreach ($a, $b);
+                die "Wanted \"$a\", got \"$b\"";
+            }
+        }
+    }
+}
+
+package CryptrootTest::Mock;
+
+use Exporter qw/import/;
+BEGIN {
+    our @EXPORT = qw/
+        unlock_disk
+        login
+        shell
+        suspend
+        wakeup
+        hibernate
+        poweroff
+        expect
+    /;
+}
+
+*expect     = \&CryptrootTest::Utils::expect;
+*write_data = \&CryptrootTest::Utils::write_data;
+
+sub unlock_disk($) {
+    my $passphrase = shift;
+    my %r = expect($SERIAL => qr/\A(?:.*(?:\r\n|\.\.\. ))?Please unlock disk (?<name>\p{Graph}+): \z/aams);
+    if ((my $ref = ref($passphrase)) ne "") {
+        my $name = $r{name};
+        unless (defined $name) {
+            undef $passphrase;
+        } elsif ($ref eq "CODE") {
+            $passphrase = $passphrase->($name);
+        } elsif ($ref eq "HASH") {
+            $passphrase = $passphrase->{$name};
+        } else {
+            die "Unsupported reference $ref";
+        }
+    }
+    die "Unable to unlock, aborting.\n" unless defined $passphrase;
+    write_data($SERIAL => $passphrase, echo => 0, reol => "\r");
+}
+
+sub login($;$) {
+    my ($username, $password) = @_;
+    expect($CONSOLE => qr/\r\ncryptroot-[[:alnum:]._-]+ login: \z/aams);
+    write_data($CONSOLE => $username, reol => "\r");
+
+    if (defined $password) {
+        expect($CONSOLE => qr/\A[\r\n]*Password: \z/aams);
+        write_data($CONSOLE => $username, echo => 0, reol => "\r");
+    }
+
+    # consume motd(5) or similar
+    expect($CONSOLE => qr/\r\n $PS1 \z/aamsx);
+}
+
+sub shell($%);
+sub shell($%) {
+    my $command = shift;
+    my %options = @_;
+
+    write_data($CONSOLE => $command);
+    my %r = expect($CONSOLE => qr/\A (?<out>.*) $PS1 \z/aamsx);
+    my $out = $r{out};
+
+    if (exists $options{rv}) {
+        my $rv = shell(q{echo $?});
+        unless ($rv =~ s/\r?\n\z// and $rv =~ /\A[0-9]+\z/ and $rv == $options{rv}) {
+            my @loc = caller;
+            die "ERROR: Command \`$command\` exited with status $rv != $options{rv}",
+                " at line $loc[2] in $loc[1]\n";
+        }
+    }
+    return $out;
+}
+
+# enter S3 sleep state (suspend to ram aka standby)
+sub suspend() {
+    write_data($CONSOLE => q{systemctl suspend});
+    # while the command is asynchronous the system might suspend before
+    # we have a chance to read the next $PS1
+
+    # wait for the SUSPEND event
+    QMP::wait_for_event("SUSPEND");
+
+    # double check that the guest is indeed suspended
+    my $resp = QMP::command(q{query-status});
+    die unless defined $resp->{status} and  $resp->{status} eq "suspended" and
+        defined $resp->{running} and $resp->{running} == JSON::false();
+}
+
+sub wakeup() {
+    my $r = QMP::command(q{system_wakeup});
+    die if %$r;
+
+    # wait for the WAKEUP event
+    QMP::wait_for_event("WAKEUP");
+
+    # double check that the guest is indeed running
+    my $resp = QMP::command(q{query-status});
+    die unless defined $resp->{status} and  $resp->{status} eq "running" and
+        defined $resp->{running} and $resp->{running} == JSON::true();
+}
+
+# enter S4 sleep state (suspend to disk aka hibernate)
+sub hibernate() {
+    # an alternative is to send {"execute":"guest-suspend-disk"} on the
+    # guest agent socket, but we don't want to require qemu-guest-agent
+    # on the guest so this will have to do
+    write_data($CONSOLE => q{systemctl hibernate});
+    # while the command is asynchronous the system might hibernate
+    # before we have a chance to read the next $PS1
+    QMP::wait_for_event("SUSPEND_DISK");
+    expect();# wait for QEMU to terminate
+}
+
+sub poweroff() {
+    # XXX would be nice to use the QEMU monitor here but the guest
+    # doesn't seem to respond to system_powerdown QMP commands
+    write_data($CONSOLE => q{poweroff});
+    # while the command is asynchronous the system might shutdown
+    # before we have a chance to read the next $PS1
+    QMP::wait_for_event("SHUTDOWN");
+    expect(); # wait for QEMU to terminate
+}
+
+
+package QMP;
+
+# QMP protocol
+# https://qemu.readthedocs.io/en/latest/interop/qemu-qmp-ref.html
+
+use JSON ();
+
+# read and decode a QMP server line
+sub getline() {
+    my %r = CryptrootTest::Utils::expect($MONITOR => qr/\A(?<str>.+?)\r\n/m);
+    my $str = $r{str} // die;
+    return JSON::->new->decode($str);
+}
+
+# send a QMP command and optional arguments
+sub command($;$) {
+    my ($command, $arguments) = @_;
+    my $cmd = { execute => $command };
+    $cmd->{arguments} = $arguments if defined $arguments;
+
+    $cmd = JSON::->new->encode($cmd);
+    STDOUT->printflush($cmd . "\n");
+    CryptrootTest::Utils::write_data($MONITOR => $cmd, eol => "\r\n", echo => 0, reol => "");
+
+    while(1) {
+        my $resp = QMP::getline() // next;
+        # ignore unsolicited server responses (such as events)
+        return $resp->{return} if exists $resp->{return};
+    }
+}
+
+# wait for the QMP greeting line
+my @CAPABILITIES;
+sub greeting() {
+    my $greeting = QMP::getline() // die;
+    $greeting = $greeting->{QMP} // die;
+    @CAPABILITIES = @{$greeting->{capabilities}} if defined $greeting->{capabilities};
+}
+
+# negotiate QMP capabilities
+sub capabilities(@) {
+    my $r = QMP::command(qmp_capabilities => {enable => \@_});
+    die if %$r;
+}
+
+BEGIN {
+    # https://gitlab.com/qemu-project/qemu/-/blob/master/docs/interop/qmp-spec.txt sec 4
+    QMP::greeting();
+    QMP::capabilities();
+}
+
+sub wait_for_event($) {
+    my $event_name = shift;
+    while(1) {
+        my $resp = QMP::getline() // next;
+        return if exists $resp->{event} and $resp->{event} eq $event_name;
+    }
+}
+
+sub quit() {
+    # don't use QMP::command() here since we might never receive a response
+    my $cmd = JSON::->new->encode({ execute => "quit" });
+    STDOUT->printflush($cmd . "\n");
+    CryptrootTest::Utils::write_data($MONITOR => $cmd, eol => "\r\n", echo => 0, reol => "");
+    CryptrootTest::Utils::expect(); # wait for QEMU to terminate
+}
+
+1;