—
—
—
—
—
—
—
—
—
—
—
—
—

              
package Zonemaster::Backend::Validator;
our $VERSION = '0.1.0';
use strict;
use warnings;
use 5.14.2;
use Exporter qw( import );
use File::Spec::Functions qw( file_name_is_absolute );
use JSON::Validator::Joi;
use Readonly;
use Locale::TextDomain qw[Zonemaster-Backend];
use Net::IP::XS;
use Zonemaster::Engine::Logger::Entry;
use Zonemaster::Engine::Normalization;
use Zonemaster::LDNS;
our @EXPORT_OK = qw(
  untaint_abs_path
  untaint_bool
  untaint_engine_type
  untaint_ip_address
  untaint_ipv4_address
  untaint_ipv6_address
  untaint_host
  untaint_ldh_domain
  untaint_locale_tag
  untaint_mariadb_database
  untaint_mariadb_user
  untaint_non_negative_int
  untaint_password
  untaint_postgresql_ident
  untaint_profile_name
  untaint_strictly_positive_int
  untaint_strictly_positive_millis
  check_domain
  check_ip
  check_profile
  check_language_tag
);
our %EXPORT_TAGS = (
    untaint => [
        qw(
          untaint_abs_path
          untaint_bool
          untaint_engine_type
          untaint_ip_address
          untaint_ipv4_address
          untaint_ipv6_address
          untaint_host
          untaint_ldh_domain
          untaint_locale_tag
          untaint_mariadb_database
          untaint_mariadb_user
          untaint_non_negative_int
          untaint_password
          untaint_postgresql_ident
          untaint_profile_name
          untaint_strictly_positive_int
          untaint_strictly_positive_millis
          )
    ],
    format => [
        qw(
            check_domain
            check_ip
            check_profile
            check_language_tag
        )
    ]
);
# Does not check value ranges within the groups
Readonly my $IPV4_RE => qr/^[0-9]{1,3}\.[0-9]{1,3}\.[0-9]{1,3}\.[0-9]{1,3}$/;
# Does not check the length and number of the hex groups, nor the value ranges in the IPv4 groups
Readonly my $IPV6_RE => qr/^[0-9a-f:]*:[0-9a-f:]+(:[0-9]{1,3}\.[0-9]{1,3}\.[0-9]{1,3}\.[0-9]{1,3})?$/i;
Readonly my $API_KEY_RE                 => qr/^[a-z0-9-_]{1,512}$/i;
Readonly my $CLIENT_ID_RE               => qr/^[a-z0-9-+~_.: ]{1,50}$/i;
Readonly my $CLIENT_VERSION_RE          => qr/^[a-z0-9-+~_.: ]{1,50}$/i;
Readonly my $DIGEST_RE                  => qr/^[a-f0-9]{40}$|^[a-f0-9]{64}$|^[a-f0-9]{96}$/i;
Readonly my $ENGINE_TYPE_RE             => qr/^(?:mysql|postgresql|sqlite)$/i;
Readonly my $IPADDR_RE                  => qr/^$|$IPV4_RE|$IPV6_RE/;
Readonly my $JSONRPC_METHOD_RE          => qr/^[a-z0-9_-]*$/i;
Readonly my $LANGUAGE_RE                => qr/^[a-z]{2}$/;
Readonly my $LDH_DOMAIN_RE1             => qr{^[a-z0-9_./-]{1,253}[.]?$}i;
Readonly my $LDH_DOMAIN_RE2             => qr{^(?:[.]|[^.]{1,63}(?:[.][^.]{1,63})*[.]?)$};
Readonly my $LOCALE_TAG_RE              => qr/^[a-z]{2}_[A-Z]{2}$/;
Readonly my $MARIADB_DATABASE_LENGTH_RE => qr/^.{1,64}$/;
# See: https://mariadb.com/kb/en/identifier-names/#unquoted
Readonly my $MARIADB_IDENT_RE       => qr/^[0-9a-z\$_]+$/i;
Readonly my $MARIADB_USER_LENGTH_RE => qr/^.{1,80}$/u;
# Up to 5 and 3 digits in the integer and fraction components respectively
Readonly my $MILLIS_RE => qr/^(?:0|[1-9][0-9]{0,4})(?:[.][0-9]{1,3})?$/;
# Up to 5 digits
Readonly my $NON_NEGATIVE_INT_RE => qr/^(?:0|[1-9][0-9]{0,4})$/;
# At least one non-zero digit
Readonly my $NON_ZERO_NUM_RE => qr/[1-9]/;
# Printable ASCII but first character must not be space or '<'
Readonly my $PASSWORD_RE => qr/^(?:[\x21-\x3b\x3d-\x7e][\x20-\x7e]{0,99})?$/;
# See: https://www.postgresql.org/docs/current/sql-syntax-lexical.html#SQL-SYNTAX-IDENTIFIERS
Readonly my $POSTGRESQL_IDENT_RE    => qr/^[a-z_][a-z0-9_\$]{0,62}$/i;
Readonly my $PROFILE_NAME_RE        => qr/^[a-z0-9]$|^[a-z0-9][a-z0-9_-]{0,30}[a-z0-9]$/i;
Readonly my $RELAXED_DOMAIN_NAME_RE => qr/^[.]$|^.{2,254}$/;
Readonly my $TEST_ID_RE             => qr/^[0-9a-f]{16}$/;
Readonly my $USERNAME_RE            => qr/^[a-z0-9-.@]{1,50}$/i;
# Boolean
Readonly my $BOOL_TRUE_RE           => qr/^(true|yes)$/i;
Readonly my $BOOL_FALSE_RE          => qr/^(false|no)$/i;
Readonly my $BOOL_RE                => qr/^$BOOL_TRUE_RE|$BOOL_FALSE_RE$/i;
sub joi {
    return JSON::Validator::Joi->new;
}
sub new {
    my ( $type ) = @_;
    my $self = {};
    bless( $self, $type );
    return ( $self );
}
sub api_key {
    return joi->string->regex( $API_KEY_RE );
}
sub batch_id {
    return joi->integer->positive;
}
sub client_id {
    return joi->string->regex( $CLIENT_ID_RE );
}
sub client_version {
    return joi->string->regex( $CLIENT_VERSION_RE );
}
sub domain_name {
    return {
        type => 'string',
        format => 'domain',
    };
}
sub ds_info {
    return {
        type => 'object',
        additionalProperties => 0,
        required => [ 'digest', 'algorithm', 'digtype', 'keytag' ],
        properties => {
            digest => {
                type => 'string',
                pattern => $DIGEST_RE,
                'x-error-message' => N__ 'Invalid digest format'
            },
            algorithm => {
                type => 'number',
                minimum => 0,
                'x-error-message' => N__ 'Algorithm must be a positive integer'
            },
            digtype => {
                type => 'number',
                minimum => 0,
                'x-error-message' => N__ 'Digest type must be a positive integer'
            },
            keytag => {
                type => 'number',
                minimum => 0,
                'x-error-message' => N__ 'Keytag must be a positive integer'
            }
        }
    };
}
sub ip_address {
    return {
        type => 'string',
        format => 'ip',
    };
}
sub nameserver {
    return {
        type => 'object',
        required => [ 'ns' ],
        additionalProperties => 0,
        properties => {
            ns => domain_name,
            ip => ip_address
        }
    };
}
sub priority {
    return joi->integer;
}
sub profile_name {
    return {
        type => 'string',
        format => 'profile',
    };
}
sub queue {
    return joi->integer;
}
sub test_id {
    return joi->string->regex( $TEST_ID_RE );
}
sub language_tag {
    return {
        type => 'string',
        format => 'language_tag',
    };
}
sub username {
    return joi->string->regex( $USERNAME_RE );
}
sub jsonrpc_method {
    return joi->string->regex( $JSONRPC_METHOD_RE );
}
HideShow 35 lines of Pod
=head1 FORMAT INTERFACE
This module contains a set of procedures for validating data types.
The C<check_*> procedures take the value to validate and potential extra
arguments and return either undef if the validation succeeded or the reason of
the failure.
    use Zonemaster::Backend::Validator qw( :format );
    # prints "invalid value: The domain name character(s) are not supported"
    if ( defined ( my $error = check_domain( 'not a domain' ) ) ) {
        print "invalid value: $error\n";
    } else {
        print "value is valid\n";
    }
    # prints "value is valid"
    if ( defined ( my $error = check_domain( 'zonemaster.net' ) ) ) {
        print "invalid value: $error\n";
    } else {
        print "value is valid\n";
    }
