File Coverage

blib/lib/TUWF/Validate/Interop.pm

Criterion	Covered	Total	%
statement	68	176	38.6
branch	57	146	39.0
condition	45	184	24.4
subroutine	13	19	68.4
pod	0	7	0.0
total	183	532	34.4

package TUWF::Validate::Interop;

use strict;
use warnings;
use TUWF::Validate;
use Exporter 'import';
use Carp 'croak';

our @EXPORT_OK = ('analyze');
our $VERSION = '1.5';


# Analyzed ("flattened") object:
#   { type => scalar | bool | num | int | array | hash | any
#   , min, max, minlength, maxlength, required, regexes
#   , keys, values, unknown
#   }

sub _merge_type {
  my($c, $o) = @_;
  my $n = $c->{name}||'';

  return if $o->{type} eq 'int' || $o->{type} eq 'bool';
  $o->{type} = 'int'    if $n eq 'int'     || $n eq 'uint';
  $o->{type} = 'bool'   if $n eq 'anybool' || $n eq 'undefbool' || $n eq 'jsonbool';
  $o->{type} = 'num'    if $n eq 'num';
}


sub _merge {
  my($c, $o) = @_;

  _merge_type $c, $o;

  $o->{required} = 1 if ($c->{name}||'') eq 'anybool';

  $o->{values} = _merge_toplevel($c->{schema}{values}, $o->{values}||{}) if $c->{schema}{values};

  if($c->{schema}{keys}) {
      $o->{keys} ||= {};
      $o->{keys}{$_} = _merge_toplevel($c->{schema}{keys}{$_}, $o->{keys}{$_}||{}) for keys %{$c->{schema}{keys}};
  }

  $o->{minlength} = $c->{schema}{_analyze_minlength} if defined $c->{schema}{_analyze_minlength} && (!defined $o->{minlength} || $o->{minlength} < $c->{schema}{_analyze_minlength});
  $o->{maxlength} = $c->{schema}{_analyze_maxlength} if defined $c->{schema}{_analyze_maxlength} && (!defined $o->{maxlength} || $o->{maxlength} > $c->{schema}{_analyze_maxlength});
  $o->{min}       = $c->{schema}{_analyze_min}       if defined $c->{schema}{_analyze_min}       && (!defined $o->{min}       || $o->{min}       < $c->{schema}{_analyze_min}      );
  $o->{max}       = $c->{schema}{_analyze_max}       if defined $c->{schema}{_analyze_max}       && (!defined $o->{max}       || $o->{max}       > $c->{schema}{_analyze_max}      );
  push @{$o->{regexes}}, $c->{schema}{_analyze_regex} if defined $c->{schema}{_analyze_regex};

  _merge($_, $o) for @{$c->{validations}};
}


sub _merge_toplevel {
  my($c, $o) = @_;
  $o->{required} ||= $c->{schema}{required};
  $o->{unknown}  ||= $c->{schema}{unknown};
  $o->{default}  = $c->{schema}{default} if exists $c->{schema}{default};
  $o->{type} = $c->{schema}{type} if !$o->{type} || $o->{type} eq 'any';

  _merge $c, $o;
  bless $o, __PACKAGE__;
}


sub analyze {
  my $c = shift;
  $c->{analysis} ||= _merge_toplevel $c, {};
  $c->{analysis}
}


# Assumes that $obj already has the required format/structure, odd things may
# happen if this is not the case.
#   unknown => remove|reject|pass
sub coerce_for_json {
  my($o, $obj, %opt) = @_;
  $opt{unknown} ||= $o->{unknown};
  return undef if !defined $obj;
  return $obj+0 if $o->{type} eq 'num';
  return int $obj if $o->{type} eq 'int';
  return $obj ? \1 : \0 if $o->{type} eq 'bool';
  return "$obj" if $o->{type} eq 'scalar';
  return [map $o->{values}->coerce_for_json($_, %opt), @$obj] if $o->{type} eq 'array' && $o->{values};
  return {map {
        $o->{keys}{$_}            ? ($_, $o->{keys}{$_}->coerce_for_json($obj->{$_}, %opt)) :
        $opt{unknown} eq 'pass'   ? ($_, $obj->{$_}) :
        $opt{unknown} eq 'remove' ? ()
                                  : croak "Unknown key '$_' in hash in coerce_for_json()"
  } keys %$obj} if $o->{type} eq 'hash' && $o->{keys};
  $obj
}


