@voxgig/sdkgen 4.34.0 → 4.34.1

package/project/.sdk/tm/perl/utility/make_point.pm

@@ -12,6 +12,8 @@ BEGIN { $__dir = File::Basename::dirname(Cwd::abs_path(__FILE__)) }
 require(Cwd::abs_path("$__dir/../lib/Voxgig/Struct.pm"));
 require(Cwd::abs_path("$__dir/../core/helpers.pm"));
 require(Cwd::abs_path("$__dir/../core/error.pm"));
+require(Cwd::abs_path("$__dir/prepare_method.pm"));
+require(Cwd::abs_path("$__dir/param.pm"));
 
 package ProjectNameUtilities;
 
@@ -38,6 +40,36 @@ sub _terminal_param {
   return (defined $last && !ref $last && $last =~ /^\{/) ? 1 : 0;
 }
 
+# The entity's own route among some points.
+sub _own_point {
+  my (@points) = @_;
+  my $best = $points[0];
+  for my $p (@points) {
+    if (_terminal_param($p) != _terminal_param($best)) {
+      $best = $p if _terminal_param($p);
+    }
+    elsif (_parts_len($p) < _parts_len($best)) {
+      $best = $p;
+    }
+  }
+  return $best;
+}
+
+# The path parameters of a point that neither the call nor the entity gives a
+# value for, looked up as prepare_params looks them up.
+sub _unfilled {
+  my ($ctx, $point) = @_;
+  my $parts = ProjectNameHelpers::gp($point, 'parts');
+  return () unless Voxgig::Struct::islist($parts);
+  my @missing;
+  for my $part (@$parts) {
+    next unless defined $part && !ref $part && $part =~ /\A\{([^{}\/]+)\}\z/;
+    my $name = $1;
+    push @missing, $name unless defined param_value($ctx, $point, $name);
+  }
+  return @missing;
+}
+
 $REGISTRY{make_point} = sub {
   my ($ctx) = @_;
 
@@ -56,8 +88,9 @@ $REGISTRY{make_point} = sub {
   my $options = $ctx->{options};
 
   my $allow_op = ProjectNameHelpers::gpath($options, 'allow.op');
+  my $allow_ok = ProjectNameUtilities::allowed($allow_op, $op->{name});
   $allow_op = '' unless defined $allow_op && !ref $allow_op;
-  if (index($allow_op, $op->{name}) < 0) {
+  unless ($allow_ok) {
     return (undef, $ctx->make_error('point_op_allow',
       "Operation \"$op->{name}\" not allowed by SDK option allow.op value: \"$allow_op\""));
   }
@@ -124,15 +157,28 @@ $REGISTRY{make_point} = sub {
           Voxgig::Struct::stringify($unmatched_action) . '" is not valid.'));
       }
 
-      $point = $op->{points}[0];
-      for my $p (@{ $op->{points} }) {
-        if (_terminal_param($p) != _terminal_param($point)) {
-          $point = $p if _terminal_param($p);
-        }
-        elsif (_parts_len($p) < _parts_len($point)) {
-          $point = $p;
-        }
+      # A call without an action falls back to a point without one, as
+      # generation does, and only to a route the call can fill.
+      my @plain = grep {
+        !defined ProjectNameHelpers::gp(
+          ProjectNameHelpers::to_map(ProjectNameHelpers::gp($_, 'select')), '$action')
+      } @{ $op->{points} };
+      unless (@plain) {
+        return (undef, $ctx->make_error('point_action_required',
+          'Operation "' . $op->{name} .
+          '" has only action endpoints; pass $action to choose one.'));
       }
+
+      my @fillable = grep { my @missing = _unfilled($ctx, $_); !@missing } @plain;
+
+      unless (@fillable) {
+        return (undef, $ctx->make_error('point_no_match',
+          'Operation "' . $op->{name} .
+          '" has no endpoint whose path parameters are all given (missing: ' .
+          join(', ', _unfilled($ctx, _own_point(@plain))) . ').'));
+      }
+
+      $point = _own_point(@fillable);
     }
 
     if ($reqselector) {

package/project/.sdk/tm/perl/utility/make_spec.pm

@@ -5,12 +5,14 @@ use warnings;
 
 use File::Basename ();
 use Cwd ();
+use Scalar::Util ();
 
 my $__dir;
 BEGIN { $__dir = File::Basename::dirname(Cwd::abs_path(__FILE__)) }
 require(Cwd::abs_path("$__dir/../lib/Voxgig/Struct.pm"));
 require(Cwd::abs_path("$__dir/../core/helpers.pm"));
 require(Cwd::abs_path("$__dir/../core/spec.pm"));
+require(Cwd::abs_path("$__dir/prepare_method.pm"));
 
 package ProjectNameUtilities;
 
@@ -20,7 +22,12 @@ $REGISTRY{make_spec} = sub {
   my ($ctx) = @_;
 
   if ($ctx->{out}{spec}) {
-    $ctx->{spec} = $ctx->{out}{spec};
+    my $preset = $ctx->{out}{spec};
+    # A PreSpec hook (validate) rejects the operation by placing its error
+    # here; the pipeline raises it, and ctx.spec stays a request spec.
+    return (undef, $preset)
+      if Scalar::Util::blessed($preset) && $preset->isa('ProjectNameError');
+    $ctx->{spec} = $preset;
     return ($ctx->{spec}, undef);
   }
 
@@ -47,10 +54,12 @@ $REGISTRY{make_spec} = sub {
   $ctx->{spec}{method} = $utility->{prepare_method}->($ctx);
 
   my $allow_method = ProjectNameHelpers::gpath($options, 'allow.method');
+  my $allow_ok = ProjectNameUtilities::allowed($allow_method, $ctx->{spec}{method});
   $allow_method = '' unless defined $allow_method && !ref $allow_method;
-  unless (index($allow_method, $ctx->{spec}{method}) >= 0) {
+  unless ($allow_ok) {
+    my $shown = $ctx->{spec}{method} // '';
     return (undef, $ctx->make_error('spec_method_allow',
-      "Method \"$ctx->{spec}{method}\" not allowed by SDK option allow.method value: \"$allow_method\""));
+      "Method \"$shown\" not allowed by SDK option allow.method value: \"$allow_method\""));
   }
 
   $ctx->{spec}{params} = $utility->{prepare_params}->($ctx);
@@ -79,9 +88,24 @@ $REGISTRY{make_spec} = sub {
 
   $ctx->{ctrl}{explain}{spec} = $ctx->{spec} if $ctx->{ctrl}{explain};
 
+  # Whatever prepare_auth sets in the query, under whichever name, is the
+  # credential; a key it leaves as it was is the caller's.
+  my %query = %{ $ctx->{spec}{query} || {} };
+
   my ($spec, $err) = $utility->{prepare_auth}->($ctx);
   return (undef, $err) if $err;
 
+  my $same = sub {
+    my ($was, $now) = @_;
+    return !defined $now unless defined $was;
+    return 0 if !defined $now || ref $was ne ref $now;
+    return ref $now ? $was == $now : $was eq $now;
+  };
+  my $now = $spec->{query} || {};
+  $spec->{authquery} = [ grep {
+    !exists $query{$_} || !$same->($query{$_}, $now->{$_})
+  } sort keys %$now ];
+
   $ctx->{spec} = $spec;
   return ($spec, undef);
 };

package/project/.sdk/tm/perl/utility/make_url.pm

@@ -29,6 +29,9 @@ $REGISTRY{make_url} = sub {
     [$spec->{base}, $spec->{prefix}, $spec->{path}, $spec->{suffix}], '/', 1);
   my $resmatch = {};
 
+  # Sent with the request, never recorded as the entity's match.
+  my %authquery = map { $_ => 1 } @{ $spec->{authquery} || [] };
+
   # A route the definition ends with a slash keeps it: a server such as a
   # Django REST one redirects or refuses the route without it.
   my $orig = $ctx->{point} ? ProjectNameHelpers::gp($ctx->{point}, 'orig') : undef;
@@ -48,6 +51,15 @@ $REGISTRY{make_url} = sub {
     }
   }
 
+  # A placeholder left in the route would send the request to the wrong route.
+  # The base's own placeholders are server variables, resolved with the options.
+  my $base = defined $spec->{base} && !ref $spec->{base} ? $spec->{base} : '';
+  $base =~ s{/+\z}{};
+  my $route = 0 == index($url, $base) ? substr($url, length $base) : $url;
+  my @unfilled = $route =~ /(\{[^{}\/]+\})/g;
+  return ('', $ctx->make_error('url_param_missing',
+    'URL path has no value for ' . join(', ', @unfilled) . '.')) if @unfilled;
+
   # Append query string from spec.query.
   my $qsep = '?';
   my $query_items = Voxgig::Struct::items($spec->{query});
@@ -57,7 +69,7 @@ $REGISTRY{make_url} = sub {
       if (ProjectNameHelpers::rb_truthy($val) && defined $key && !ref $key) {
         $url .= $qsep . Voxgig::Struct::escurl("$key") . '=' . Voxgig::Struct::escurl("$val");
         $qsep = '&';
-        $resmatch->{$key} = $val;
+        $resmatch->{$key} = $val unless $authquery{$key};
       }
     }
   }

package/project/.sdk/tm/perl/utility/media.pm

@@ -0,0 +1,109 @@
+# ProjectName SDK utility: media
+
+use strict;
+use warnings;
+
+use File::Basename ();
+use Cwd ();
+use Scalar::Util ();
+
+my $__dir;
+BEGIN { $__dir = File::Basename::dirname(Cwd::abs_path(__FILE__)) }
+require(Cwd::abs_path("$__dir/../lib/Voxgig/Struct.pm"));
+require(Cwd::abs_path("$__dir/../core/helpers.pm"));
+
+# The media types a point declares: `response` (the model's `rs`) for the
+# Accept header, and `body` (the model's `rb`) for the request body.
+package ProjectNameUtilities;
+
+# The data key holding a raw request body. Like `$action`, it can never be a
+# declared argument name.
+our $RAW_BODY = '$body';
+
+sub is_json_media {
+  my ($media) = @_;
+  my ($m) = split /;/, (defined $media && !ref $media ? "$media" : '');
+  $m = lc(defined $m ? $m : '');
+  $m =~ s/^\s+|\s+$//g;
+  return 'application/json' eq $m || 'text/json' eq $m || $m =~ /\+json\z/;
+}
+
+# The declared JSON type alone, else every declared type in the model's
+# order; undef when no success response declares a body.
+sub accept_of {
+  my ($point) = @_;
+  my $res = ProjectNameHelpers::gp($point, 'response');
+  my $media = ProjectNameHelpers::gp($res, 'media');
+  return undef unless defined $media && !ref $media && '' ne $media;
+  my $kind = ProjectNameHelpers::gp($res, 'kind');
+  return $media if defined $kind && 'json' eq $kind;
+  my @types = ($media);
+  my $alts = ProjectNameHelpers::gp($res, 'alternatives');
+  for my $alt (ref $alts eq 'ARRAY' ? @$alts : ()) {
+    my $m = ProjectNameHelpers::gp($alt, 'media');
+    push @types, $m if defined $m && !ref $m && '' ne $m;
+  }
+  return join(', ', @types);
+}
+
+sub is_raw_request {
+  my ($point) = @_;
+  my $kind = ProjectNameHelpers::gp(ProjectNameHelpers::gp($point, 'body'), 'kind');
+  return defined $kind && 'raw' eq $kind;
+}
+
+sub is_json_request {
+  my ($point) = @_;
+  my $kind = ProjectNameHelpers::gp(ProjectNameHelpers::gp($point, 'body'), 'kind');
+  return defined $kind && 'json' eq $kind;
+}
+
+# A stream goes as given. A hash or an array is JSON, and so is a scalar on a
+# point that declares a JSON body.
+sub request_body {
+  my ($point, $body) = @_;
+  return $body if ref $body eq 'GLOB' || (Scalar::Util::blessed($body) && $body->can('read'));
+  return Voxgig::Struct::jsonify($body) if Voxgig::Struct::isnode($body) || is_json_request($point);
+  return $body;
+}
+
+sub _has_header {
+  my ($headers, $name) = @_;
+  return scalar grep { lc $_ eq $name } keys %$headers;
+}
+
+# A caller's accept wins. A declared request type replaces each JSON
+# content-type, the SDK default, and leaves any other the caller set.
+sub media_headers {
+  my ($point, $headers) = @_;
+  my $accept = accept_of($point);
+  $headers->{accept} = $accept if defined $accept && !_has_header($headers, 'accept');
+
+  my $body = ProjectNameHelpers::gp($point, 'body');
+  my $kind = ProjectNameHelpers::gp($body, 'kind');
+  my $media = ProjectNameHelpers::gp($body, 'media');
+  if (defined $kind && ('raw' eq $kind || 'json' eq $kind)
+    && defined $media && !ref $media && '' ne $media) {
+    delete $headers->{$_}
+      for grep { 'content-type' eq lc $_ && is_json_media($headers->{$_}) } keys %$headers;
+    $headers->{'content-type'} = $media unless _has_header($headers, 'content-type');
+  }
+
+  return $headers;
+}
+
+# A string of bytes, a character string (sent as UTF-8), or a filehandle. A
+# filehandle can be read once, so it is read here, before the first attempt,
+# and a retry sends the same bytes again.
+sub raw_body {
+  my ($reqdata) = @_;
+  my $body = ref $reqdata eq 'HASH' ? $reqdata->{$RAW_BODY} : undef;
+  if (ref $body && Scalar::Util::openhandle($body)) {
+    local $/;
+    my $data = <$body>;
+    return defined $data ? $data : '';
+  }
+  return $body;
+}
+
+1;

package/project/.sdk/tm/perl/utility/param.pm

@@ -17,12 +17,6 @@ our %REGISTRY;
 
 $REGISTRY{param} = sub {
   my ($ctx, $paramdef) = @_;
-  my $point = $ctx->{point};
-  my $spec = $ctx->{spec};
-  my $match_val = $ctx->{match};
-  my $reqmatch = $ctx->{reqmatch};
-  my $data = $ctx->{data};
-  my $reqdata = $ctx->{reqdata};
 
   my $pt = Voxgig::Struct::typify($paramdef);
   my $key;
@@ -34,32 +28,64 @@ $REGISTRY{param} = sub {
     $key = (defined $k && !ref $k) ? $k : '';
   }
 
-  my $akey = '';
-  if ($point) {
-    my $alias_map = ProjectNameHelpers::to_map(ProjectNameHelpers::gp($point, 'alias'));
-    if ($alias_map) {
-      my $ak = ProjectNameHelpers::gp($alias_map, $key);
-      $akey = $ak if defined $ak && !ref $ak;
-    }
+  my $akey = _param_alias($ctx->{point}, $key);
+  if ($ctx->{spec} && '' ne $akey &&
+    !defined ProjectNameHelpers::gp($ctx->{reqmatch}, $key) &&
+    !defined ProjectNameHelpers::gp($ctx->{match}, $key)) {
+    $ctx->{spec}{alias}{$akey} = $key;
   }
 
-  my $val = ProjectNameHelpers::gp($reqmatch, $key);
-  $val = ProjectNameHelpers::gp($match_val, $key) if !defined $val;
+  return param_value($ctx, $ctx->{point}, $key);
+};
 
-  if (!defined $val && '' ne $akey) {
-    $spec->{alias}{$akey} = $key if $spec;
-    $val = ProjectNameHelpers::gp($reqmatch, $akey);
-  }
+# The name a point gives a parameter in the call, if it renames it.
+sub _param_alias {
+  my ($point, $key) = @_;
+  return '' unless $point;
+  my $alias_map = ProjectNameHelpers::to_map(ProjectNameHelpers::gp($point, 'alias'));
+  my $ak = $alias_map ? ProjectNameHelpers::gp($alias_map, $key) : undef;
+  return (defined $ak && !ref $ak) ? $ak : '';
+}
+
+# The value the call or its entity gives a point's parameter, under its name
+# or the point's alias for it.
+sub param_value {
+  my ($ctx, $point, $key) = @_;
+  my $akey = _param_alias($point, $key);
 
-  $val = ProjectNameHelpers::gp($reqdata, $key) if !defined $val;
-  $val = ProjectNameHelpers::gp($data, $key) if !defined $val;
+  my $val = ProjectNameHelpers::gp($ctx->{reqmatch}, $key);
+  $val = ProjectNameHelpers::gp($ctx->{match}, $key) if !defined $val;
+  $val = ProjectNameHelpers::gp($ctx->{reqmatch}, $akey) if !defined $val && '' ne $akey;
+  $val = ProjectNameHelpers::gp($ctx->{reqdata}, $key) if !defined $val;
+  $val = ProjectNameHelpers::gp($ctx->{data}, $key) if !defined $val;
 
   if (!defined $val && '' ne $akey) {
-    $val = ProjectNameHelpers::gp($reqdata, $akey);
-    $val = ProjectNameHelpers::gp($data, $akey) if !defined $val;
+    $val = ProjectNameHelpers::gp($ctx->{reqdata}, $akey);
+    $val = ProjectNameHelpers::gp($ctx->{data}, $akey) if !defined $val;
   }
 
   return $val;
-};
+}
+
+# The arguments a point declares in one location, query or header, each with
+# the name it travels under and the value this call passes in its match or
+# else its data. Unlike a path parameter, the entity's stored match and data
+# never supply one.
+sub call_args {
+  my ($ctx, $kind) = @_;
+  my $defs = $ctx->{point} ? ProjectNameHelpers::gpath($ctx->{point}, "args.$kind") : undef;
+  return () unless Voxgig::Struct::islist($defs);
+  my @out;
+  for my $ad (@$defs) {
+    my $name = ProjectNameHelpers::gp($ad, 'name');
+    next unless defined $name && !ref $name && '' ne $name;
+    my $wire = ProjectNameHelpers::gp($ad, 'orig');
+    $wire = $name unless defined $wire && !ref $wire && '' ne $wire;
+    my $val = ProjectNameHelpers::gp($ctx->{reqmatch} || {}, $name);
+    $val = ProjectNameHelpers::gp($ctx->{reqdata} || {}, $name) unless defined $val;
+    push @out, [$name, $wire, $val];
+  }
+  return @out;
+}
 
 1;

package/project/.sdk/tm/perl/utility/prepare_body.pm

@@ -3,15 +3,23 @@
 use strict;
 use warnings;
 
+use File::Basename ();
+use Cwd ();
+
+my $__dir;
+BEGIN { $__dir = File::Basename::dirname(Cwd::abs_path(__FILE__)) }
+require(Cwd::abs_path("$__dir/media.pm"));
+
 package ProjectNameUtilities;
 
 our %REGISTRY;
 
 $REGISTRY{prepare_body} = sub {
   my ($ctx) = @_;
-  return ('data' eq $ctx->{op}{input})
-    ? $ctx->{utility}{transform_request}->($ctx)
-    : undef;
+  return undef unless 'data' eq $ctx->{op}{input};
+  return ProjectNameUtilities::raw_body($ctx->{reqdata})
+    if ProjectNameUtilities::is_raw_request($ctx->{point});
+  return $ctx->{utility}{transform_request}->($ctx);
 };
 
 1;

package/project/.sdk/tm/perl/utility/prepare_headers.pm

@@ -10,6 +10,8 @@ my $__dir;
 BEGIN { $__dir = File::Basename::dirname(Cwd::abs_path(__FILE__)) }
 require(Cwd::abs_path("$__dir/../lib/Voxgig/Struct.pm"));
 require(Cwd::abs_path("$__dir/../core/helpers.pm"));
+require(Cwd::abs_path("$__dir/param.pm"));
+require(Cwd::abs_path("$__dir/media.pm"));
 
 package ProjectNameUtilities;
 
@@ -21,25 +23,70 @@ $REGISTRY{prepare_headers} = sub {
   my $headers = ProjectNameHelpers::gp($options, 'headers');
   my $out = ProjectNameHelpers::rb_truthy($headers) ? Voxgig::Struct::clone($headers) : {};
   $out = {} unless Voxgig::Struct::ismap($out);
-  # A header parameter travels as a header, under the name the definition
-  # gives it, and only from this call's own arguments. It replaces a default
-  # of the same name, whatever its case.
-  my $hl = $ctx->{point} ? ProjectNameHelpers::gpath($ctx->{point}, 'args.header') : undef;
-  if (Voxgig::Struct::islist($hl)) {
-    for my $hd (@$hl) {
-      my $name = ProjectNameHelpers::gp($hd, 'name');
-      next unless defined $name && !ref $name && '' ne $name;
-      my $orig = ProjectNameHelpers::gp($hd, 'orig');
-      $orig = $name unless defined $orig && !ref $orig && '' ne $orig;
-      my $val = ProjectNameHelpers::gp($ctx->{reqmatch} || {}, $name);
-      $val = ProjectNameHelpers::gp($ctx->{reqdata} || {}, $name) unless defined $val;
-      next unless defined $val;
-      my $wire = lc $orig;
-      delete $out->{$_} for grep { lc $_ eq $wire } keys %$out;
-      $out->{$wire} = Voxgig::Struct::stringify($val);
+  $out = ProjectNameUtilities::media_headers($ctx->{point}, $out);
+  # A header argument replaces a default of the same name, whatever its case.
+  for my $arg (ProjectNameUtilities::call_args($ctx, 'header')) {
+    my (undef, $orig, $val) = @$arg;
+    next unless defined $val;
+    my $wire = lc $orig;
+    delete $out->{$_} for grep { lc $_ eq $wire } keys %$out;
+    $out->{$wire} = Voxgig::Struct::stringify($val);
+  }
+  # A cookie argument travels in the cookie header, form serialized and
+  # percent-encoded, replacing a cookie of the same name among those the
+  # caller's headers already send.
+  my @sent = grep { defined $_->[2] } ProjectNameUtilities::call_args($ctx, 'cookie');
+  if (@sent) {
+    my %names = map {
+      my $arg = $_;
+      map { ($_ => 1) } (Voxgig::Struct::ismap($arg->[2])
+        ? (map { Voxgig::Struct::escurl($_) } @{ Voxgig::Struct::keysof($arg->[2]) }) : ($arg->[1]));
+    } @sent;
+    my @kept;
+    for my $key (grep { lc $_ eq 'cookie' } keys %$out) {
+      my $given = delete $out->{$key};
+      next if !defined $given || ref $given;
+      push @kept, @{ cookie_keep($given, \%names) };
+    }
+    for my $arg (@sent) {
+      my $pair = ProjectNameUtilities::cookie_pair($arg->[1], $arg->[2]);
+      push @kept, $pair if $pair ne '';
     }
+    $out->{cookie} = join('; ', @kept) if @kept;
   }
   return $out;
 };
 
+# The caller's cookie pieces with the named cookies removed: a cookie is one
+# ;-delimited piece, whatever its value holds.
+sub cookie_keep {
+  my ($header, $names) = @_;
+  my @kept;
+  for my $piece (split /;/, $header) {
+    (my $cookie = $piece) =~ s/^\s+|\s+$//g;
+    next if $cookie eq '';
+    (my $name = (split /=/, $cookie, 2)[0]) =~ s/^\s+|\s+$//g;
+    push @kept, $cookie unless $names->{$name};
+  }
+  return \@kept;
+}
+
+# The form style of a cookie parameter: a list repeats the name, a map sends
+# its own keys, and every value is percent-encoded.
+sub cookie_pair {
+  my ($wire, $val) = @_;
+  my $esc = sub { Voxgig::Struct::escurl(Voxgig::Struct::stringify($_[0])) };
+  my @pairs;
+  if (Voxgig::Struct::islist($val)) {
+    @pairs = map { $wire . '=' . $esc->($_) } @$val;
+  }
+  elsif (Voxgig::Struct::ismap($val)) {
+    @pairs = map { Voxgig::Struct::escurl($_) . '=' . $esc->($val->{$_}) } @{ Voxgig::Struct::keysof($val) };
+  }
+  else {
+    @pairs = ($wire . '=' . $esc->($val));
+  }
+  return join('; ', @pairs);
+}
+
 1;

package/project/.sdk/tm/perl/utility/prepare_method.pm

@@ -44,4 +44,17 @@ $REGISTRY{prepare_method} = sub {
   return $METHOD_MAP{$opname};
 };
 
+# Whether a comma-separated allow option names the item: whole names, any case.
+sub allowed {
+  my ($names, $item) = @_;
+  return 0 unless defined $item && !ref $item && '' ne $item;
+  return 0 unless defined $names && !ref $names;
+  my $want = uc $item;
+  for my $name (split /,/, $names) {
+    (my $trimmed = $name) =~ s/^\s+|\s+$//g;
+    return 1 if uc($trimmed) eq $want;
+  }
+  return 0;
+}
+
 1;

package/project/.sdk/tm/perl/utility/prepare_query.pm

@@ -10,6 +10,7 @@ my $__dir;
 BEGIN { $__dir = File::Basename::dirname(Cwd::abs_path(__FILE__)) }
 require(Cwd::abs_path("$__dir/../lib/Voxgig/Struct.pm"));
 require(Cwd::abs_path("$__dir/../core/helpers.pm"));
+require(Cwd::abs_path("$__dir/param.pm"));
 
 package ProjectNameUtilities;
 
@@ -32,12 +33,18 @@ $REGISTRY{prepare_query} = sub {
         push @$params, $name if defined $name && !ref $name;
       }
     }
-    # A header parameter travels in the headers, which prepare_headers fills.
-    my $hl = ProjectNameHelpers::gpath($point, 'args.header');
-    if (Voxgig::Struct::islist($hl)) {
+    # A header or cookie parameter travels in the headers, which prepare_headers
+    # fills, unless a query parameter shares its name: then both are sent.
+    my $ql = ProjectNameHelpers::gpath($point, 'args.query');
+    my %declared = Voxgig::Struct::islist($ql)
+      ? map { my $n = ProjectNameHelpers::gp($_, 'name'); defined $n && !ref $n ? ($n => 1) : () } @$ql
+      : ();
+    for my $hl (ProjectNameHelpers::gpath($point, 'args.header'),
+      ProjectNameHelpers::gpath($point, 'args.cookie')) {
+      next unless Voxgig::Struct::islist($hl);
       for my $hd (@$hl) {
         my $name = ProjectNameHelpers::gp($hd, 'name');
-        push @$params, $name if defined $name && !ref $name;
+        push @$params, $name if defined $name && !ref $name && !$declared{$name};
       }
     }
   }
@@ -66,6 +73,13 @@ $REGISTRY{prepare_query} = sub {
       $out->{exists $wire{$key} ? $wire{$key} : $key} = $val;
     }
   }
+  # A create or update passes its query arguments in its data.
+  for my $arg (ProjectNameUtilities::call_args($ctx, 'query')) {
+    my ($name, $orig, $val) = @$arg;
+    next unless defined $val;
+    next if grep { defined $_ && !ref $_ && $_ eq $name } @$params;
+    $out->{$orig} = $val;
+  }
   return $out;
 };
 

package/project/.sdk/tm/perl/utility/result_body.pm

@@ -5,6 +5,7 @@ use warnings;
 
 use File::Basename ();
 use Cwd ();
+use Scalar::Util ();
 
 my $__dir;
 BEGIN { $__dir = File::Basename::dirname(Cwd::abs_path(__FILE__)) }
@@ -22,7 +23,66 @@ $REGISTRY{result_body} = sub {
     && ProjectNameHelpers::rb_truthy($response->{body})) {
     $result->{body} = $response->{json_func}->();
   }
+  if ($result && $response && $response->{unreadable}) {
+    my $sent = $ctx->{spec} ? $ctx->{spec}{headers} : undef;
+    $result->{err} = unreadable_body($ctx, $result->{status}, $result->{headers},
+      $response->{body}, $sent, $result->{err});
+  }
   return $result;
 };
 
