File Coverage

blib/lib/FU/Validate.pm

Criterion	Covered	Total	%
statement	233	236	98.7
branch	196	212	92.4
condition	131	159	82.3
subroutine	27	28	96.4
pod	2	4	50.0
total	589	639	92.1

package FU::Validate 1.4;

use v5.36;
use experimental 'builtin', 'for_list';
use builtin qw/true false blessed trim/;
use Carp 'confess';
use FU::Util 'to_bool', 'has_control';


# Unavailable as custom validation names
my %builtin = map +($_,1), qw/
    type
    default
    onerror
    trim allow_control
    elems sort unique
    accept_scalar accept_array
    keys values unknown missing
    func
/;

my %type_vals = map +($_,1), qw/scalar hash array any/;
my %unknown_vals = map +($_,1), qw/remove reject pass/;
my %missing_vals = map +($_,1), qw/create reject ignore/;
my %implied_type = qw/
    accept_array scalar
    keys hash values hash unknown hash
    elems array sort array unique array accept_scalar array
/;
my %sort_vals = (
    str => sub($x,$y) { $x cmp $y },
    num => sub($x,$y) { $x <=> $y },
);

sub _length($exp, $min, $max) {
    [ func => sub($v) {
        my $got = ref $v eq 'HASH' ? keys %$v : ref $v eq 'ARRAY' ? @$v : length $v;
        (!defined $min || $got >= $min) && (!defined $max || $got <= $max) ? 1 : { expected => $exp, got => $got };
    }]
}

# Basically the same as ( regex => $arg ), but hides the regex error
sub _reg($reg) {
    ( type => 'scalar', func => sub { $_[0] =~ $reg ? 1 : { got => $_[0] } } );
}


