751 lines
17 KiB
Plaintext
751 lines
17 KiB
Plaintext
|
#!/usr/bin/env perl
|
||
|
|
use strict;
|
||
|
|
use warnings;
|
||
|
|
use feature 'say';
|
||
|
|
|
||
|
|
use Encode qw( decode_utf8 FB_CROAK );
|
||
|
|
use Getopt::Long qw( GetOptionsFromArray :config require_order );
|
||
|
|
use JSON::PP qw( encode_json );
|
||
|
|
use LWP::UserAgent;
|
||
|
|
use Pod::Usage;
|
||
|
|
|
||
|
|
=head1 NAME
|
||
|
|
|
||
|
|
B<zmb> - Shell bindings for the Zonemaster::Backend RPC API
|
||
|
|
|
||
|
|
Zmb is meant to be pronounced I<Zimba>.
|
||
|
|
|
||
|
|
=head1 SYNOPSIS
|
||
|
|
|
||
|
|
zmb [GLOBAL OPTIONS] COMMAND [OPTIONS]
|
||
|
|
|
||
|
|
=head1 GLOBAL OPTIONS
|
||
|
|
|
||
|
|
--help Show usage
|
||
|
|
--verbose Show RPC query
|
||
|
|
--server URL The server to connect to. Default is http://localhost:5000/.
|
||
|
|
|
||
|
|
=cut
|
||
|
|
|
||
|
|
sub main {
|
||
|
|
my @argv = @_;
|
||
|
|
|
||
|
|
@argv = map { decode_utf8( $_, FB_CROAK ) } @argv;
|
||
|
|
|
||
|
|
my $opt_help;
|
||
|
|
my $opt_verbose;
|
||
|
|
my $opt_server = 'http://localhost:5000/';
|
||
|
|
GetOptionsFromArray(
|
||
|
|
\@argv,
|
||
|
|
'help' => \$opt_help,
|
||
|
|
'verbose' => \$opt_verbose,
|
||
|
|
'server=s' => \$opt_server,
|
||
|
|
) or pod2usage( 2 );
|
||
|
|
if ( !@argv ) {
|
||
|
|
pod2usage( -verbose => 99, -sections => ['SYNOPSIS', 'GLOBAL OPTIONS'], -exitval => 'NOEXIT' );
|
||
|
|
show_commands();
|
||
|
|
exit 1;
|
||
|
|
}
|
||
|
|
my $cmd = shift @argv;
|
||
|
|
pod2usage( 1 ) if !defined $cmd;
|
||
|
|
my $cmd_sub = \&{ "cmd_" . $cmd };
|
||
|
|
pod2usage( "'$cmd' is not a command" ) if !defined &$cmd_sub;
|
||
|
|
pod2usage( -verbose => 99, -sections => ["COMMANDS/$cmd"] ) if $opt_help;
|
||
|
|
|
||
|
|
my $json = &$cmd_sub( @argv );
|
||
|
|
|
||
|
|
if ( $json ) {
|
||
|
|
say $json if $opt_verbose;
|
||
|
|
my $request = to_request( $opt_server, $json );
|
||
|
|
my $response = submit( $request );
|
||
|
|
say $response;
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
|
||
|
|
=head1 COMMANDS
|
||
|
|
|
||
|
|
=head2 man
|
||
|
|
|
||
|
|
Show the full manual page.
|
||
|
|
|
||
|
|
zmb [GLOBAL OPTIONS] man
|
||
|
|
|
||
|
|
=cut
|
||
|
|
|
||
|
|
sub cmd_man {
|
||
|
|
pod2usage( -verbose => 2 );
|
||
|
|
}
|
||
|
|
|
||
|
|
|
||
|
|
=head2 non_existing_method
|
||
|
|
|
||
|
|
Call a non-existing RPC method.
|
||
|
|
|
||
|
|
zmb [GLOBAL OPTIONS] non_existing_method
|
||
|
|
|
||
|
|
=cut
|
||
|
|
|
||
|
|
sub cmd_non_existing_method {
|
||
|
|
return to_jsonrpc(
|
||
|
|
id => 1,
|
||
|
|
method => 'non_existing_method',
|
||
|
|
);
|
||
|
|
}
|
||
|
|
|
||
|
|
|
||
|
|
=head2 version_info
|
||
|
|
|
||
|
|
zmb [GLOBAL OPTIONS] version_info
|
||
|
|
|
||
|
|
=cut
|
||
|
|
|
||
|
|
sub cmd_version_info {
|
||
|
|
return to_jsonrpc(
|
||
|
|
id => 1,
|
||
|
|
method => 'version_info',
|
||
|
|
);
|
||
|
|
}
|
||
|
|
|
||
|
|
|
||
|
|
=head2 profile_names
|
||
|
|
|
||
|
|
zmb [GLOBAL OPTIONS] profile_names
|
||
|
|
|
||
|
|
=cut
|
||
|
|
|
||
|
|
sub cmd_profile_names {
|
||
|
|
return to_jsonrpc(
|
||
|
|
id => 1,
|
||
|
|
method => 'profile_names',
|
||
|
|
);
|
||
|
|
}
|
||
|
|
|
||
|
|
|
||
|
|
=head2 get_language_tags
|
||
|
|
|
||
|
|
zmb [GLOBAL OPTIONS] get_language_tags
|
||
|
|
|
||
|
|
=cut
|
||
|
|
|
||
|
|
sub cmd_get_language_tags {
|
||
|
|
return to_jsonrpc(
|
||
|
|
id => 1,
|
||
|
|
method => 'get_language_tags',
|
||
|
|
);
|
||
|
|
}
|
||
|
|
|
||
|
|
|
||
|
|
=head2 start_domain_test
|
||
|
|
|
||
|
|
zmb [GLOBAL OPTIONS] start_domain_test [OPTIONS]
|
||
|
|
|
||
|
|
Options:
|
||
|
|
|
||
|
|
--domain DOMAIN_NAME
|
||
|
|
--ipv4 true|false|null
|
||
|
|
--ipv6 true|false|null
|
||
|
|
--nameserver DOMAIN_NAME:IP_ADDRESS
|
||
|
|
--nameserver DOMAIN_NAME # Trailing colon is optional when not specifing IP_ADDRESS
|
||
|
|
--ds-info DS_INFO
|
||
|
|
--client-id CLIENT_ID
|
||
|
|
--client-version CLIENT_VERSION
|
||
|
|
--profile PROFILE_NAME
|
||
|
|
--queue QUEUE
|
||
|
|
--language LANGUAGE
|
||
|
|
|
||
|
|
DS_INFO is a comma separated list of key-value pairs. The expected pairs are:
|
||
|
|
|
||
|
|
keytag=NON_NEGATIVE_INTEGER
|
||
|
|
algorithm=NON_NEGATIVE_INTEGER
|
||
|
|
digtype=NON_NEGATIVE_INTEGER
|
||
|
|
digest=HEX_STRING
|
||
|
|
|
||
|
|
=cut
|
||
|
|
|
||
|
|
sub cmd_start_domain_test {
|
||
|
|
my @opts = @_;
|
||
|
|
|
||
|
|
my @opt_nameserver;
|
||
|
|
my $opt_domain;
|
||
|
|
my $opt_client_id;
|
||
|
|
my $opt_client_version;
|
||
|
|
my @opt_ds_info;
|
||
|
|
my $opt_ipv4;
|
||
|
|
my $opt_ipv6;
|
||
|
|
my $opt_profile;
|
||
|
|
my $opt_queue;
|
||
|
|
my $opt_language;
|
||
|
|
GetOptionsFromArray(
|
||
|
|
\@opts,
|
||
|
|
'domain|d=s' => \$opt_domain,
|
||
|
|
'nameserver|n=s' => \@opt_nameserver,
|
||
|
|
'client-id=s' => \$opt_client_id,
|
||
|
|
'client-version=s' => \$opt_client_version,
|
||
|
|
'ds-info=s' => \@opt_ds_info,
|
||
|
|
'ipv4=s' => \$opt_ipv4,
|
||
|
|
'ipv6=s' => \$opt_ipv6,
|
||
|
|
'profile=s' => \$opt_profile,
|
||
|
|
'queue=s' => \$opt_queue,
|
||
|
|
'language=s' => \$opt_language,
|
||
|
|
) or pod2usage( 2 );
|
||
|
|
|
||
|
|
my %params = ( domain => $opt_domain, );
|
||
|
|
|
||
|
|
if ( $opt_client_id ) {
|
||
|
|
$params{client_id} = $opt_client_id;
|
||
|
|
}
|
||
|
|
|
||
|
|
if ( $opt_client_version ) {
|
||
|
|
$params{client_version} = $opt_client_version;
|
||
|
|
}
|
||
|
|
|
||
|
|
if ( @opt_ds_info ) {
|
||
|
|
my @info_objects;
|
||
|
|
for my $property_value_pairs ( @opt_ds_info ) {
|
||
|
|
my %info_object;
|
||
|
|
for my $pair ( split /,/, $property_value_pairs ) {
|
||
|
|
my ( $property, $value ) = split /=/, $pair;
|
||
|
|
if ( $property =~ /^(?:keytag|algorithm|digtype)$/ ) {
|
||
|
|
$value = 0 + $value;
|
||
|
|
}
|
||
|
|
$info_object{$property} = $value;
|
||
|
|
}
|
||
|
|
push @info_objects, \%info_object;
|
||
|
|
}
|
||
|
|
$params{ds_info} = \@info_objects;
|
||
|
|
}
|
||
|
|
|
||
|
|
if ( @opt_nameserver ) {
|
||
|
|
my @nameserver_objects;
|
||
|
|
for my $domain_ip_pair ( @opt_nameserver ) {
|
||
|
|
my ( $domain, $ip ) = split /:/, $domain_ip_pair, 2;
|
||
|
|
if ($ip) {
|
||
|
|
push @nameserver_objects, { ns => $domain, ip => $ip };
|
||
|
|
} else {
|
||
|
|
push @nameserver_objects, { ns => $domain };
|
||
|
|
}
|
||
|
|
}
|
||
|
|
$params{nameservers} = \@nameserver_objects;
|
||
|
|
}
|
||
|
|
|
||
|
|
if ( $opt_ipv4 ) {
|
||
|
|
$params{ipv4} = json_tern( $opt_ipv4 );
|
||
|
|
}
|
||
|
|
|
||
|
|
if ( $opt_ipv6 ) {
|
||
|
|
$params{ipv6} = json_tern( $opt_ipv6 );
|
||
|
|
}
|
||
|
|
|
||
|
|
if ( $opt_profile ) {
|
||
|
|
$params{profile} = $opt_profile;
|
||
|
|
}
|
||
|
|
|
||
|
|
if ( $opt_queue ) {
|
||
|
|
$params{queue} = $opt_queue;
|
||
|
|
}
|
||
|
|
|
||
|
|
if ( $opt_language ) {
|
||
|
|
$params{language} = $opt_language;
|
||
|
|
}
|
||
|
|
|
||
|
|
return to_jsonrpc(
|
||
|
|
id => 1,
|
||
|
|
method => 'start_domain_test',
|
||
|
|
params => \%params,
|
||
|
|
);
|
||
|
|
}
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
=head2 test_progress
|
||
|
|
|
||
|
|
zmb [GLOBAL OPTIONS] test_progress [OPTIONS]
|
||
|
|
|
||
|
|
Options:
|
||
|
|
--test-id TEST_ID
|
||
|
|
|
||
|
|
=cut
|
||
|
|
|
||
|
|
sub cmd_test_progress {
|
||
|
|
my @opts = @_;
|
||
|
|
|
||
|
|
my $opt_test_id;
|
||
|
|
GetOptionsFromArray(
|
||
|
|
\@opts,
|
||
|
|
'test-id|t=s' => \$opt_test_id,
|
||
|
|
) or pod2usage( 2 );
|
||
|
|
|
||
|
|
return to_jsonrpc(
|
||
|
|
id => 1,
|
||
|
|
method => 'test_progress',
|
||
|
|
params => {
|
||
|
|
test_id => $opt_test_id,
|
||
|
|
},
|
||
|
|
);
|
||
|
|
}
|
||
|
|
|
||
|
|
|
||
|
|
=head2 get_test_params
|
||
|
|
|
||
|
|
zmb [GLOBAL OPTIONS] get_test_params [OPTIONS]
|
||
|
|
|
||
|
|
Options:
|
||
|
|
--test-id TEST_ID
|
||
|
|
|
||
|
|
=cut
|
||
|
|
|
||
|
|
sub cmd_get_test_params {
|
||
|
|
my @opts = @_;
|
||
|
|
|
||
|
|
my $opt_test_id;
|
||
|
|
GetOptionsFromArray( #
|
||
|
|
\@opts,
|
||
|
|
'test-id|t=s' => \$opt_test_id,
|
||
|
|
) or pod2usage( 2 );
|
||
|
|
|
||
|
|
return to_jsonrpc(
|
||
|
|
id => 1,
|
||
|
|
method => 'get_test_params',
|
||
|
|
params => {
|
||
|
|
test_id => $opt_test_id,
|
||
|
|
},
|
||
|
|
);
|
||
|
|
}
|
||
|
|
|
||
|
|
|
||
|
|
=head2 get_test_results
|
||
|
|
|
||
|
|
zmb [GLOBAL OPTIONS] get_test_results [OPTIONS]
|
||
|
|
|
||
|
|
Options:
|
||
|
|
--test-id TEST_ID
|
||
|
|
--lang LANGUAGE
|
||
|
|
|
||
|
|
=cut
|
||
|
|
|
||
|
|
sub cmd_get_test_results {
|
||
|
|
my @opts = @_;
|
||
|
|
|
||
|
|
my $opt_lang;
|
||
|
|
my $opt_test_id;
|
||
|
|
GetOptionsFromArray(
|
||
|
|
\@opts,
|
||
|
|
'test-id|t=s' => \$opt_test_id,
|
||
|
|
'lang|l=s' => \$opt_lang,
|
||
|
|
) or pod2usage( 2 );
|
||
|
|
|
||
|
|
return to_jsonrpc(
|
||
|
|
id => 1,
|
||
|
|
method => 'get_test_results',
|
||
|
|
params => {
|
||
|
|
id => $opt_test_id,
|
||
|
|
language => $opt_lang,
|
||
|
|
},
|
||
|
|
);
|
||
|
|
}
|
||
|
|
|
||
|
|
|
||
|
|
=head2 get_test_history
|
||
|
|
|
||
|
|
zmb [GLOBAL OPTIONS] get_test_history [OPTIONS]
|
||
|
|
|
||
|
|
Options:
|
||
|
|
--domain DOMAIN_NAME
|
||
|
|
--filter all|delegated|undelegated
|
||
|
|
--offset COUNT
|
||
|
|
--limit COUNT
|
||
|
|
|
||
|
|
=cut
|
||
|
|
|
||
|
|
sub cmd_get_test_history {
|
||
|
|
my @opts = @_;
|
||
|
|
my $opt_filter;
|
||
|
|
my $opt_domain;
|
||
|
|
my $opt_offset;
|
||
|
|
my $opt_limit;
|
||
|
|
|
||
|
|
GetOptionsFromArray(
|
||
|
|
\@opts,
|
||
|
|
'domain|d=s' => \$opt_domain,
|
||
|
|
'filter|n=s' => \$opt_filter,
|
||
|
|
'offset|o=i' => \$opt_offset,
|
||
|
|
'limit|l=i' => \$opt_limit,
|
||
|
|
) or pod2usage( 2 );
|
||
|
|
|
||
|
|
my %params = (
|
||
|
|
frontend_params => {
|
||
|
|
domain => $opt_domain,
|
||
|
|
},
|
||
|
|
);
|
||
|
|
|
||
|
|
if ( $opt_filter ) {
|
||
|
|
unless ( $opt_filter =~ /^(?:all|delegated|undelegated)$/ ) {
|
||
|
|
die 'Illegal filter value. Expects "all", "delegated" or "undelegated" ';
|
||
|
|
}
|
||
|
|
$params{filter} = $opt_filter;
|
||
|
|
}
|
||
|
|
|
||
|
|
if ( defined $opt_offset ) {
|
||
|
|
$params{offset} = $opt_offset;
|
||
|
|
}
|
||
|
|
|
||
|
|
if ( defined $opt_limit ) {
|
||
|
|
$params{limit} = $opt_limit;
|
||
|
|
}
|
||
|
|
|
||
|
|
return to_jsonrpc(
|
||
|
|
id => 1,
|
||
|
|
method => 'get_test_history',
|
||
|
|
params => \%params,
|
||
|
|
);
|
||
|
|
}
|
||
|
|
|
||
|
|
|
||
|
|
=head2 add_api_user
|
||
|
|
|
||
|
|
zmb [GLOBAL OPTIONS] add_api_user [OPTIONS]
|
||
|
|
|
||
|
|
Options:
|
||
|
|
--username USERNAME
|
||
|
|
--api-key API_KEY
|
||
|
|
|
||
|
|
=cut
|
||
|
|
|
||
|
|
sub cmd_add_api_user {
|
||
|
|
my @opts = @_;
|
||
|
|
|
||
|
|
my $opt_username;
|
||
|
|
my $opt_api_key;
|
||
|
|
GetOptionsFromArray(
|
||
|
|
\@opts,
|
||
|
|
'username|u=s' => \$opt_username,
|
||
|
|
'api-key|a=s' => \$opt_api_key,
|
||
|
|
) or pod2usage( 2 );
|
||
|
|
|
||
|
|
return to_jsonrpc(
|
||
|
|
id => 1,
|
||
|
|
method => 'add_api_user',
|
||
|
|
params => {
|
||
|
|
username => $opt_username,
|
||
|
|
api_key => $opt_api_key,
|
||
|
|
},
|
||
|
|
);
|
||
|
|
}
|
||
|
|
|
||
|
|
|
||
|
|
=head2 add_batch_job
|
||
|
|
|
||
|
|
zmb [GLOBAL OPTIONS] add_batch_job [OPTIONS]
|
||
|
|
|
||
|
|
Options:
|
||
|
|
--username USERNAME
|
||
|
|
--api-key API_KEY
|
||
|
|
--domain DOMAIN_NAME
|
||
|
|
--ipv4 true|false|null
|
||
|
|
--ipv6 true|false|null
|
||
|
|
--nameserver DOMAIN_NAME:IP_ADDRESS
|
||
|
|
--nameserver DOMAIN_NAME # Trailing colon is optional when not specifing IP_ADDRESS
|
||
|
|
--ds-info DS_INFO
|
||
|
|
--client-id CLIENT_ID
|
||
|
|
--client-version CLIENT_VERSION
|
||
|
|
--profile PROFILE_NAME
|
||
|
|
--queue QUEUE
|
||
|
|
--file FILENAME
|
||
|
|
|
||
|
|
"--domain" is repeated for each domain to be tested.
|
||
|
|
"--nameserver" can be repeated for each name server.
|
||
|
|
"--ds-info" can be repeated for each DS record.
|
||
|
|
|
||
|
|
"--file" points at a file with a list of domain names
|
||
|
|
to test, one name per line. Lines starting with "#",
|
||
|
|
empty lines and lines with white space only are
|
||
|
|
ignored. Trailing white space is ignored.
|
||
|
|
|
||
|
|
"--file" and "--domain" can be combined. Domains specified
|
||
|
|
by any "--domain" are added before those specified in the
|
||
|
|
file, if any.
|
||
|
|
|
||
|
|
DS_INFO is a comma separated list of key-value pairs. The expected pairs are:
|
||
|
|
|
||
|
|
keytag=NON_NEGATIVE_INTEGER
|
||
|
|
algorithm=NON_NEGATIVE_INTEGER
|
||
|
|
digtype=NON_NEGATIVE_INTEGER
|
||
|
|
digest=HEX_STRING
|
||
|
|
|
||
|
|
=cut
|
||
|
|
|
||
|
|
sub cmd_add_batch_job {
|
||
|
|
my @opts = @_;
|
||
|
|
|
||
|
|
my $opt_username;
|
||
|
|
my $opt_api_key;
|
||
|
|
my @opt_nameserver;
|
||
|
|
my @opt_domains;
|
||
|
|
my $opt_file;
|
||
|
|
my $opt_client_id;
|
||
|
|
my $opt_client_version;
|
||
|
|
my @opt_ds_info;
|
||
|
|
my $opt_ipv4;
|
||
|
|
my $opt_ipv6;
|
||
|
|
my $opt_profile;
|
||
|
|
my $opt_queue;
|
||
|
|
GetOptionsFromArray(
|
||
|
|
\@opts,
|
||
|
|
'username|u=s' => \$opt_username,
|
||
|
|
'api-key|a=s' => \$opt_api_key,
|
||
|
|
'domain|d=s' => \@opt_domains,
|
||
|
|
'nameserver|n=s' => \@opt_nameserver,
|
||
|
|
'client-id=s' => \$opt_client_id,
|
||
|
|
'client-version=s' => \$opt_client_version,
|
||
|
|
'ds-info=s' => \@opt_ds_info,
|
||
|
|
'ipv4=s' => \$opt_ipv4,
|
||
|
|
'ipv6=s' => \$opt_ipv6,
|
||
|
|
'profile=s' => \$opt_profile,
|
||
|
|
'queue=s' => \$opt_queue,
|
||
|
|
'file=s' => \$opt_file,
|
||
|
|
) or pod2usage( 2 );
|
||
|
|
|
||
|
|
if ($opt_file) {
|
||
|
|
open( my $fh, "<", $opt_file ) or die "Can't open < $opt_file: $!";
|
||
|
|
while( <$fh> ) {
|
||
|
|
chomp;
|
||
|
|
s/\s+$//;
|
||
|
|
s/^\s+//;
|
||
|
|
next if /^#/ or /^$/;
|
||
|
|
push( @opt_domains, decode_utf8( $_ ) );
|
||
|
|
};
|
||
|
|
};
|
||
|
|
|
||
|
|
my %params = ( domains => \@opt_domains );
|
||
|
|
|
||
|
|
$params{username} = $opt_username;
|
||
|
|
$params{api_key} = $opt_api_key;
|
||
|
|
|
||
|
|
if ( $opt_client_id ) {
|
||
|
|
$params{test_params}{client_id} = $opt_client_id;
|
||
|
|
}
|
||
|
|
|
||
|
|
if ( $opt_client_version ) {
|
||
|
|
$params{test_params}{client_version} = $opt_client_version;
|
||
|
|
}
|
||
|
|
|
||
|
|
if ( @opt_ds_info ) {
|
||
|
|
my @info_objects;
|
||
|
|
for my $property_value_pairs ( @opt_ds_info ) {
|
||
|
|
my %info_object;
|
||
|
|
for my $pair ( split /,/, $property_value_pairs ) {
|
||
|
|
my ( $property, $value ) = split /=/, $pair;
|
||
|
|
if ( $property =~ /^(?:keytag|algorithm|digtype)$/ ) {
|
||
|
|
$value = 0 + $value;
|
||
|
|
}
|
||
|
|
$info_object{$property} = $value;
|
||
|
|
}
|
||
|
|
push @info_objects, \%info_object;
|
||
|
|
}
|
||
|
|
$params{test_params}{ds_info} = \@info_objects;
|
||
|
|
}
|
||
|
|
|
||
|
|
if ( @opt_nameserver ) {
|
||
|
|
my @nameserver_objects;
|
||
|
|
for my $domain_ip_pair ( @opt_nameserver ) {
|
||
|
|
my ( $domain, $ip ) = split /:/, $domain_ip_pair, 2;
|
||
|
|
$ip //= "";
|
||
|
|
push @nameserver_objects,
|
||
|
|
{
|
||
|
|
ns => $domain,
|
||
|
|
ip => $ip,
|
||
|
|
};
|
||
|
|
}
|
||
|
|
$params{test_params}{nameservers} = \@nameserver_objects;
|
||
|
|
}
|
||
|
|
|
||
|
|
if ( $opt_ipv4 ) {
|
||
|
|
$params{test_params}{ipv4} = json_tern( $opt_ipv4 );
|
||
|
|
}
|
||
|
|
|
||
|
|
if ( $opt_ipv6 ) {
|
||
|
|
$params{test_params}{ipv6} = json_tern( $opt_ipv6 );
|
||
|
|
}
|
||
|
|
|
||
|
|
if ( $opt_profile ) {
|
||
|
|
$params{test_params}{profile} = $opt_profile;
|
||
|
|
}
|
||
|
|
|
||
|
|
if ( $opt_queue ) {
|
||
|
|
$params{test_params}{queue} = $opt_queue;
|
||
|
|
}
|
||
|
|
|
||
|
|
return to_jsonrpc(
|
||
|
|
id => 1,
|
||
|
|
method => 'add_batch_job',
|
||
|
|
params => \%params,
|
||
|
|
);
|
||
|
|
}
|
||
|
|
|
||
|
|
=head2 batch_status
|
||
|
|
|
||
|
|
zmb [GLOBAL OPTIONS] batch_status [OPTIONS]
|
||
|
|
|
||
|
|
Options:
|
||
|
|
--batch-id BATCH-ID|--bi BATCH-ID
|
||
|
|
--list-waiting-tests true|false|null
|
||
|
|
--list-running-tests true|false|null
|
||
|
|
--list-finished-tests true|false|null
|
||
|
|
|
||
|
|
--lw # Same as "--list-waiting-tests true"
|
||
|
|
--lr # Same as "--list-running-tests true"
|
||
|
|
--lf # Same as "--list-finished-tests true"
|
||
|
|
|
||
|
|
"--batch-id" is mandatory.
|
||
|
|
|
||
|
|
The command provides the number of tests waiting to be run, tests running and
|
||
|
|
test finished, respectively, for the batch.
|
||
|
|
|
||
|
|
"--list-waiting-tests", "--list-running-tests" and "--list-finished-tests" are
|
||
|
|
optional. If given the test IDs of tests waiting to be run, tests running
|
||
|
|
and test finished, respectively, are listed.
|
||
|
|
|
||
|
|
"--lw", "--lr" and "--lf" are option.
|
||
|
|
|
||
|
|
"--lw" must not be combined with "--list-waiting-tests". "--lr" must not be
|
||
|
|
combined with "--list-running-tests". "--lf" must not be combined with
|
||
|
|
"--list-finished-tests".
|
||
|
|
=cut
|
||
|
|
|
||
|
|
sub cmd_batch_status {
|
||
|
|
my @opts = @_;
|
||
|
|
|
||
|
|
my $opt_batch_id;
|
||
|
|
my $opt_list_waiting_tests;
|
||
|
|
my $opt_lw;
|
||
|
|
my $opt_list_running_tests;
|
||
|
|
my $opt_lr;
|
||
|
|
my $opt_list_finished_tests;
|
||
|
|
my $opt_lf;
|
||
|
|
|
||
|
|
GetOptionsFromArray(
|
||
|
|
\@opts,
|
||
|
|
'batch-id|bi=s' => \$opt_batch_id,
|
||
|
|
'list-waiting-tests=s' => \$opt_list_waiting_tests,
|
||
|
|
'lw' => \$opt_lw,
|
||
|
|
'list-running-tests=s' => \$opt_list_running_tests,
|
||
|
|
'lr' => \$opt_lr,
|
||
|
|
'list-finished-tests=s' => \$opt_list_finished_tests,
|
||
|
|
'lf' => \$opt_lf,
|
||
|
|
) or pod2usage( 2 );
|
||
|
|
|
||
|
|
pod2usage( "'--lw' and '--list-waiting-test' must not be combined" ) if defined $opt_list_waiting_tests and $opt_lw;
|
||
|
|
pod2usage( "'--lr' and '--list-running-test' must not be combined" ) if defined $opt_list_running_tests and $opt_lr;
|
||
|
|
pod2usage( "'--lf' and '--list-finished-test' must not be combined" ) if defined $opt_list_finished_tests and $opt_lf;
|
||
|
|
|
||
|
|
my %params;
|
||
|
|
$params{batch_id} = $opt_batch_id;
|
||
|
|
$params{list_waiting_tests} = json_tern( $opt_list_waiting_tests ) if $opt_list_waiting_tests and json_tern( $opt_list_waiting_tests );
|
||
|
|
$params{list_running_tests} = json_tern( $opt_list_running_tests ) if $opt_list_running_tests and json_tern( $opt_list_running_tests );
|
||
|
|
$params{list_finished_tests} = json_tern( $opt_list_finished_tests ) if $opt_list_finished_tests and json_tern( $opt_list_finished_tests );
|
||
|
|
|
||
|
|
$params{list_waiting_tests} = JSON::PP::true if $opt_lw;
|
||
|
|
$params{list_running_tests} = JSON::PP::true if $opt_lr;
|
||
|
|
$params{list_finished_tests} = JSON::PP::true if $opt_lf;
|
||
|
|
|
||
|
|
return to_jsonrpc(
|
||
|
|
id => 1,
|
||
|
|
method => 'batch_status',
|
||
|
|
params => \%params,
|
||
|
|
);
|
||
|
|
}
|
||
|
|
|
||
|
|
|
||
|
|
sub show_commands {
|
||
|
|
my %specials = (
|
||
|
|
man => 'Show the full manual page.',
|
||
|
|
non_existing_method => 'Call a non-existing RPC method.',
|
||
|
|
);
|
||
|
|
my @commands = get_commands();
|
||
|
|
my $max_width = 0;
|
||
|
|
for my $command ( @commands ) {
|
||
|
|
$max_width = length $command if length $command > $max_width;
|
||
|
|
}
|
||
|
|
say "Commands:";
|
||
|
|
for my $command ( @commands ) {
|
||
|
|
if ( exists $specials{$command} ) {
|
||
|
|
printf " %-*s %s\n", $max_width, $command, $specials{$command};
|
||
|
|
}
|
||
|
|
else {
|
||
|
|
say " ", $command;
|
||
|
|
}
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
|
||
|
|
sub get_commands {
|
||
|
|
no strict 'refs';
|
||
|
|
|
||
|
|
return sort
|
||
|
|
map { $_ =~ s/^cmd_//r }
|
||
|
|
grep { $_ =~ /^cmd_/ } grep { defined &{"main\::$_"} } keys %{"main\::"};
|
||
|
|
}
|
||
|
|
|
||
|
|
|
||
|
|
sub json_tern {
|
||
|
|
my $value = shift;
|
||
|
|
|
||
|
|
if ( $value eq 'true' ) {
|
||
|
|
return JSON::PP::true;
|
||
|
|
}
|
||
|
|
elsif ( $value eq 'false' ) {
|
||
|
|
return JSON::PP::false;
|
||
|
|
}
|
||
|
|
elsif ( $value eq 'null' ) {
|
||
|
|
return undef;
|
||
|
|
}
|
||
|
|
else {
|
||
|
|
die 'Illegal value. Expects "true", "false" or "null" ';
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
sub to_jsonrpc {
|
||
|
|
my %args = @_;
|
||
|
|
my $id = $args{id};
|
||
|
|
my $method = $args{method};
|
||
|
|
|
||
|
|
my $request = {
|
||
|
|
jsonrpc => "2.0",
|
||
|
|
method => $method,
|
||
|
|
id => $id,
|
||
|
|
};
|
||
|
|
if ( exists $args{params} ) {
|
||
|
|
$request->{params} = $args{params};
|
||
|
|
}
|
||
|
|
return encode_json( $request );
|
||
|
|
}
|
||
|
|
|
||
|
|
sub to_request {
|
||
|
|
my $server = shift;
|
||
|
|
my $json = shift;
|
||
|
|
|
||
|
|
my $req = HTTP::Request->new( POST => $server );
|
||
|
|
$req->content_type( 'application/json' );
|
||
|
|
$req->content( $json );
|
||
|
|
|
||
|
|
return $req;
|
||
|
|
}
|
||
|
|
|
||
|
|
sub submit {
|
||
|
|
my $req = shift;
|
||
|
|
|
||
|
|
my $ua = LWP::UserAgent->new;
|
||
|
|
my $res = $ua->request( $req );
|
||
|
|
|
||
|
|
if ( $res->is_success ) {
|
||
|
|
return $res->decoded_content;
|
||
|
|
}
|
||
|
|
else {
|
||
|
|
die $res->status_line;
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
main( @ARGV );
|