# Returns a Cpanel::JSON::XS::Type; Behavior is subtly different compared to coerce_for_json():
# - Unknown keys in hashes will cause Cpanel::JSON::XS to die()
# - Numbers are always formatted as floats (e.g. 10.0) even if it's a round nunmber
sub json_type {
  my $o = shift;
  require Cpanel::JSON::XS::Type;
  return Cpanel::JSON::XS::Type::JSON_TYPE_FLOAT_OR_NULL()  if $o->{type} eq 'num';
  return Cpanel::JSON::XS::Type::JSON_TYPE_INT_OR_NULL()    if $o->{type} eq 'int';
  return Cpanel::JSON::XS::Type::JSON_TYPE_BOOL_OR_NULL()   if $o->{type} eq 'bool';
  return Cpanel::JSON::XS::Type::JSON_TYPE_STRING_OR_NULL() if $o->{type} eq 'scalar';
  return Cpanel::JSON::XS::Type::json_type_null_or_anyof(Cpanel::JSON::XS::Type::json_type_arrayof($o->{values} ? $o->{values}->json_type : undef)) if $o->{type} eq 'array';
  return Cpanel::JSON::XS::Type::json_type_null_or_anyof({ map +($_, $o->{keys}{$_}->json_type), keys %{$o->{keys}} }) if $o->{type} eq 'hash' && $o->{keys};
  return Cpanel::JSON::XS::Type::json_type_null_or_anyof(Cpanel::JSON::XS::Type::json_type_hashof(undef)) if $o->{type} eq 'hash';
  undef
}


