All new accounts created on Gitlab now require administrator approval. If you invite any collaborators, please let Flux staff know so they can approve the accounts.

Commit 5756edfb authored by Russ Fish's avatar Russ Fish

Sync copies of the xmlfields code, before I forget why they're different.

parent 24ffb396
......@@ -168,7 +168,8 @@ my %errors = ();
#
# Make sure all the required arguments were provided.
#
foreach my $key (keys(%xmlfields)) {
my $key;
foreach $key (keys(%xmlfields)) {
my (undef, $required, undef) = @{$xmlfields{$key}};
$errors{$key} = "Required value not provided"
......@@ -184,20 +185,60 @@ UserError()
#
my %editexp_args = ();
foreach my $key (keys(%{ $xmlparse->{'attribute'} })) {
#
# Wildcard keys have one or more *'s in them like simple glob patterns.
# This allows multiple key instances for categories of attributes, and
# putting a "type signature" in the key for arg checking, as well.
#
# Wildcards are made into regex's by anchoring the ends and changing each * to
# a "word" (group of alphahumeric.) A tail * means "the rest", allowing
# multiple words separated by underscores or dashes.
#
my $wordpat = '[a-zA-Z0-9]+';
my $tailpat = '[-\w]+';
my %wildcards;
foreach $key (keys(%xmlfields)) {
if (index($key, "*") >= 0) {
my $regex = '^' . $key . '$';
$regex =~ s/\*\$$/$tailpat/;
$regex =~ s/\*/$wordpat/g;
$wildcards{$key} = $regex;
}
}
# Key ordering is lost in a hash.
# Put longer matching wildcard keys before their prefix.
my @wildkeys = reverse(sort(keys(%wildcards)));
foreach $key (keys(%{ $xmlparse->{'attribute'} })) {
my $value = $xmlparse->{'attribute'}->{"$key"}->{'value'};
if (!defined($value)) { # Empty string comes from XML as an undef value.
$xmlparse->{'attribute'}->{"$key"}->{'value'} = $value = "";
}
if ($debug) {
print STDERR "User attribute: '$key' -> '$value'\n";
print STDERR "User attribute: '$key' -> '$value'\n"
if ($debug);
my $field = $key;
my $wild;
if (!exists($xmlfields{$key})) {
# Not a regular key; look for a wildcard regex match.
foreach my $wildkey (@wildkeys) {
my $regex = $wildcards{$wildkey};
if ($wild = $key =~ /$regex/) {
$field = $wildkey;
print STDERR "Wildcard: '$key' matches '$wildkey'\n"
if ($debug);
last; # foreach $wildkey
}
}
if (!$wild) {
$errors{$key} = "Unknown attribute";
next; # foreach $key
}
}
$errors{$key} = "Unknown attribute"
if (!exists($xmlfields{$key}));
my ($dbslot, $required, $default) = @{$xmlfields{$key}};
my ($dbslot, $required, $default) = @{$xmlfields{$field}};
if ($required & $SLOT_REQUIRED) {
# A slot that must be provided, so do not allow a null value.
......@@ -228,7 +269,7 @@ foreach my $key (keys(%{ $xmlparse->{'attribute'} })) {
next;
}
$editexp_args{$dbslot} = $value;
$editexp_args{$key} = $value;
}
UserError()
if (keys(%errors));
......@@ -238,7 +279,7 @@ UserError()
#
my $doemail = 0;
my $experiment = Experiment->Lookup($editexp_args{"eid_idx"});
my $experiment = Experiment->Lookup($editexp_args{"experiment"});
if (!defined($experiment)) {
UserError("Experiment: No such experiment");
}
......
......@@ -128,8 +128,15 @@ my $SLOT_ADMINONLY = 0x4; # Only admins can set this field.
#
my %xmlfields =
# XML Field Name DB slot name Flags Default
("group" => ["gid_idx", $SLOT_REQUIRED]);
# And also trust args, see below.
("group" => ["gid_idx", $SLOT_REQUIRED],
# Trust args, either:
# (change|add)_xxx=permit or
# Uxxx$$trust=(user|local_root|group_root)
# where xxx is the uid_idx of a user.
"change_*" => ["change", $SLOT_OPTIONAL],
"add_*" => ["add", $SLOT_OPTIONAL],
"U*\\\$\\\$trust" => ["trust", $SLOT_OPTIONAL]);
#
# Must wrap the parser in eval since it exits on error.
......@@ -168,36 +175,60 @@ UserError()
#
my %editgroup_args = ();
#
# Wildcard keys have one or more *'s in them like simple glob patterns.
# This allows multiple key instances for categories of attributes, and
# putting a "type signature" in the key for arg checking, as well.
#
# Wildcards are made into regex's by anchoring the ends and changing each * to
# a "word" (group of alphahumeric.) A tail * means "the rest", allowing
# multiple words separated by underscores or dashes.
#
my $wordpat = '[a-zA-Z0-9]+';
my $tailpat = '[-\w]+';
my %wildcards;
foreach $key (keys(%xmlfields)) {
if (index($key, "*") >= 0) {
my $regex = '^' . $key . '$';
$regex =~ s/\*\$$/$tailpat/;
$regex =~ s/\*/$wordpat/g;
$wildcards{$key} = $regex;
}
}
# Key ordering is lost in a hash.
# Put longer matching wildcard keys before their prefix.
my @wildkeys = reverse(sort(keys(%wildcards)));
foreach $key (keys(%{ $xmlparse->{'attribute'} })) {
my $value = $xmlparse->{'attribute'}->{"$key"}->{'value'};
if (!defined($value)) { # Empty string comes from XML as an undef value.
$xmlparse->{'attribute'}->{"$key"}->{'value'} = $value = "";
}
if ($debug) {
print STDERR "User attribute: '$key' -> '$value'\n";
}
# XXX Special for trust args. Either:
# (change|add)_xxx=permit or
# Uxxx$$trust=(user|(local|group)_root)
# where xxx is the uid_idx of a user.
if (($key =~ /^(change|add)_[0-9]+$/ &&
$value eq "permit") ||
($key =~ /^U[0-9]+\$\$trust$/ &&
$value =~ /^(user|(local|group)_root)$/)) {
if ($debug) {
print STDERR "Trust: '$key' -> '$value'\n";
print STDERR "User attribute: '$key' -> '$value'\n"
if ($debug);
my $field = $key;
my $wild;
if (!exists($xmlfields{$key})) {
# Not a regular key; look for a wildcard regex match.
foreach my $wildkey (@wildkeys) {
my $regex = $wildcards{$wildkey};
if ($wild = $key =~ /$regex/) {
$field = $wildkey;
print STDERR "Wildcard: '$key' matches '$wildkey'\n"
if ($debug);
last; # foreach $wildkey
}
}
if (!$wild) {
$errors{$key} = "Unknown attribute";
next; # foreach $key
}
$editgroup_args{$key} = $value;
next;
}
$errors{$key} = "Unknown attribute"
if (!exists($xmlfields{$key}));
my ($dbslot, $required, $default) = @{$xmlfields{$key}};
my ($dbslot, $required, $default) = @{$xmlfields{$field}};
if ($required & $SLOT_REQUIRED) {
# A slot that must be provided, so do not allow a null value.
......@@ -222,12 +253,13 @@ foreach $key (keys(%{ $xmlparse->{'attribute'} })) {
}
# Now check that the value is legal.
if (! TBcheck_dbslot($value, "groups", $dbslot, TBDB_CHECKDBSLOT_ERROR)) {
if (! TBcheck_dbslot($value, "groups",
$dbslot, TBDB_CHECKDBSLOT_ERROR)) {
$errors{$key} = TBFieldErrorString();
next;
}
$editgroup_args{$dbslot} = $value;
$editgroup_args{$key} = $value;
}
UserError()
if (keys(%errors));
......@@ -235,7 +267,7 @@ UserError()
#
# Now do special checks.
#
my $group = Group->Lookup($editgroup_args{"gid_idx"});
my $group = Group->Lookup($editgroup_args{"group"});
if (!defined($group)) {
UserError("Group: No such group");
}
......@@ -254,7 +286,7 @@ exit(0)
# We pass the group along as an argument to EditGroup(), so remove it from
# the argument array.
#
delete($editgroup_args{"gid_idx"});
delete($editgroup_args{"group"});
my $usrerr;
my $editgroup_val = Group->EditGroup($group, $this_user,
......
......@@ -138,9 +138,9 @@ my %xmlfields =
# The rest are optional, so we can skip passing ones that are not changing.
"description" => ["description", $SLOT_OPTIONAL],
"path" => ["path", $SLOT_OPTIONAL],
"mtype_*" => ["mtype", $SLOT_OPTIONAL],
"load_address" => ["load_address", $SLOT_ADMINONLY],
"frisbee_pid" => ["frisbee_pid", $SLOT_ADMINONLY]);
# The "mtype_$type" node type booleans are handled below...
#
# Need a list of node types. We join this over the nodes table so that
# we get a list of just the nodes that are currently in the testbed, not
......@@ -199,38 +199,60 @@ UserError()
my %editimageid_args = ();
my $foo;
#
# Wildcard keys have one or more *'s in them like simple glob patterns.
# This allows multiple key instances for categories of attributes, and
# putting a "type signature" in the key for arg checking, as well.
#
# Wildcards are made into regex's by anchoring the ends and changing each * to
# a "word" (group of alphahumeric.) A tail * means "the rest", allowing
# multiple words separated by underscores or dashes.
#
my $wordpat = '[a-zA-Z0-9]+';
my $tailpat = '[-\w]+';
my %wildcards;
foreach $key (keys(%xmlfields)) {
if (index($key, "*") >= 0) {
my $regex = '^' . $key . '$';
$regex =~ s/\*\$$/$tailpat/;
$regex =~ s/\*/$wordpat/g;
$wildcards{$key} = $regex;
}
}
# Key ordering is lost in a hash.
# Put longer matching wildcard keys before their prefix.
my @wildkeys = reverse(sort(keys(%wildcards)));
foreach $key (keys(%{ $xmlparse->{'attribute'} })) {
my $value = $xmlparse->{'attribute'}->{"$key"}->{'value'};
if (!defined($value)) { # Empty string comes from XML as an undef value.
$xmlparse->{'attribute'}->{"$key"}->{'value'} = $value = "";
}
if ($debug) {
print STDERR "User attribute: '$key' -> '$value'\n";
}
# XXX Special for mtype_* args, since the keys are dynamically generated.
if ($key =~ /^mtype_[\w]+$/) {
print STDERR "mtype: '$key' -> '$value'\n"
if ($debug);
my $type = $key;
$type =~ s/^mtype_//;
my $match = grep(/^${type}$/, @mtypes_array);
$errors{$key} = "Illegal node type."
if ($match == 0);
$errors{$key} = "Illegal characters in boolean value"
if ($value ne "0" && $value ne "1");
$editimageid_args{$key} = $value;
next;
print STDERR "User attribute: '$key' -> '$value'\n"
if ($debug);
my $field = $key;
my $wild;
if (!exists($xmlfields{$key})) {
# Not a regular key; look for a wildcard regex match.
foreach my $wildkey (@wildkeys) {
my $regex = $wildcards{$wildkey};
if ($wild = $key =~ /$regex/) {
$field = $wildkey;
print STDERR "Wildcard: '$key' matches '$wildkey'\n"
if ($debug);
last; # foreach $wildkey
}
}
if (!$wild) {
$errors{$key} = "Unknown attribute";
next; # foreach $key
}
}
$errors{$key} = "Unknown attribute"
if (!exists($xmlfields{$key}));
my ($dbslot, $required, $default) = @{$xmlfields{$key}};
my ($dbslot, $required, $default) = @{$xmlfields{$field}};
if ($required & $SLOT_REQUIRED) {
# A slot that must be provided, so do not allow a null value.
......@@ -255,12 +277,13 @@ foreach $key (keys(%{ $xmlparse->{'attribute'} })) {
}
# Now check that the value is legal.
if (! TBcheck_dbslot($value, "images", $dbslot, TBDB_CHECKDBSLOT_ERROR)) {
if (! TBcheck_dbslot($value, "images",
$dbslot, TBDB_CHECKDBSLOT_ERROR)) {
$errors{$key} = TBFieldErrorString();
next;
}
$editimageid_args{$dbslot} = $value;
$editimageid_args{$key} = $value;
}
UserError()
if (keys(%errors));
......@@ -320,11 +343,32 @@ if (!$isadmin && exists($editimageid_args{"path"})) {
#
# See what node types this image will work on. Must be at least one!
if ($#mtypes_array < 0) {
UserError("Node Types: Must have at least one node type");
}
#
UserError("Node Types: Must have at least one node type")
if ($#mtypes_array < 0);
my $typeclause = join(" or ", map("type='$_'", @mtypes_array));
# Check validity of mtype_* args, since the keys are dynamically generated.
my $node_types_selected = 0;
my @mtype_keys = grep(/^mtype_/, keys(%editimageid_args));
foreach $key (@mtype_keys) {
my $value = $editimageid_args{$key};
print STDERR "mtype: '$key' -> '$value'\n"
if ($debug);
my $type = $key;
$type =~ s/^mtype_//;
my $match = grep(/^${type}$/, @mtypes_array);
if ($match == 0) {
$errors{$key} = "Illegal node type."
}
elsif ($value eq "1") {
$node_types_selected++;
}
}
UserError("Node Types: Must select at least one node type")
if ($node_types_selected == 0);
#
# Only admins can edit the load_address or the frisbee pid.
#
......
......@@ -278,7 +278,8 @@ foreach $key (keys(%{ $xmlparse->{'attribute'} })) {
}
# Now check that the value is legal.
if (! TBcheck_dbslot($value, "node_types", $dbslot, TBDB_CHECKDBSLOT_ERROR)) {
if (! TBcheck_dbslot($value, "node_types",
$dbslot, TBDB_CHECKDBSLOT_ERROR)) {
$errors{$key} = TBFieldErrorString();
next;
}
......
......@@ -171,20 +171,60 @@ UserError()
#
my %editsitevars_args = ();
#
# Wildcard keys have one or more *'s in them like simple glob patterns.
# This allows multiple key instances for categories of attributes, and
# putting a "type signature" in the key for arg checking, as well.
#
# Wildcards are made into regex's by anchoring the ends and changing each * to
# a "word" (group of alphahumeric.) A tail * means "the rest", allowing
# multiple words separated by underscores or dashes.
#
my $wordpat = '[a-zA-Z0-9]+';
my $tailpat = '[-\w]+';
my %wildcards;
foreach $key (keys(%xmlfields)) {
if (index($key, "*") >= 0) {
my $regex = '^' . $key . '$';
$regex =~ s/\*\$$/$tailpat/;
$regex =~ s/\*/$wordpat/g;
$wildcards{$key} = $regex;
}
}
# Key ordering is lost in a hash.
# Put longer matching wildcard keys before their prefix.
my @wildkeys = reverse(sort(keys(%wildcards)));
foreach $key (keys(%{ $xmlparse->{'attribute'} })) {
my $value = $xmlparse->{'attribute'}->{"$key"}->{'value'};
if (!defined($value)) { # Empty string comes from XML as an undef value.
$xmlparse->{'attribute'}->{"$key"}->{'value'} = $value = "";
}
if ($debug) {
print STDERR "User attribute: '$key' -> '$value'\n";
print STDERR "User attribute: '$key' -> '$value'\n"
if ($debug);
my $field = $key;
my $wild;
if (!exists($xmlfields{$key})) {
# Not a regular key; look for a wildcard regex match.
foreach my $wildkey (@wildkeys) {
my $regex = $wildcards{$wildkey};
if ($wild = $key =~ /$regex/) {
$field = $wildkey;
print STDERR "Wildcard: '$key' matches '$wildkey'\n"
if ($debug);
last; # foreach $wildkey
}
}
if (!$wild) {
$errors{$key} = "Unknown attribute";
next; # foreach $key
}
}
$errors{$key} = "Unknown attribute"
if (!exists($xmlfields{$key}));
my ($dbslot, $required, $default) = @{$xmlfields{$key}};
my ($dbslot, $required, $default) = @{$xmlfields{$field}};
if ($required & $SLOT_REQUIRED) {
# A slot that must be provided, so do not allow a null value.
......@@ -209,13 +249,13 @@ foreach $key (keys(%{ $xmlparse->{'attribute'} })) {
}
# Now check that the value is legal.
if (! TBcheck_dbslot($value, "sitevariables",
if (! TBcheck_dbslot($value, "sitevariables",
$dbslot, TBDB_CHECKDBSLOT_ERROR)) {
$errors{$key} = TBFieldErrorString();
next;
}
$editsitevars_args{$dbslot} = $value;
$editsitevars_args{$key} = $value;
}
UserError()
if (keys(%errors));
......
......@@ -152,6 +152,7 @@ my %xmlfields =
"w_password2" => ["w_password2", $SLOT_OPTIONAL],
"user_interface" => ["user_interface", $SLOT_OPTIONAL],
"notes" => ["notes", $SLOT_OPTIONAL]);
#
# Must wrap the parser in eval since it exits on error.
#
......@@ -172,7 +173,8 @@ my %errors = ();
#
# Make sure all the required arguments were provided.
#
foreach my $key (keys(%xmlfields)) {
my $key;
foreach $key (keys(%xmlfields)) {
my (undef, $required, undef) = @{$xmlfields{$key}};
$errors{$key} = "Required value not provided"
......@@ -188,20 +190,60 @@ UserError()
#
my %moduserinfo_args = ();
foreach my $key (keys(%{ $xmlparse->{'attribute'} })) {
#
# Wildcard keys have one or more *'s in them like simple glob patterns.
# This allows multiple key instances for categories of attributes, and
# putting a "type signature" in the key for arg checking, as well.
#
# Wildcards are made into regex's by anchoring the ends and changing each * to
# a "word" (group of alphahumeric.) A tail * means "the rest", allowing
# multiple words separated by underscores or dashes.
#
my $wordpat = '[a-zA-Z0-9]+';
my $tailpat = '[-\w]+';
my %wildcards;
foreach $key (keys(%xmlfields)) {
if (index($key, "*") >= 0) {
my $regex = '^' . $key . '$';
$regex =~ s/\*\$$/$tailpat/;
$regex =~ s/\*/$wordpat/g;
$wildcards{$key} = $regex;
}
}
# Key ordering is lost in a hash.
# Put longer matching wildcard keys before their prefix.
my @wildkeys = reverse(sort(keys(%wildcards)));
foreach $key (keys(%{ $xmlparse->{'attribute'} })) {
my $value = $xmlparse->{'attribute'}->{"$key"}->{'value'};
if (!defined($value)) { # Empty string comes from XML as an undef value.
$xmlparse->{'attribute'}->{"$key"}->{'value'} = $value = "";
}
if ($debug) {
print STDERR "User attribute: '$key' -> '$value'\n";
print STDERR "User attribute: '$key' -> '$value'\n"
if ($debug);
my $field = $key;
my $wild;
if (!exists($xmlfields{$key})) {
# Not a regular key; look for a wildcard regex match.
foreach my $wildkey (@wildkeys) {
my $regex = $wildcards{$wildkey};
if ($wild = $key =~ /$regex/) {
$field = $wildkey;
print STDERR "Wildcard: '$key' matches '$wildkey'\n"
if ($debug);
last; # foreach $wildkey
}
}
if (!$wild) {
$errors{$key} = "Unknown attribute";
next; # foreach $key
}
}
$errors{$key} = "Unknown attribute"
if (!exists($xmlfields{$key}));
my ($dbslot, $required, $default) = @{$xmlfields{$key}};
my ($dbslot, $required, $default) = @{$xmlfields{$field}};
if ($required & $SLOT_REQUIRED) {
# A slot that must be provided, so do not allow a null value.
......@@ -226,7 +268,8 @@ foreach my $key (keys(%{ $xmlparse->{'attribute'} })) {
}
# Now check that the value is legal.
if (! TBcheck_dbslot($value, "users", $dbslot, TBDB_CHECKDBSLOT_ERROR)) {
if (! TBcheck_dbslot($value, "users",
$dbslot, TBDB_CHECKDBSLOT_ERROR)) {
$errors{$key} = TBFieldErrorString();
next;
}
......
......@@ -155,7 +155,8 @@ my %errors = ();
#
# Make sure all the required arguments were provided.
#
foreach my $key (keys(%xmlfields)) {
my $key;
foreach $key (keys(%xmlfields)) {
my (undef, $required, undef) = @{$xmlfields{$key}};
$errors{$key} = "Required value not provided"
......@@ -171,20 +172,60 @@ UserError()
#
my %newgroup_args = ();
foreach my $key (keys(%{ $xmlparse->{'attribute'} })) {
#
# Wildcard keys have one or more *'s in them like simple glob patterns.
# This allows multiple key instances for categories of attributes, and
# putting a "type signature" in the key for arg checking, as well.
#
# Wildcards are made into regex's by anchoring the ends and changing each * to
# a "word" (group of alphahumeric.) A tail * means "the rest", allowing
# multiple words separated by underscores or dashes.
#
my $wordpat = '[a-zA-Z0-9]+';
my $tailpat = '[-\w]+';
my %wildcards;
foreach $key (keys(%xmlfields)) {
if (index($key, "*") >= 0) {
my $regex = '^' . $key . '$';
$regex =~ s/\*\$$/$tailpat/;
$regex =~ s/\*/$wordpat/g;
$wildcards{$key} = $regex;
}
}
# Key ordering is lost in a hash.
# Put longer matching wildcard keys before their prefix.
my @wildkeys = reverse(sort(keys(%wildcards)));
foreach $key (keys(%{ $xmlparse->{'attribute'} })) {
my $value = $xmlparse->{'attribute'}->{"$key"}->{'value'};
if (!defined($value)) { # Empty string comes from XML as an undef value.
$xmlparse->{'attribute'}->{"$key"}->{'value'} = $value = "";
}
if ($debug) {
print STDERR "User attribute: '$key' -> '$value'\n";
print STDERR "User attribute: '$key' -> '$value'\n"
if ($debug);
my $field = $key;
my $wild;
if (!exists($xmlfields{$key})) {
# Not a regular key; look for a wildcard regex match.
foreach my $wildkey (@wildkeys) {
my $regex = $wildcards{$wildkey};
if ($wild = $key =~ /$regex/) {
$field = $wildkey;
print STDERR "Wildcard: '$key' matches '$wildkey'\n"
if ($debug);
last; # foreach $wildkey
}
}
if (!$wild) {
$errors{$key} = "Unknown attribute";
next; # foreach $key
}
}
$errors{$key} = "Unknown attribute"
if (!exists($xmlfields{$key}));
my ($dbslot, $required, $default) = @{$xmlfields{$key}};
my ($dbslot, $required, $default) = @{$xmlfields{$field}};
if ($required & $SLOT_REQUIRED) {