+use constant BODY_PREVIEW_LENGTH => 160;
+
+# A body that is not JSON. An HTTP failure keeps its own error, with the
+# response described; otherwise the code tells a wrong content type from
+# malformed JSON.
+sub unreadable_body {
+  my ($ctx, $status, $headers, $text, $sent, $failed) = @_;
+  my $type = _body_header($headers, 'content-type');
+  my $agent = $ctx->{utility}{clean}->($ctx, _body_header($sent, 'user-agent'));
+  $agent = 'transport default' unless defined $agent && length $agent;
+  my $detail = 'HTTP ' . (defined $status ? $status : -1) . ', content-type '
+    . (length $type ? $type : 'none') . ", user-agent $agent";
+  $detail .= ', body: ' . _body_preview($ctx, $text) if defined $text;
+
+  if (defined $failed) {
+    if (Scalar::Util::blessed($failed) && 'HASH' eq Scalar::Util::reftype($failed)
+      && exists $failed->{msg}) {
+      $failed->{msg} .= " ($detail)";
+      return $failed;
+    }
+    return "$failed ($detail)";
+  }
+
+  if (!length $type || $type =~ /json/i) {
+    return $ctx->make_error('response_json_invalid',
+      "response: body is not valid JSON ($detail)");
+  }
+  return $ctx->make_error('response_content_type',
+    "response: expected JSON, got $type ($detail)");
+}
+
+sub _body_header {
+  my ($headers, $name) = @_;
+  return '' unless Voxgig::Struct::ismap($headers);
+  for my $k (keys %$headers) {
+    next unless lc("$k") eq $name;
+    return defined $headers->{$k} ? "$headers->{$k}" : '';
+  }
+  return '';
+}
+
+# Cleaned whole: a secret the bound would split could leave its prefix.
+sub _body_preview {
+  my ($ctx, $text) = @_;
+  my $flat = "$text";
+  utf8::decode($flat);
+  $flat =~ s/\s+/ /g;
+  $flat =~ s/^ | $//g;
+  $flat = $ctx->{utility}{clean}->($ctx, $flat);
+  $flat = defined $flat ? "$flat" : '';
+  return length($flat) > BODY_PREVIEW_LENGTH
+    ? substr($flat, 0, BODY_PREVIEW_LENGTH) . '...' : $flat;
+}
+
 1;