=cut
=head2 formats($config)
Returns a hashref to be used with the L<"format" method in JSON::Validator|JSON::Validator::Schema/formats>.
The keys are the names of the custom formats, supports: C<domain>,
C<language_tag>, C<ip> and C<profile>.
The method takes a L<Config|Zonemaster::Backend::Config> object as argument.
=cut
sub formats {
    my ( $config ) = @_;
    return {
        domain => \&check_domain,
        language_tag => sub { check_language_tag( @_, $config->LANGUAGE_locale ) },
        ip => \&check_ip,
        profile => sub { check_profile( @_, ( $config->PUBLIC_PROFILES, $config->PRIVATE_PROFILES ) ) },
    };
}
HideShow 6 lines of Pod
=head2 check_domain(%value)
Validates a L<domain name|https://github.com/zonemaster/zonemaster/blob/master/docs/public/using/backend/rpcapi-reference.md#domain-name>.
=cut
sub check_domain {
    my ( $domain ) = @_;
    if ( !defined( $domain ) ) {
        return N__ 'Domain name required';
    }
    my ( $errors, $_domain ) = normalize_name( $domain );
    if ( @{$errors} ) {
        return $errors->[0]->message;
    }
    return undef
}
HideShow 14 lines of Pod
=head2 check_language_tag($value, %locales)
Validates a L<https://github.com/zonemaster/zonemaster/blob/master/docs/public/using/backend/rpcapi-reference.md#language-tag>.
=over
=item %locales
A hash of configured locales, as returned by L<Zonemaster::Backend::Config::LANGUAGE_locale>.
=back
=cut
sub check_language_tag {
    my ( $language, %locales ) = @_;
    my @error;
    if ( $language !~ $LANGUAGE_RE ) {
        return N__ 'Invalid language tag format';
    }
    elsif ( !exists $locales{$language} ) {
        return N__ "Unkown language string";
    }
    return undef;
}
HideShow 6 lines of Pod
=head2 check_ip($value)
Validates an L<IP address|https://github.com/zonemaster/zonemaster/blob/master/docs/public/using/backend/rpcapi-reference.md#ip-address>.
=cut
sub check_ip {
    my ( $ip ) = @_;
    return N__ 'Invalid IP address' unless untaint_ip_address($ip) ;
    return undef
}
HideShow 14 lines of Pod
=head2 check_profile($value, %profiles)
Validates a L<profile name|https://github.com/zonemaster/zonemaster/blob/master/docs/public/using/backend/rpcapi-reference.md#profile-name>.
=over
=item %profiles
A hash of configured profiles, as returned by L<Zonemaster::Backend::Config::PUBLIC_PROFILES>.
=back
=cut
sub check_profile  {
    my ( $profile, %profiles ) = @_;
    if ( $profile !~ $PROFILE_NAME_RE ) {
        return N__ "Invalid profile format";
    }
    if ( !exists $profiles{ lc($profile) } ) {
        return N__ "Unknown profile";
    }
}
HideShow 21 lines of Pod
=head1 UNTAINT INTERFACE
This module contains a set of procedures for validating and untainting strings.
    use Zonemaster::Backend::Validator qw( :untaint );
    # prints "untainted: sqlite"
    if ( defined ( my $value = untaint_engine_type( 'sqlite' ) ) ) {
        print "untainted: $value\n";
    }
    # does not print anything
    if ( defined ( my $value = untaint_engine_type( 'Excel' ) ) ) {
        print "untainted: $value\n";
    }
