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 = (); ...@@ -168,7 +168,8 @@ my %errors = ();
# #
# Make sure all the required arguments were provided. # 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}}; my (undef, $required, undef) = @{$xmlfields{$key}};
$errors{$key} = "Required value not provided" $errors{$key} = "Required value not provided"
...@@ -184,20 +185,60 @@ UserError() ...@@ -184,20 +185,60 @@ UserError()
# #
my %editexp_args = (); 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'}; my $value = $xmlparse->{'attribute'}->{"$key"}->{'value'};
if (!defined($value)) { # Empty string comes from XML as an undef value. if (!defined($value)) { # Empty string comes from XML as an undef value.
$xmlparse->{'attribute'}->{"$key"}->{'value'} = $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" my ($dbslot, $required, $default) = @{$xmlfields{$field}};
if (!exists($xmlfields{$key}));
my ($dbslot, $required, $default) = @{$xmlfields{$key}};
if ($required & $SLOT_REQUIRED) { if ($required & $SLOT_REQUIRED) {
# A slot that must be provided, so do not allow a null value. # A slot that must be provided, so do not allow a null value.
...@@ -228,7 +269,7 @@ foreach my $key (keys(%{ $xmlparse->{'attribute'} })) { ...@@ -228,7 +269,7 @@ foreach my $key (keys(%{ $xmlparse->{'attribute'} })) {
next; next;
} }
$editexp_args{$dbslot} = $value; $editexp_args{$key} = $value;
} }
UserError() UserError()
if (keys(%errors)); if (keys(%errors));
...@@ -238,7 +279,7 @@ UserError() ...@@ -238,7 +279,7 @@ UserError()
# #
my $doemail = 0; my $doemail = 0;
my $experiment = Experiment->Lookup($editexp_args{"eid_idx"}); my $experiment = Experiment->Lookup($editexp_args{"experiment"});
if (!defined($experiment)) { if (!defined($experiment)) {
UserError("Experiment: No such experiment"); UserError("Experiment: No such experiment");
} }
......
...@@ -128,8 +128,15 @@ my $SLOT_ADMINONLY = 0x4; # Only admins can set this field. ...@@ -128,8 +128,15 @@ my $SLOT_ADMINONLY = 0x4; # Only admins can set this field.
# #
my %xmlfields = my %xmlfields =
# XML Field Name DB slot name Flags Default # XML Field Name DB slot name Flags Default
("group" => ["gid_idx", $SLOT_REQUIRED]); ("group" => ["gid_idx", $SLOT_REQUIRED],
# And also trust args, see below.
# 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. # Must wrap the parser in eval since it exits on error.
...@@ -168,36 +175,60 @@ UserError() ...@@ -168,36 +175,60 @@ UserError()
# #
my %editgroup_args = (); 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'} })) { foreach $key (keys(%{ $xmlparse->{'attribute'} })) {
my $value = $xmlparse->{'attribute'}->{"$key"}->{'value'}; my $value = $xmlparse->{'attribute'}->{"$key"}->{'value'};
if (!defined($value)) { # Empty string comes from XML as an undef value. if (!defined($value)) { # Empty string comes from XML as an undef value.
$xmlparse->{'attribute'}->{"$key"}->{'value'} = $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;
# XXX Special for trust args. Either: my $wild;
# (change|add)_xxx=permit or if (!exists($xmlfields{$key})) {
# Uxxx$$trust=(user|(local|group)_root)
# where xxx is the uid_idx of a user. # Not a regular key; look for a wildcard regex match.
if (($key =~ /^(change|add)_[0-9]+$/ && foreach my $wildkey (@wildkeys) {
$value eq "permit") || my $regex = $wildcards{$wildkey};
($key =~ /^U[0-9]+\$\$trust$/ && if ($wild = $key =~ /$regex/) {
$value =~ /^(user|(local|group)_root)$/)) { $field = $wildkey;
print STDERR "Wildcard: '$key' matches '$wildkey'\n"
if ($debug) { if ($debug);
print STDERR "Trust: '$key' -> '$value'\n"; last; # foreach $wildkey
}
}
if (!$wild) {
$errors{$key} = "Unknown attribute";
next; # foreach $key
} }
$editgroup_args{$key} = $value;
next;
} }
$errors{$key} = "Unknown attribute" my ($dbslot, $required, $default) = @{$xmlfields{$field}};
if (!exists($xmlfields{$key}));
my ($dbslot, $required, $default) = @{$xmlfields{$key}};
if ($required & $SLOT_REQUIRED) { if ($required & $SLOT_REQUIRED) {
# A slot that must be provided, so do not allow a null value. # A slot that must be provided, so do not allow a null value.
...@@ -222,12 +253,13 @@ foreach $key (keys(%{ $xmlparse->{'attribute'} })) { ...@@ -222,12 +253,13 @@ foreach $key (keys(%{ $xmlparse->{'attribute'} })) {
} }
# Now check that the value is legal. # 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(); $errors{$key} = TBFieldErrorString();
next; next;
} }
$editgroup_args{$dbslot} = $value; $editgroup_args{$key} = $value;
} }
UserError() UserError()
if (keys(%errors)); if (keys(%errors));
...@@ -235,7 +267,7 @@ UserError() ...@@ -235,7 +267,7 @@ UserError()
# #
# Now do special checks. # Now do special checks.
# #
my $group = Group->Lookup($editgroup_args{"gid_idx"}); my $group = Group->Lookup($editgroup_args{"group"});
if (!defined($group)) { if (!defined($group)) {
UserError("Group: No such group"); UserError("Group: No such group");
} }
...@@ -254,7 +286,7 @@ exit(0) ...@@ -254,7 +286,7 @@ exit(0)
# We pass the group along as an argument to EditGroup(), so remove it from # We pass the group along as an argument to EditGroup(), so remove it from
# the argument array. # the argument array.
# #
delete($editgroup_args{"gid_idx"}); delete($editgroup_args{"group"});
my $usrerr; my $usrerr;
my $editgroup_val = Group->EditGroup($group, $this_user, my $editgroup_val = Group->EditGroup($group, $this_user,
......
...@@ -138,9 +138,9 @@ my %xmlfields = ...@@ -138,9 +138,9 @@ my %xmlfields =
# The rest are optional, so we can skip passing ones that are not changing. # The rest are optional, so we can skip passing ones that are not changing.
"description" => ["description", $SLOT_OPTIONAL], "description" => ["description", $SLOT_OPTIONAL],
"path" => ["path", $SLOT_OPTIONAL], "path" => ["path", $SLOT_OPTIONAL],
"mtype_*" => ["mtype", $SLOT_OPTIONAL],
"load_address" => ["load_address", $SLOT_ADMINONLY], "load_address" => ["load_address", $SLOT_ADMINONLY],
"frisbee_pid" => ["frisbee_pid", $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 # 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 # we get a list of just the nodes that are currently in the testbed, not
...@@ -199,38 +199,60 @@ UserError() ...@@ -199,38 +199,60 @@ UserError()
my %editimageid_args = (); my %editimageid_args = ();
my $foo; 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'} })) { foreach $key (keys(%{ $xmlparse->{'attribute'} })) {
my $value = $xmlparse->{'attribute'}->{"$key"}->{'value'}; my $value = $xmlparse->{'attribute'}->{"$key"}->{'value'};
if (!defined($value)) { # Empty string comes from XML as an undef value. if (!defined($value)) { # Empty string comes from XML as an undef value.
$xmlparse->{'attribute'}->{"$key"}->{'value'} = $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;
# XXX Special for mtype_* args, since the keys are dynamically generated. my $wild;
if ($key =~ /^mtype_[\w]+$/) { if (!exists($xmlfields{$key})) {
print STDERR "mtype: '$key' -> '$value'\n"
if ($debug); # Not a regular key; look for a wildcard regex match.
foreach my $wildkey (@wildkeys) {
my $type = $key; my $regex = $wildcards{$wildkey};
$type =~ s/^mtype_//; if ($wild = $key =~ /$regex/) {
my $match = grep(/^${type}$/, @mtypes_array); $field = $wildkey;
$errors{$key} = "Illegal node type." print STDERR "Wildcard: '$key' matches '$wildkey'\n"
if ($match == 0); if ($debug);
last; # foreach $wildkey
$errors{$key} = "Illegal characters in boolean value" }
if ($value ne "0" && $value ne "1"); }
if (!$wild) {
$editimageid_args{$key} = $value; $errors{$key} = "Unknown attribute";
next; next; # foreach $key
}
} }
$errors{$key} = "Unknown attribute" my ($dbslot, $required, $default) = @{$xmlfields{$field}};
if (!exists($xmlfields{$key}));
my ($dbslot, $required, $default) = @{$xmlfields{$key}};
if ($required & $SLOT_REQUIRED) { if ($required & $SLOT_REQUIRED) {
# A slot that must be provided, so do not allow a null value. # A slot that must be provided, so do not allow a null value.
...@@ -255,12 +277,13 @@ foreach $key (keys(%{ $xmlparse->{'attribute'} })) { ...@@ -255,12 +277,13 @@ foreach $key (keys(%{ $xmlparse->{'attribute'} })) {
} }
# Now check that the value is legal. # 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(); $errors{$key} = TBFieldErrorString();
next; next;
} }
$editimageid_args{$dbslot} = $value; $editimageid_args{$key} = $value;
} }
UserError() UserError()
if (keys(%errors)); if (keys(%errors));
...@@ -320,11 +343,32 @@ if (!$isadmin && exists($editimageid_args{"path"})) { ...@@ -320,11 +343,32 @@ if (!$isadmin && exists($editimageid_args{"path"})) {
# #
# See what node types this image will work on. Must be at least one! # 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)); 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. # Only admins can edit the load_address or the frisbee pid.
# #
......
...@@ -278,7 +278,8 @@ foreach $key (keys(%{ $xmlparse->{'attribute'} })) { ...@@ -278,7 +278,8 @@ foreach $key (keys(%{ $xmlparse->{'attribute'} })) {
} }
# Now check that the value is legal. # 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(); $errors{$key} = TBFieldErrorString();
next; next;
} }
......
...@@ -171,20 +171,60 @@ UserError() ...@@ -171,20 +171,60 @@ UserError()
# #
my %editsitevars_args = (); 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'} })) { foreach $key (keys(%{ $xmlparse->{'attribute'} })) {
my $value = $xmlparse->{'attribute'}->{"$key"}->{'value'}; my $value = $xmlparse->{'attribute'}->{"$key"}->{'value'};
if (!defined($value)) { # Empty string comes from XML as an undef value. if (!defined($value)) { # Empty string comes from XML as an undef value.
$xmlparse->{'attribute'}->{"$key"}->{'value'} = $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" my ($dbslot, $required, $default) = @{$xmlfields{$field}};
if (!exists($xmlfields{$key}));
my ($dbslot, $required, $default) = @{$xmlfields{$key}};
if ($required & $SLOT_REQUIRED) { if ($required & $SLOT_REQUIRED) {
# A slot that must be provided, so do not allow a null value. # A slot that must be provided, so do not allow a null value.
...@@ -209,13 +249,13 @@ foreach $key (keys(%{ $xmlparse->{'attribute'} })) { ...@@ -209,13 +249,13 @@ foreach $key (keys(%{ $xmlparse->{'attribute'} })) {
} }
# Now check that the value is legal. # Now check that the value is legal.
if (! TBcheck_dbslot($value, "sitevariables", if (! TBcheck_dbslot($value, "sitevariables",
$dbslot, TBDB_CHECKDBSLOT_ERROR)) { $dbslot, TBDB_CHECKDBSLOT_ERROR)) {
$errors{$key} = TBFieldErrorString(); $errors{$key} = TBFieldErrorString();
next; next;
} }
$editsitevars_args{$dbslot} = $value; $editsitevars_args{$key} = $value;
} }
UserError() UserError()
if (keys(%errors)); if (keys(%errors));
......
...@@ -152,6 +152,7 @@ my %xmlfields = ...@@ -152,6 +152,7 @@ my %xmlfields =
"w_password2" => ["w_password2", $SLOT_OPTIONAL], "w_password2" => ["w_password2", $SLOT_OPTIONAL],
"user_interface" => ["user_interface", $SLOT_OPTIONAL], "user_interface" => ["user_interface", $SLOT_OPTIONAL],
"notes" => ["notes", $SLOT_OPTIONAL]); "notes" => ["notes", $SLOT_OPTIONAL]);
# #
# Must wrap the parser in eval since it exits on error. # Must wrap the parser in eval since it exits on error.
# #
...@@ -172,7 +173,8 @@ my %errors = (); ...@@ -172,7 +173,8 @@ my %errors = ();
# #
# Make sure all the required arguments were provided. # 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}}; my (undef, $required, undef) = @{$xmlfields{$key}};
$errors{$key} = "Required value not provided" $errors{$key} = "Required value not provided"
...@@ -188,20 +190,60 @@ UserError() ...@@ -188,20 +190,60 @@ UserError()
# #
my %moduserinfo_args = (); 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'}; my $value = $xmlparse->{'attribute'}->{"$key"}->{'value'};
if (!defined($value)) { # Empty string comes from XML as an undef value. if (!defined($value)) { # Empty string comes from XML as an undef value.
$xmlparse->{'attribute'}->{"$key"}->{'value'} = $value = ""; $xmlparse->{'attribute'}->{"$key"}->{'value'} = $value = "";
} }