# Attempts to convert a stringified Perl regex into something that is compatible with JS.
# - @ should not be escaped
# - (?^: is a perl alias for (?d-imnsx:
# - Javascript doesn't officially support embedded modifiers in the first place, so these are removed
# Regexes compiled with any of /imsx will not work properly.
sub _re_compat {
  local $_ = $_[0];
  s/\\@/@/g;
  s{\(\?\^?[alupimnsx]*(?:-[imnsx]+)?(?=[:\)])}{(?}g;
  $_
}


sub _join_regexes {
  my %r = map +($_,1), @{$_[0]};
  my @r = sort keys %r;
  _re_compat join('', map "(?=$_)", @r[0..$#r-1]).$r[$#r]
}


# Returns a few HTML5 validation properties. Doesn't include the 'type'
sub html5_validation {
  my $o = shift;
  +(
    $o->{required} ? (required => 'required') : (),
    defined $o->{minlength} ? (minlength => $o->{minlength}) : (),
    defined $o->{maxlength} ? (maxlength => $o->{maxlength}) : (),
    defined $o->{min}       ? (min       => $o->{min}      ) : (),
    defined $o->{max}       ? (max       => $o->{max}      ) : (),
    $o->{regexes} ? (pattern => _join_regexes $o->{regexes}) : (),
  );
}



# The elm_ are experimental, unstable, not very well-tested and for Elm 0.19

# Options: required any array values keys indent level
sub elm_type {
  my($o, %opt) = @_;
  my $par = delete $opt{_need_parens} ? sub { "($_[0])" } : sub { $_[0] };
  return $par->('Maybe ' . $o->elm_type(%opt, required => 1, _need_parens => 1)) if !$o->{required} && !defined $o->{default} && !$opt{required};
  delete $opt{required};
  return 'String' if $o->{type} eq 'scalar';
  return 'Bool'   if $o->{type} eq 'bool';
  return 'Float'  if $o->{type} eq 'num';
  return 'Int'    if $o->{type} eq 'int';
  return $opt{any} if $o->{type} eq 'any' && $opt{any};
  return $par->( ($opt{array} || 'List') . ' ' . ($opt{values} || $o->{values}->elm_type(%opt, _need_parens => 1)) )
    if $o->{type} eq 'array' && ($opt{values} || $o->{values});

  if($o->{type} eq 'hash' && ($o->{keys} || $opt{keys})) {
    $opt{indent} //= 2;
    $opt{level}  //= 1;
    my $len = 0;
    $len = length $_ > $len ? length $_ : $len for keys %{$o->{keys}};

    my $r = "\n{ " . join("\n, ", map {
      sprintf "%-*s : %s", $len, $_, $opt{keys}{$_} || $o->{keys}{$_}->elm_type(%opt, level => $opt{level}+1);
    } sort keys %{$o->{keys}}) . "\n}";;

    $r =~ s/\n/$opt{indent} ? "\n" . (' 'x($opt{indent}*$opt{level})) : ''/eg;
    return $r;
  }

  croak "Unknown type '$o->{type}' or missing option";
}


# Elm JSON encoder for values of elm_type()
# options: elm_type() options + json_encode var_prefix
sub elm_encoder {
  my($o, %opt) = @_;
  $opt{json_encode} //= '';
  $opt{var_prefix} //= 'e';
  $opt{var_num} //= 0;

  return sprintf '(Maybe.withDefault %snull << Maybe.map %s)',
    $opt{json_encode}, $opt{values} || $o->elm_encoder(%opt, required => 1)
    if !$o->{required} && !defined $o->{default} && !$opt{required};

  delete $opt{required};
  return "$opt{json_encode}string" if $o->{type} eq 'scalar';
  return "$opt{json_encode}bool"   if $o->{type} eq 'bool';
  return "$opt{json_encode}float"  if $o->{type} eq 'num';
  return "$opt{json_encode}int"    if $o->{type} eq 'int';
  return $opt{any}                 if $o->{type} eq 'any' && $opt{any};
  return sprintf '(%slist %s)', $opt{json_encode}, $opt{values} || $o->{values}->elm_encoder(%opt)
    if $o->{type} eq 'array' && ($opt{values} || $o->{values});

  if($o->{type} eq 'hash' && ($o->{keys} || $opt{keys})) {
    $opt{indent} //= 2;
    $opt{level}  //= 1;
    my $len = 0;
    $len = length $_ > $len ? length $_ : $len for keys %{$o->{keys}};

    my $var = $opt{var_prefix}.$opt{var_num};
    my $r = sprintf "(\\%s -> %sobject\n[ %s\n])", $var, $opt{json_encode}, join "\n, ", map {
      sprintf '("%s",%s %s %s.%1$s)', $_,
        ' 'x($len-(length $_)),
        $opt{keys}{$_} || $o->{keys}{$_}->elm_encoder(%opt, level => $opt{level}+1, var_num => $opt{var_num}+1),
        $var;
    } sort keys %{$o->{keys}};

    $r =~ s/\n/$opt{indent} ? "\n" . (' 'x($opt{indent}*$opt{level})) : ''/eg;
    return $r;
  }

  croak "Unknown type '$o->{type}' or missing option";
}


# Elm JSON decoder for values of elm_type()
# options: elm_type() options + json_decode var_prefix
sub elm_decoder {
  my($o, %opt) = @_;
  $opt{json_decode} //= '';
  $opt{var_prefix} //= 'd';

  return sprintf '(%snullable %s)',
    $opt{json_decode}, $opt{values} || $o->elm_decoder(%opt, required => 1)
    if !$o->{required} && !defined $o->{default} && !$opt{required};

  delete $opt{required};
  return "$opt{json_decode}string" if $o->{type} eq 'scalar';
  return "$opt{json_decode}bool"   if $o->{type} eq 'bool';
  return "$opt{json_decode}float"  if $o->{type} eq 'num';
  return "$opt{json_decode}int"    if $o->{type} eq 'int';
  return $opt{any}                 if $o->{type} eq 'any' && $opt{any};
  return "$opt{json_decode}value"  if $o->{type} eq 'any';
  return sprintf '(%slist %s)', $opt{json_decode}, $opt{values} || $o->{values}->elm_decoder(%opt)
    if $o->{type} eq 'array' && ($opt{values} || $o->{values});

  if($o->{type} eq 'hash' && ($o->{keys} || $opt{keys})) {
    $opt{indent} //= 2;
    $opt{level}  //= 1;
    my $len = 0;
    $len = length $_ > $len ? length $_ : $len for keys %{$o->{keys}};

    my $r;
    my $num = keys %{$o->{keys}};
    my $varnum = 1;
    my $getvar = sub { $opt{var_prefix}.($varnum++) };

    # For 8 members or less we can use the simple Json.Decode.map* functions.
    if($num <= 8) {
      my(@fnarg, @assign, @fetch);
      for (sort keys %{$o->{keys}}) {
        my $var = $getvar->();
        push @fnarg, $var;
        push @assign, "$_ = $var";
        push @fetch, sprintf '(%sfield "%s"%s %s)', $opt{json_decode}, $_,
          ' 'x($len-(length $_)),
          $opt{keys}{$_} || $o->{keys}{$_}->elm_decoder(%opt, var_prefix => $var, level => $opt{level}+1);
      }
      $r = sprintf "(%smap%s\n(\\%s -> { %s })\n%s)",
        $opt{json_decode}, $num == 1 ? '' : $num, join(' ', @fnarg), join(', ', @assign), join("\n", @fetch);

    # For larger hashes we go through Json.Decode.dict and a little custom decoding logic.
    # Json.Decode only allows failing with an error string, so the error messages aren't as good.
    } else {
      my($dict, $fn, $name, $dec, $next, $cap) = map $getvar->(), 1..6;
      my(@assign, @fn);
      for (sort keys %{$o->{keys}}) {
        my $var = $getvar->();
        push @assign, "$_ = $var";
        push @fn, sprintf '%s "%s"%s %s (\%s ->', $fn, $_,
          ' 'x($len-(length $_)),
          $opt{keys}{$_} || $o->{keys}{$_}->elm_decoder(%opt, var_prefix => "${var}_", level => $opt{level}+1),
          $var;
      }
      my $spc = ' 'x(12 + length($fn) + length($name) + length($dec) + length($next));
      $r = "($opt{json_decode}andThen (\\$dict -> \n"
          ."let $fn $name $dec $next = case Maybe.map ($opt{json_decode}decodeValue $dec) (Dict.get $name $dict) of\n"
          ."${spc}Nothing -> $opt{json_decode}fail (\"Missing key '\"++$name++\"'\")\n"
          ."${spc}Just (Err $cap) -> $opt{json_decode}fail (\"Error decoding value of '\"++$name++\"': \"++($opt{json_decode}errorToString $cap))\n"
          ."${spc}Just (Ok $cap) -> $next $cap\n"
          ."in ".join("\n   ", @fn)."\n"
          ."   $opt{json_decode}succeed { ".join(', ', @assign)." }\n"
          .')'.(')'x@fn)." ($opt{json_decode}dict $opt{json_decode}value))";
    }

    $r =~ s/\n/$opt{indent} ? "\n" . (' 'x($opt{indent}*$opt{level})) : ''/eg;
    return $r;
  }

  croak "Unknown type '$o->{type}' or missing option";
}


1;