our $re_num       = qr/^-?(?:0|[1-9][0-9]*)(?:\.[0-9]+)?(?:[eE][+-]?[0-9]+)?$/;
our $re_int       = qr/^-?(?:0|[1-9][0-9]*)$/;
our $re_uint      = qr/^(?:0|[1-9][0-9]*)$/;
our $re_fqdn      = qr/(?:[a-zA-Z0-9][\w-]*\.)+[a-zA-Z][a-zA-Z0-9-]{1,25}\.?/;
our $re_ip4_digit = qr/(?:0|[1-9]|[1-9][0-9]|1[0-9]{2}|2[0-4][0-9]|25[0-5])/;
our $re_ip4       = qr/($re_ip4_digit\.){3}$re_ip4_digit/;
# This monstrosity is based on http://stackoverflow.com/questions/53497/regular-expression-that-matches-valid-ipv6-addresses
# Doesn't allow IPv4-mapped-IPv6 addresses or other fancy stuff.
our $re_ip6       = qr/(?:[0-9a-fA-F]{1,4}:){7,7}[0-9a-fA-F]{1,4}|(?:[0-9a-fA-F]{1,4}:){1,7}:|(?:[0-9a-fA-F]{1,4}:){1,6}:[0-9a-fA-F]{1,4}|(?:[0-9a-fA-F]{1,4}:){1,5}(?::[0-9a-fA-F]{1,4}){1,2}|(?:[0-9a-fA-F]{1,4}:){1,4}(?::[0-9a-fA-F]{1,4}){1,3}|(?:[0-9a-fA-F]{1,4}:){1,3}(?::[0-9a-fA-F]{1,4}){1,4}|(?:[0-9a-fA-F]{1,4}:){1,2}(?::[0-9a-fA-F]{1,4}){1,5}|[0-9a-fA-F]{1,4}:(?:(?::[0-9a-fA-F]{1,4}){1,6})|:(?:(?::[0-9a-fA-F]{1,4}){1,7}|:)/;
our $re_ip        = qr/(?:$re_ip4|$re_ip6)/;
our $re_domain    = qr/(?:$re_fqdn|$re_ip4|\[$re_ip6\])/;
our $re_email     = qr/^[-\+\.#\$=\w]+\@$re_fqdn$/;
our $re_weburl    = qr/^https?:\/\/$re_domain(?::[1-9][0-9]{0,5})?(?:\/[^\s<>"]*)$/;
our $re_date      = qr/^(?:19[0-9][0-9]|20[0-9][0-9])-(?:0[1-9]|1[0-2])-(?:0[1-9]|[12][0-9]|3[01])$/;


# There's a special '_scalartype' option used for coerce() and empty(), with the following values:
#   0/undef/missing: string, 1:num, 2:int, 3:bool
# The highest number, i.e. most restrictive type, is chosen when multiple validations exist.

our %default_validations = (
    regex => sub($reg) {
        # Error objects should be plain data structures so that they can easily
        # be converted to JSON for debugging. We have to stringify $reg in the
        # error object to ensure that.
        +{ type => 'scalar', func => sub { $_[0] =~ $reg ? 1 : { regex => "$reg", got => $_[0] } } }
    },
    enum => sub($vals) {
        my @l = ref $vals eq 'HASH' ? sort keys %$vals : ref $vals eq 'ARRAY' ? @$vals : ($vals);
        my %opts = map +($_,1), @l;
        +{ type => 'scalar', func => sub { $opts{ (my $v = $_[0]) } ? 1 : { expected => \@l, got => $_[0] } } }
    },

    minlength => sub($v) { _length $v, $v, undef },
    maxlength => sub($v) { _length $v, undef, $v },
    length    => sub($v) { _length $v, ref $v eq 'ARRAY' ? @$v : ($v, $v) },

    bool      => { _scalartype => 3, type => 'any', func => sub { my $r = to_bool $_[0]; return {} if !defined $r; $_[0] = $r; 1 } },
    anybool   => { _scalartype => 3, type => 'any', default => false, func => sub { $_[0] = $_[0] ? true : false; 1 } },

    num   => [ _scalartype => 1, _reg($re_num), func => sub { $_[0] = $_[0]*1; 1 } ],
    int   => [ _scalartype => 2, _reg($re_int), func => sub { return { message => 'integer out of range' } if $_[0] < -9223372036854775808 || $_[0] > 9223372036854775807; $_[0] = int $_[0]; 1 } ],
    uint  => [ _scalartype => 2, _reg($re_uint), func => sub { return { message => 'integer out of range' } if $_[0] > 18446744073709551615; $_[0] = int $_[0]; 1 } ],
    min   => sub($min) { +{ num => 1, func => sub { $_[0] >= $min ? 1 : { expected => $min, got => $_[0] } } } },
    max   => sub($max) { +{ num => 1, func => sub { $_[0] <= $max ? 1 : { expected => $max, got => $_[0] } } } },
    range => sub { [ min => $_[0][0], max => $_[0][1] ] },

    ascii  => { _reg qr/^[\x20-\x7E]*$/ },
    sl     => { _reg qr/^[^\t\r\n]+$/ },
    ipv4   => { _reg $re_ip4 },
    ipv6   => { _reg $re_ip6 },
    ip     => { _reg $re_ip  },
    email  => { _reg($re_email),  maxlength => 254 },
    weburl => { _reg($re_weburl), maxlength => 65536 }, # the maxlength is a bit arbitrary, but better than unlimited
    date   => { _reg $re_date },
);


sub _new { bless { validations => [], @_ }, __PACKAGE__ }


sub _compile($schema, $custom, $rec, $top, $validations=$top->{validations}) {
    my $iscompiled = $schema isa __PACKAGE__;

    # For hashref schemas, builtins always override other validations
    $schema = [
        map +($_, $schema->{$_}),
            (grep !$builtin{$_}, keys %$schema),
            (grep $builtin{$_}, keys %$schema),
    ] if ref $schema ne 'ARRAY';

    for my($name, $val) (@$schema) {
        if ($name eq 'type') {
            confess "Invalid value for 'type': $val" if $name eq 'type' && !$type_vals{$val};
            confess "Incompatible types, the schema specifies '$val', but another validation requires '$top->{type}'" if $top->{type} && $top->{type} ne $val;;
            $top->{type} = $val;
            next;
        }

        my $type = $implied_type{$name};
        if ($type) {
            confess "Incompatible types, the schema specifies '$top->{type}' but the '$name' validation implies '$type'" if $top->{type} && $top->{type} ne $type;
            $top->{type} = $type;
        }

        if ($name eq 'elems' || $name eq 'values') {
            $top->{$name} ||= _new;
            _compile($val, $custom, $rec-1, $top->{$name});
            next;
        }

        if ($name eq 'keys') {
            $top->{keys} ||= {};
            for my($n,$v) (%$val) {
                $top->{keys}{$n} ||= _new;
                _compile($v, $custom, $rec-1, $top->{keys}{$n});
            }
            next;
        }

        if ($name eq 'func') {
            push @$validations, $val;
            next;
        }

        if ($name eq 'default') {
            $top->{default} = $val;
            delete $top->{default} if ref $val eq 'SCALAR' && $$val eq 'required';
            next;
        }

        if ($name eq '_scalartype') {
            $top->{_scalartype} = $val if ($top->{_scalartype}||0) < $val;
            next;
        }

        if ($builtin{$name}) {
            confess "Invalid value for 'missing': $val" if $name eq 'missing' && !$missing_vals{$val};
            confess "Invalid value for 'unknown': $val" if $name eq 'unknown' && !$unknown_vals{$val};
            confess "Invalid value for 'accept_array': $val" if $name eq 'accept_array' && $val && $val ne 'first' && $val ne 'last';
            $val = $sort_vals{$val} || confess "Unknown value for 'sort': $val" if $name eq 'sort' && ref $val ne 'CODE';
            $top->{$name} = $val;
            next;
        }

        if ($iscompiled && $name eq 'validations') {
            push @$validations, @$val;
            next;
        }

        my $t = $custom->{$name} || $default_validations{$name};
        confess "Unknown validation: $name" if !$t;
        confess "Recursion limit exceeded while resolving validation '$name'" if $rec < 1;
        $t = ref $t eq 'CODE' ? $t->($val) : $t;

        my $v = _new name => $name;
        _compile($t, $custom, $rec-1, $top, $v->{validations});
        push @$validations, $v if $v->{validations}->@*;
    }
}


sub compile($pkg, $schema, $custom={}) {
    return $schema if $schema isa __PACKAGE__;
    my $c = _new;
    _compile $schema, $custom, 64, $c;
    $c
}


sub _validate_hash {
    my $c = $_[0];

    if ($c->{keys}) {
        my @err;
        for my ($k, $s) ($c->{keys}->%*) {
            if (!exists $_[1]{$k}) {
                next if $s->{missing} && $s->{missing} eq 'ignore';
                return { validation => 'missing', key => $k } if $s->{missing} && $s->{missing} eq 'reject';
                $_[1]{$k} = ref $s->{default} eq 'CODE' ? $s->{default}->() : $s->{default} // undef;
                next if exists $s->{default};
            }

            my $r = _validate($s, $_[1]{$k});
            if ($r) {
                $r->{key} = $k;
                push @err, $r;
            }
        }
        return { validation => 'keys', errors => [ sort { $a->{key} cmp $b->{key} } @err ] } if @err;
    }

    if ($c->{values}) {
        my @err;
        for my ($k, $v) ($_[1]->%*) {
            my $r = _validate($c->{values}, $v);
            if ($r) {
                $r->{key} = $k;
                push @err, $r;
            }
        }
        return { validation => 'values', errors => [ sort { $a->{key} cmp $b->{key} } @err ] } if @err;
    }
}

sub _validate_elems {
    my @err;
    for my $i (0..$#{$_[1]}) {
        my $r = _validate($_[0]{elems}, $_[1][$i]);
        if ($r) {
            $r->{index} = $i;
            push @err, $r;
        }
    }
    return { validation => 'elems', errors => \@err } if @err;
}


sub _validate_rec {
    my $c = $_[0];
    for my $v ($c->{validations}->@*) {
        if (ref $v eq 'CODE') {
            my $r = $v->($_[1]);
            return { %$r, validation => 'func' } if ref $r eq 'HASH';
            return { validation => 'func', result => $r } if !$r;
        } else {
            my $r = _validate_rec($v, $_[1]);
            return {
                # If the error was a custom 'func' object, then make that the primary cause.
                # This makes it possible for validations to provide their own error objects.
                $r->{validation} eq 'func' && (!exists $r->{result} || keys $r->%* > 2) ? $r->%* : (error => $r),
                validation => $v->{name},
            } if $r;
        }
    }
}


sub _validate_array {
    my $c = $_[0];

    $_[1] = [sort { $c->{sort}->($a, $b) } $_[1]->@* ] if $c->{sort};

    # Key-based uniqueness
    if ($c->{unique} && (!$c->{sort} || ref $c->{unique} eq 'CODE')) {
        my %h;
        for my $i (0..$#{$_[1]}) {
            my $k = ref $c->{unique} eq 'CODE' ? $c->{unique}->($_[1][$i]) : $_[1][$i];
            return { validation => 'unique', index_a => $h{$k}, value_a => $_[1][$h{$k}], index_b => $i, value_b => $_[1][$i], key => $k } if exists $h{$k};
            $h{$k} = $i;
        }

    # Comparison-based uniqueness
    } elsif ($c->{unique}) {
        for my $i (0..$#{$_[1]}-1) {
            return { validation => 'unique', index_a => $i, value_a => $_[1][$i], index_b => $i+1, value_b => $_[1][$i+1] }
                if $c->{sort}->($_[1][$i], $_[1][$i+1]) == 0
        }
    }
}


sub _validate_input {
    my $c = $_[0];

    my $type = $c->{type} // 'scalar';

    # accept_array (needs to be done before 'trim')
    $_[1] = $_[1]->@* == 0 ? undef : $c->{accept_array} eq 'first' ? $_[1][0] : $_[1][ $#{$_[1]} ]
        if $c->{accept_array} && ref $_[1] eq 'ARRAY';

    # early scalar checks
    if (defined $_[1] && !ref $_[1] && $type eq 'scalar') {
        # trim needs to be done before the 'default' test
        $_[1] = trim $_[1] =~ s/\r//rg if !exists $c->{trim} || $c->{trim};

        return { validation => 'allow_control' } if !$c->{allow_control} && has_control $_[1];
    }

    # default
    if (!defined $_[1] || (!ref $_[1] && $_[1] eq '')) {
        if (exists $c->{default}) {
            $_[1] = ref $c->{default} eq 'CODE' ? $c->{default}->($_[1]) : $c->{default};
            return;
        }
        return { validation => 'required' };
    }

    if ($type eq 'scalar') {
        return { validation => 'type', expected => 'scalar', got => lc ref $_[1] } if ref $_[1];

    } elsif ($type eq 'hash') {
        return { validation => 'type', expected => 'hash', got => lc ref $_[1] || 'scalar' } if ref $_[1] ne 'HASH';

        # Each branch below makes a shallow copy of the hash, so that further
        # validations can perform in-place modifications without affecting the
        # input.
        if (!$c->{keys} || ($c->{unknown} && $c->{unknown} eq 'pass')) {
            $_[1] = { $_[1]->%* };
        } elsif (!$c->{unknown} || $c->{unknown} eq 'remove') {
            $_[1] = { map +($_, $_[1]{$_}), grep $c->{keys}{$_}, keys $_[1]->%* };
        } else {
            my @err = grep !$c->{keys}{$_}, keys $_[1]->%*;
            return { validation => 'unknown', keys => \@err, expected => [ sort keys $c->{keys}->%* ] } if @err;
            $_[1] = { $_[1]->%* };
        }

    } elsif ($type eq 'array') {
        $_[1] = [$_[1]] if $c->{accept_scalar} && !ref $_[1];
        return { validation => 'type', expected => $c->{accept_scalar} ? 'array or scalar' : 'array', got => lc ref $_[1] || 'scalar' } if ref $_[1] ne 'ARRAY';
        $_[1] = [$_[1]->@*]; # Create a shallow copy to prevent in-place modification.

    } elsif ($type eq 'any') {
        # No need to do anything here.
    }

    ($type eq 'hash' && &_validate_hash) ||
    ($c->{elems} && &_validate_elems) ||
    &_validate_rec ||
    ($type eq 'array' && &_validate_array)
}


sub _validate {
    my $c = $_[0];
    my $r = &_validate_input;
    ($r, $_[1]) = (undef, ref $c->{onerror} eq 'CODE' ? $c->{onerror}->($_[0], bless $r, 'FU::Validate::err') : $c->{onerror})
        if $r && exists $c->{onerror};
    $r
}


sub validate($c, $input) {
    my $r = _validate($c, $input);
    return $input if !$r;
    $r = bless $r, 'FU::Validate::err';;
    my @e = $r->errors;
    $r->{longmess} = Carp::longmess(@e > 1 ? join("\n",@e)."\n" : $e[0]);
    die $r;
}


sub coerce {
    my $c = $_[0];
    my %opt = @_[2..$#_];
    if (!defined $_[1]) {
        $_[1] = undef;
    } elsif ($c->{_scalartype}) {
        $_[1] = $c->{_scalartype} == 3 ? !!$_[1] : $c->{_scalartype} == 2 ? int $_[1] : $_[1]+0;
    } elsif (!$c->{type} || $c->{type} eq 'scalar') {
        $_[1] = "$_[1]";
    } elsif ($c->{type} eq 'array' && $c->{elems} && ref $_[1] eq 'ARRAY') {
        coerce($c->{elems}, $_, %opt) for $_[1]->@*;
    } elsif ($c->{type} eq 'hash' && $c->{keys} && ref $_[1] eq 'HASH') {
        $opt{unknown} ||= $c->{unknown};
        delete @{$_[1]}{ grep !$c->{keys}{$_}, keys $_[1]->%* }
            if $opt{unknown} && $opt{unknown} ne 'pass';
        $_[1]{$_} = exists $_[1]{$_} ? coerce($c->{keys}{$_}, $_[1]{$_}, %opt) : empty($c->{keys}{$_})
            for keys $c->{keys}->%*;
    }
    return $_[1];
}


sub empty($c) {
    return ref $c->{default} eq 'CODE' ? $c->{default}->(undef) : $c->{default} if exists $c->{default};
    return [] if $c->{type} && $c->{type} eq 'array';
    return $c->{keys} ? +{ map +($_, empty($c->{keys}{$_})), keys $c->{keys}->%* } : {} if $c->{type} && $c->{type} eq 'hash';
    return undef if $c->{type} && $c->{type} eq 'any';
    # Only scalar types remain
    return !$c->{_scalartype} ? '' : $c->{_scalartype} == 3 ? !1 : 0;
}



sub _fmtkey($k) { $k =~ /^[a-zA-Z0-9_-]+$/ ? $k : FU::Util::json_format($k); }
sub _fmtval($v) { eval { $v = FU::Util::json_format($v) }; "$v" }
sub _inval($t,$v) { sprintf 'invalid %s: %s', $t, _fmtval $v }

# validation name => formatting sub
# TODO: document.
our %error_format = (
    required  => sub { 'required value missing' },
    allow_control => sub { 'invalid control character' },
    type      => sub($e) { "invalid type, expected '$e->{expected}' but got '$e->{got}'" },
    unknown   => sub($e) { sprintf 'unknown key%s: %s', $e->{keys}->@* == 1 ? '' : 's', join ', ', map _fmtkey($_), $e->{keys}->@* },
    minlength => sub($e) { sprintf "input too short, expected minimum of %d but got %d", $e->{expected}, $e->{got} },
    maxlength => sub($e) { sprintf "input too long, expected maximum of %d but got %d", $e->{expected}, $e->{got} },
    length    => sub($e) {
        !ref $e->{expected}
        ? sprintf 'invalid input length, expected %d but got %d', $e->{expected}, $e->{got}
        : sprintf 'invalid input length, expected between %d and %d but got %d', $e->{expected}->@*, $e->{got}
    },
    num       => sub($e) { _inval 'number', $e->{got} },
    min       => sub($e) { $e->{error} ? _inval 'number', $e->{error}{got} : sprintf 'expected minimum %s but got %s', $e->{expected}, $e->{got} },
    max       => sub($e) { $e->{error} ? _inval 'number', $e->{error}{got} : sprintf 'expected maximum %s but got %s', $e->{expected}, $e->{got} },
    range     => sub($e) { FU::Validate::err::errors($e->{error}) },
);


package FU::Validate::err;
use v5.36;

use overload '""' => sub { $_[0]{longmess} || join "\n", $_[0]->errors };

# TODO: document.
sub errors($e, $prefix='') {
    my $val = $e->{validation};
    my $p = $prefix ? "$prefix: " : '';
    $FU::Validate::error_format{$val} ? map "$p$_", $FU::Validate::error_format{$val}->($e) :
    $val eq 'keys'     ? map errors($_, $prefix.'.'.FU::Validate::_fmtkey($_->{key})), $e->{errors}->@* :
    $val eq 'values'   ? map errors($_, $prefix.'.'.FU::Validate::_fmtkey($_->{key})), $e->{errors}->@* :
    $val eq 'missing'  ? $prefix.'.'.FU::Validate::_fmtkey($e->{key}).': required key missing' :
    $val eq 'elems'    ? map errors($_, $prefix."[$_->{index}]"), $e->{errors}->@* :
    $val eq 'unique'   ? $prefix."[$e->{index_b}] value '".FU::Validate::_fmtval($e->{value_a})."' duplicated" :
    $e->{error}        ? errors($e->{error}, "${p}validation '$val'") :
    $e->{message}      ? "${p}validation '$val': $e->{message}" :
                         "${p}failed validation '$val'";
}


1;
__END__