#!/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 );