These procedures all take a possibly tainted single string argument.
If the string is accepted an untainted copy of the string is returned.
=cut
sub untaint_abs_path {
    my ( $value ) = @_;
    return _untaint_pred( $value, \&file_name_is_absolute );
}
HideShow 7 lines of Pod
=head2 untaint_engine_type
Accepts the strings C<"MySQL">, C<"PostgreSQL"> and C<"SQLite">,
case-insensitively.
=cut
sub untaint_engine_type {
    my ( $value ) = @_;
    return _untaint_pat( $value , $ENGINE_TYPE_RE );
}
HideShow 6 lines of Pod
=head2 untaint_ip_address
Accepts an IPv4 or IPv6 address.
=cut
sub untaint_ip_address {
    my ( $value ) = @_;
    return untaint_ipv4_address( $value ) // untaint_ipv6_address( $value );
}
HideShow 6 lines of Pod
=head2 untaint_ipv4_address
Accepts an IPv4 address.
=cut
sub untaint_ipv4_address {
    my ( $value ) = @_;
    if ( $value =~ /($IPV4_RE)/
        && Net::IP::XS::ip_is_ipv4( $value ) )
    {
        return $1;
    }
    return;
}
HideShow 6 lines of Pod
=head2 untaint_ipv6_address
Accepts an IPv6 address.
=cut
sub untaint_ipv6_address {
    my ( $value ) = @_;
    if ( $value =~ /($IPV6_RE)/
        && Net::IP::XS::ip_is_ipv6( $value ) )
    {
        return $1;
    }
    return;
}
HideShow 6 lines of Pod
=head2 untaint_host
Accepts an LDH domain name or an IPv4 or IPv6 address.
=cut
sub untaint_host {
    my ( $value ) = @_;
    return untaint_ldh_domain( $value ) // untaint_ip_address( $value );
}
HideShow 6 lines of Pod
=head2 untaint_ldh_domain
Accepts an LDH domain name.
=cut
sub untaint_ldh_domain {
    my ( $value ) = @_;
    return _untaint_pat( $value, $LDH_DOMAIN_RE1, $LDH_DOMAIN_RE2 );
}
HideShow 6 lines of Pod
=head2 untaint_locale_tag
Accepts a locale tag.
=cut
sub untaint_locale_tag {
    my ( $value ) = @_;
    return _untaint_pat( $value, $LOCALE_TAG_RE );
}
sub untaint_mariadb_database {
    my ( $value ) = @_;
    return _untaint_pat( $value, $MARIADB_IDENT_RE, $MARIADB_DATABASE_LENGTH_RE );
}
sub untaint_mariadb_user {
    my ( $value ) = @_;
    return _untaint_pat( $value, $MARIADB_IDENT_RE, $MARIADB_USER_LENGTH_RE );
}
sub untaint_password {
    my ( $value ) = @_;
    return _untaint_pat( $value, $PASSWORD_RE );
}
sub untaint_strictly_positive_int {
    my ( $value ) = @_;
    return _untaint_pat( $value, $NON_NEGATIVE_INT_RE, $NON_ZERO_NUM_RE );
}
sub untaint_strictly_positive_millis {
    my ( $value ) = @_;
    return _untaint_pat( $value, $MILLIS_RE, $NON_ZERO_NUM_RE );
}
sub untaint_postgresql_ident {
    my ( $value ) = @_;
    return _untaint_pat( $value, $POSTGRESQL_IDENT_RE );
}
sub untaint_non_negative_int {
    my ( $value ) = @_;
    return _untaint_pat( $value, $NON_NEGATIVE_INT_RE );
}
sub untaint_profile_name {
    my ( $value ) = @_;
    return _untaint_pat( $value, $PROFILE_NAME_RE );
}
sub untaint_bool {
    my ( $value ) = @_;
    my $ret;
    $ret = 1 if defined _untaint_pat( $value, $BOOL_TRUE_RE );
    $ret = 0 if defined _untaint_pat( $value, $BOOL_FALSE_RE );
    return $ret;
}
sub _untaint_pat {
    my ( $value, @patterns ) = @_;
    for my $pattern ( @patterns ) {
        if ( $value !~ /($pattern)/ ) {
            return;
        }
    }
    $value =~ qr/(.*)/;
    return $1;
}
sub _untaint_pred {
    my ( $value, $predicate ) = @_;
    if ( $predicate->( $value ) ) {
        $value =~ qr/(.*)/;
        return $1;
    }
    else {
        return;
    }
}
1;