addpubkey.in 17.5 KB
Newer Older
1 2
#!/usr/bin/perl -wT
#
3
# Copyright (c) 2000-2012 University of Utah and the Flux Group.
4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22
# 
# {{{EMULAB-LICENSE
# 
# This file is part of the Emulab network testbed software.
# 
# This file is free software: you can redistribute it and/or modify it
# under the terms of the GNU Affero General Public License as published by
# the Free Software Foundation, either version 3 of the License, or (at
# your option) any later version.
# 
# This file is distributed in the hope that it will be useful, but WITHOUT
# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
# FITNESS FOR A PARTICULAR PURPOSE.  See the GNU Affero General Public
# License for more details.
# 
# You should have received a copy of the GNU Affero General Public License
# along with this file.  If not, see <http://www.gnu.org/licenses/>.
# 
# }}}
23 24 25
#
use English;
use Getopt::Std;
26
use XML::Simple;
27 28 29 30 31 32 33 34 35 36

#
# Parse ssh public keys and enter into the DB. The default format is
# openssh, but if the key is not in that format, then use ssh-keygen
# to see if it can be converted from either SSH2 or SECSH format into
# openssh format. This gets called from the webpage to parse keys
# uploaded by users.
#
sub usage()
{
Russ Fish's avatar
Russ Fish committed
37 38 39
    print "Usage: addpubkeys [-d] [-k | -f] [-n | -u <user>] [<keyfile> | <key>]\n";
    print "       addpubkeys [-d] -X <xmlfile>\n";
    print "       addpubkeys [-d] [-i [-r] | -w] <user>\n";
40
    print "Options:\n";
Russ Fish's avatar
Russ Fish committed
41
    print " -d      Turn on debugging\n";
42
    print " -k      Indicates that key was passed in on the command line\n";
43
    print " -f      Indicates that key was passed in as a filename\n";
44
    print " -n      Verify key format only; do not enter into into DB\n";
45
    print " -X      Get args from an XML file: verify, user, keyfile.\n";
46 47
    print " -w      Generate new authkeys (protocol 1 and 2) file for user\n";
    print " -i      Initialize mode; generate initial key for user\n";
48
    print " -r      Force a regenerate of initial key for user\n";
49 50
    exit(-1);
}
51
my $optlist   = "dkniwfu:rX:sRNC:S:";
52 53
my $iskey     = 0;
my $verify    = 0;
54
my $initmode  = 0;
Leigh B. Stoller's avatar
Leigh B. Stoller committed
55
my $force     = 0;
56 57 58
my $genmode   = 0;
my $nobody    = 0;
my $noemail   = 0;
59 60 61
my $remove    = 0;
my $nodelete  = 0;
my $Comment;
62
my $xmlfile;
63 64 65 66 67 68 69

#
# Configure variables
#
my $TB		= "@prefix@";
my $TBOPS       = "@TBOPSEMAIL@";
my $TBAUDIT     = "@TBAUDITEMAIL@";
Leigh B. Stoller's avatar
Leigh B. Stoller committed
70
my $OURDOMAIN   = "@OURDOMAIN@";
71 72 73 74 75
my $KEYGEN	= "/usr/bin/ssh-keygen";
my $USERUID;

# Locals
my $user;
76 77
my $this_user;
my $target_user;
78 79 80 81 82 83
my $keyfile;
my $keyline;
my $key;
my $comment;
my $user_name;
my $user_email;
84 85
my $user_dbid;
my $user_uid;
Russ Fish's avatar
Russ Fish committed
86
my $debug = 0;
87 88 89 90 91

#
# Testbed Support libraries
#
use lib "@prefix@/lib";
92
use libaudit;
93 94
use libdb;
use libtestbed;
95
use User;
96

97 98 99 100 101
#
# Function prototypes
#
sub ParseKey($);
sub InitUser();
Leigh B. Stoller's avatar
Leigh B. Stoller committed
102
sub GenerateKeyFile();
Russ Fish's avatar
Russ Fish committed
103
sub ParseXmlArgs($$$$$$);
104 105
sub fatal($);

106 107
my $HOMEDIR = USERROOT();

108 109 110 111 112 113 114 115 116 117 118 119
#
# These are the fields that we allow to come in from the XMLfile.
#
my $SLOT_OPTIONAL	= 0x1;	# The field is not required.
my $SLOT_REQUIRED	= 0x2;  # The field is required and must be non-null.
my $SLOT_ADMINONLY	= 0x4;  # Only admins can set this field.
my %xmlfields =
    # XML Field Name        DB slot name         Flags             Default
    ("verify"		=> ["verify",		$SLOT_OPTIONAL,	   0],
     "user"		=> ["user",		$SLOT_OPTIONAL],
     "keyfile"		=> ["keyfile",		$SLOT_REQUIRED]);

120 121 122 123 124 125 126 127 128 129 130
#
# Turn off line buffering on output
#
$| = 1;

#
# Untaint the path
# 
$ENV{'PATH'} = "/bin:/sbin:/usr/bin:/usr/sbin:/usr/local/bin:/usr/local/sbin";
delete @ENV{'IFS', 'CDPATH', 'ENV', 'BASH_ENV'};

131 132 133 134 135 136 137 138
#
# We don't want to run this script unless its the real version.
#
if ($EUID != 0) {
    die("*** $0:\n".
	"    Must be setuid! Maybe its a development version?\n");
}

139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154
#
# Please do not run it as root. Hard to track what has happened.
# 
if ($UID == 0) {
    die("*** $0:\n".
	"    Please do not run this as root!\n");
}

#
# Parse command arguments. Once we return from getopts, all that should be
# left are the required arguments.
#
%options = ();
if (! getopts($optlist, \%options)) {
    usage();
}
Russ Fish's avatar
Russ Fish committed
155 156 157
if (defined($options{"d"})) {
    $debug = 1;
}
158 159 160
if (defined($options{"k"})) {
    $iskey = 1;
}
161 162 163
if (defined($options{"f"})) {
    $iskey = 0;
}
164 165 166
if (defined($options{"n"})) {
    $verify = 1;
}
167 168 169
if (defined($options{"i"})) {
    $initmode = 1;
}
170 171 172
if (defined($options{"N"})) {
    $nodelete = 1;
}
173
if (defined($options{"r"})) {
Leigh B. Stoller's avatar
Leigh B. Stoller committed
174 175
    $force = 1;
}
176 177 178
if (defined($options{"R"})) {
    $remove = 1;
}
179 180 181
if (defined($options{"s"})) {
    $noemail = 1;
}
182 183
if (defined($options{"w"})) {
    $genmode = 1;
184
}
185 186 187
if (defined($options{"u"})) {
    $user = $options{"u"};
}
188 189 190
if (defined($options{"C"})) {
    $Comment = $options{"C"};
}
191 192 193 194 195
if (defined($options{"X"})) {
    $xmlfile = $options{"X"};

    my %xmlargs = (); 
    my %errors = ();
Russ Fish's avatar
Russ Fish committed
196 197
    ParseXmlArgs($xmlfile, "user_pubkeys", \%xmlfields, $debug,
		 \%xmlargs, \%errors);
198 199 200 201 202 203 204 205 206 207 208 209 210 211
    if (keys(%errors)) {
	foreach my $key (keys(%errors)) {
	    my $val = $errors{$key};
	    print "${key}: $val\n";
	}
	fatal("XML arg error");
    }

    $verify = $xmlargs{"verify"};
    $user = $xmlargs{"user"}
	if (exists($xmlargs{"user"}));
    $ARGV[0] = $xmlargs{"keyfile"};
}

212
if ($verify && $genmode) {
213 214
    usage();
}
215
if ($initmode || $genmode) {
216 217 218 219
    usage()
	if (@ARGV != 1);

    $user = $ARGV[0];
220 221
}
else {
222 223 224 225 226 227 228
    usage()
	if (@ARGV != 1);
    usage()
	if (!$verify && !defined($user));
    
    $keyfile = $ARGV[0];
}
229 230 231 232

#
# Untaint the arguments.
#
233
if (defined($user)) {
234
    if ($user =~ /^([-\w]+)$/i) {
235 236 237 238 239
	$user = $1;
    }
    else {
	fatal("Tainted username: $user");
    }
240 241 242 243 244 245 246 247 248 249
    # Map user to object.
    $target_user = User->Lookup($user);
    if (! defined($target_user)) {
	fatal("$user does not exist!")
    }

    $user_name  = $target_user->name();
    $user_email = $target_user->email();
    $user_dbid  = $target_user->dbid();
    $user_uid   = $target_user->uid();
Leigh B. Stoller's avatar
Leigh B. Stoller committed
250
    $USERUID    = $target_user->unix_uid();
251 252 253
}

#
254 255 256
# If invoked as "nobody" we came from the web interface. We have to have
# a credential in the environment, unless its just a key verification
# operation, which anyone can do. 
257 258
# 
if (getpwuid($UID) eq "nobody") {
259 260 261 262
    $this_user = User->ImpliedUser();
    
    if (($initmode || $genmode || !$verify) && !defined($this_user)) {
	fatal("Bad usage from web interface");
263 264 265 266
    }
    $nobody = 1;
}
else {
267 268
    # From the command line; map invoking user to object.
    $this_user = User->ThisUser();
269 270 271 272

    if (! defined($this_user)) {
	fatal("You ($UID) do not exist!");
    }
273 274 275
}

#
276 277
# Initmode or genmode, do it and exit. Eventually get rid of the switch
# to the target user.
278 279 280
#
if ($initmode) {
    # Drop root privs, switch to target user.
281
    $EUID = $UID = $USERUID;
282 283 284 285
    exit InitUser();
}
if ($genmode) {
    # Drop root privs, switch to target user.
286
    $EUID = $UID = $USERUID;
Leigh B. Stoller's avatar
Leigh B. Stoller committed
287
    exit GenerateKeyFile();
288 289 290
}

# Else, key parse mode ...
291 292 293 294 295 296 297 298 299 300 301 302
if ($iskey) {
    if ($keyfile =~ /^([-\w\s\.\@\+\/\=]*)$/) {
	$keyfile = $1;
    }
    else {
	fatal("Tainted key: $keyfile");
    }
    $keyline = $keyfile;
}
else {
    if ($keyfile =~ /^([-\w\.\/]+)$/) {
	$keyfile = $1;
303
     }
304 305 306 307
    else {
	fatal("Tainted filename: $keyfile");
    }
    if (! -e $keyfile) {
308
	fatal("No such file: $keyfile\n");
309 310 311 312 313
    }
    $keyline = `head -1 $keyfile`;
}

#
314
# Check user
315
#
316
if (!$verify) {
317 318 319 320
    # If its the user himself, then we can generate a new authkeys file.
    # Assume nodelete option comes from internal script, so do not worry.
    if (!$target_user->SameUser($this_user) && !$this_user->IsAdmin() &&
	!$nodelete) {
321
	fatal("You are not allowed to set pubkeys for $target_user\n");
322
    }
323
    if (-d "$HOMEDIR/$user_uid/.ssh") {
324 325
	# Drop root privs, switch to target user.
	$EUID = $UID = $USERUID;
326 327
	$genmode = 1;
    }
328
    
329 330 331 332 333 334
    #
    # This script is audited when not in verify mode. Since all keys are first
    # checked with verify mode, this should not cause any extra email from bad
    # keys.
    #
    AuditStart(0);
335 336
}

337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363
#
# Grab the first line of the file. Parse it to see if its in the
# format we like (openssh), either protocol 1 or 2.
#
if (ParseKey($keyline)) {
    exit 0;
}
# If the key was entered on the command line, then nothing more to do.
if ($iskey) {
    exit 1;
}

#
# Run ssh-keygen over it and see if it can convert it. 
#
if (! open(KEYGEN, "ssh-keygen -i -f $keyfile 2>/dev/null |")) {
    fatal("*** $0:\n".
	  "    Could not start ssh-keygen\n");
}
$keyline = <KEYGEN>;
if (close(KEYGEN) && ParseKey($keyline)) {
    exit 0;
}
exit 1;

sub ParseKey($) {
    my ($keyline) = @_;
364

365
    # Remove trailing newlines which screws the patterns below.
366 367
    # First convert dos newlines since many people upload from windoze.
    $keyline =~ s/\r/\n/g;
368 369
    $keyline =~ s/\n//g;

370 371 372 373 374 375
    # Enforce a reasonable length on the key.
    if (length($keyline) > 4096) {
	print "Key is too long!\n";
	print "Key: $keyline\n";
	return 0;
    }
376
    
377
    if ($keyline =~ /^(\d*\s\d*\s[0-9a-zA-Z]*) ([-\w\@\.:\ ]*)\s*$/) {
378 379 380 381 382 383 384 385 386 387 388
        # Protocol 1
	$type    = "ssh-rsa1";
	$key     = $1;
	$comment = $2;
    }
    elsif ($keyline =~ /^(\d*\s\d*\s[0-9a-zA-Z]*)\s*$/) {
        # Protocol 1 but no comment field.
	$type    = "ssh-rsa1";
	$key     = $1;
    }
    elsif ($keyline =~
389
	   /^(ssh-rsa|ssh-dss) ([-\w\.\@\+\/\=]*) ([-\w\@\.:\ ]*)$/) {
390 391 392 393 394
        # Protocol 2
	$type    = $1;
	$key     = "$1 $2";
	$comment = $3;
    }
395
    elsif ($keyline =~ /^(ssh-rsa|ssh-dss) ([-\w\.\@\+\/\=:]*)$/) {
396 397 398 399 400 401
        # Protocol 2 but no comment field
	$type    = $1;
	$key     = "$1 $2";
    }

    if (!defined($key)) {
402 403
	print "Key cannot be parsed!\n";
	print "Key: $keyline\n";
404 405
	return 0;
    }
406

407 408
    # Do not enter into DB if in verify mode.
    if ($verify) {
Leigh B. Stoller's avatar
Leigh B. Stoller committed
409
	print "Key was good: $type\n";
410 411 412 413
	return 1;
    }

    #
414
    # Make up a comment field for the DB. 
415 416
    #
    if (!defined($comment)) {
417
	$comment = (defined($Comment) ? $Comment : "$type-${user_email}");
418 419
    }
    $key = "$key $comment";
420 421
    my $safe_key = DBQuoteSpecial($key);
    my $safe_comment = DBQuoteSpecial($comment);
422

423 424 425 426 427 428 429 430 431
    if ($remove) {
	DBQueryFatal("delete from user_pubkeys ".
		     "where uid_idx='$user_dbid' and comment=$safe_comment");
    }
    DBQueryFatal("replace into user_pubkeys set ".
		 " uid='$user_uid', uid_idx='$user_dbid', ".
		 " internal='0', nodelete='$nodelete', ".
		 " idx=NULL, stamp=now(), ".
		 " pubkey=$safe_key, comment=$safe_comment");
432

433 434 435
    #
    # Mark user record as modified so nodes are updated.
    #
436
    TBNodeUpdateAccountsByUID($user_uid);
437

438 439 440 441 442 443 444 445
    my $chunked = "";

    while (length($key)) {
	$chunked .= substr($key, 0, 65, "");
	if (length($key)) {
	    $chunked .= "\n";
	}
    }
446 447
    print "SSH Public Key for '$user' added:\n";
    print "$chunked\n";
448
    
449 450
    # Generate new auth keys file. 
    if ($genmode) {
Leigh B. Stoller's avatar
Leigh B. Stoller committed
451
	GenerateKeyFile();
452 453 454 455
    }

    if (! $noemail) {
	SENDMAIL("$user_name <$user_email>",
456 457
		 "SSH Public Key for '$user_uid' Added",
		 "SSH Public Key for '$user_uid' added:\n".
458 459 460 461 462
		 "\n".
		 "$chunked\n",
		 "$TBOPS");
    }
    return 1;
463 464
}

465 466 467 468 469 470
#
# Init function for new users. Generate the first key for the user (which
# is loaded into the DB), and then generate the keyfiles. Note that the
# user might have preloaded personal keys.
#
sub InitUser()
471
{
472
    my $sshdir  = "$HOMEDIR/$user_uid/.ssh";
473 474

    #
475
    # Set up the ssh key, but only if not done so already.
476
    #
477 478 479 480
    if (! -e "$sshdir") {
	mkdir("$sshdir", 0700) or
	    fatal("Could not mkdir $sshdir: $!");
    }
Leigh B. Stoller's avatar
Leigh B. Stoller committed
481 482
    if (! -e "$sshdir/identity" || $force) {
	print "Creating ssh protocol 1 key for $user.\n";
Leigh B. Stoller's avatar
Leigh B. Stoller committed
483

Leigh B. Stoller's avatar
Leigh B. Stoller committed
484 485 486 487 488 489 490 491
	#
	# Want to delete existing key from DB.
	#
	if (-e "$sshdir/identity") {
	    my $ident = `cat $sshdir/identity.pub`;

	    if ($ident =~ /(\d*\s\d*\s[0-9a-zA-Z]*)\s([-\w\@\.]*)/) {
		DBQueryFatal("delete from user_pubkeys ".
492
			     "where uid_idx='$user_dbid' and pubkey='$1 $2'");
Leigh B. Stoller's avatar
Leigh B. Stoller committed
493 494 495
	    }
	    unlink("$sshdir/identity");
	}
496

Leigh B. Stoller's avatar
Leigh B. Stoller committed
497
	# Hmm, need to use -C option so comment field makes sense.
498
    
Leigh B. Stoller's avatar
Leigh B. Stoller committed
499 500 501
	if (system("$KEYGEN -t rsa1 -P '' ".
		   "-C '${user}" . "\@" . ${OURDOMAIN} . "' ".
		   "-f $sshdir/identity")) {
502 503 504 505 506 507 508 509
	    fatal("Failure in ssh-keygen!");
	}

	#
	# Grab a copy for the DB.
	# 
	my $ident = `cat $sshdir/identity.pub`;

Leigh B. Stoller's avatar
Leigh B. Stoller committed
510
	if ($ident =~ /(\d*\s\d*\s[0-9a-zA-Z]*)\s([-\w\@\.]*)/) {
511 512 513 514
	    DBQueryFatal("replace into user_pubkeys set ".
			 " uid='$user_uid', uid_idx='$user_dbid', ".
			 " internal='1', nodelete='1', idx=NULL, stamp=now(), ".
			 " pubkey='$1 $2', comment='$2'");
515 516
	}
	else {
Leigh B. Stoller's avatar
Leigh B. Stoller committed
517
	    fatal("Bad protocol 1 public key: $ident\n");
518 519
	}
    }
Leigh B. Stoller's avatar
Leigh B. Stoller committed
520 521 522 523 524
    #
    # Moving to V2 keys ...
    #
    if (! -e "$sshdir/id_rsa" || $force) {
	print "Creating ssh protocol 2 key for $user.\n";
525

Leigh B. Stoller's avatar
Leigh B. Stoller committed
526 527 528 529 530 531 532 533 534
	#
	# Want to delete existing key from DB.
	#
	if (-e "$sshdir/id_rsa") {
	    my $ident = `cat $sshdir/id_rsa.pub`;

	    if ($ident =~
		/^(ssh-rsa [-\w\.\@\+\/\=]*) ([-\w\@\.\ ]*)$/) {
		DBQueryFatal("delete from user_pubkeys ".
535
			     "where uid_idx='$user_dbid' and pubkey='$1 $2'");
Leigh B. Stoller's avatar
Leigh B. Stoller committed
536 537 538 539 540
	    }
	    unlink("$sshdir/id_rsa");
	}

	# Hmm, need to use -C option so comment field makes sense.
541
    
Leigh B. Stoller's avatar
Leigh B. Stoller committed
542 543 544 545 546
	if (system("$KEYGEN -t rsa -P '' ".
		   "-C '${user}" . "\@" . ${OURDOMAIN} . "' ".
		   "-f $sshdir/id_rsa")) {
	    fatal("Failure in ssh-keygen!");
	}
547

Leigh B. Stoller's avatar
Leigh B. Stoller committed
548 549 550 551
	#
	# Grab a copy for the DB.
	# 
	my $ident = `cat $sshdir/id_rsa.pub`;
552

Leigh B. Stoller's avatar
Leigh B. Stoller committed
553 554
	if ($ident =~
	    /^(ssh-rsa [-\w\.\@\+\/\=]*) ([-\w\@\.\ ]*)$/) {
555 556 557 558
	    DBQueryFatal("replace into user_pubkeys set ".
			 " uid='$user_uid', uid_idx='$user_dbid', ".
			 " internal='1', nodelete='1', idx=NULL, stamp=now(), ".
			 " pubkey='$1 $2', comment='$2'");
559 560
	}
	else {
Leigh B. Stoller's avatar
Leigh B. Stoller committed
561
	    fatal("Bad protocol 2 public key: $ident\n");
562 563
	}
    }
Leigh B. Stoller's avatar
Leigh B. Stoller committed
564
    return GenerateKeyFile();
565 566 567 568 569 570
}

#
# Generate ssh authorized_keys files. Either protocol 1 or 2.
# Returns 0 on success, -1 on failure.
#
Leigh B. Stoller's avatar
Leigh B. Stoller committed
571
sub GenerateKeyFile()
572
{
Leigh B. Stoller's avatar
Leigh B. Stoller committed
573
    my @pkeys   = ();
574
    my $sshdir  = "$HOMEDIR/$user_uid/.ssh";
575 576 577 578 579 580 581 582
    my $keyfile = "$sshdir/authorized_keys";
	
    if (! -e $sshdir) {
	if (! mkdir($sshdir, 0700)) {
	    warn("*** WARNING: Could not mkdir $sshdir: $!\n");
	    return -1;
	}
    }
Leigh B. Stoller's avatar
Leigh B. Stoller committed
583
    my $query_result =
584 585
	DBQueryFatal("select pubkey from user_pubkeys ".
		     "where uid_idx='$user_dbid'");
Leigh B. Stoller's avatar
Leigh B. Stoller committed
586 587 588

    while (my ($key) = $query_result->fetchrow_array()) {
	push(@pkeys, $key);
589
    }
Leigh B. Stoller's avatar
Leigh B. Stoller committed
590
    
591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625
    print "Generating $keyfile ...\n";

    if (!open(AUTHKEYS, "> ${keyfile}.new")) {
	warn("*** WARNING: Could not open ${keyfile}.new: $!\n");
	return -1;
    }
    print AUTHKEYS "#\n";
    print AUTHKEYS "# DO NOT EDIT! This file auto generated by ".
	"Emulab.Net account software.\n";
    print AUTHKEYS "#\n";
    print AUTHKEYS "# Please use the web interface to edit your ".
	"public key list.\n";
    print AUTHKEYS "#\n";
    
    foreach my $key (@pkeys) {
	print AUTHKEYS "$key\n";
    }
    close(AUTHKEYS);

    if (!chmod(0600, "${keyfile}.new")) {
	warn("*** WARNING: Could not chmod ${keyfile}.new: $!\n");
	return -1;
    }
    if (-e "${keyfile}") {
	if (system("cp -p -f ${keyfile} ${keyfile}.old")) {
	    warn("*** Could not save off ${keyfile}: $!\n");
	    return -1;
	}
	if (!chmod(0600, "${keyfile}.old")) {
	    warn("*** Could not chmod ${keyfile}.old: $!\n");
	}
    }
    if (system("mv -f ${keyfile}.new ${keyfile}")) {
	warn("*** Could not mv ${keyfile} to ${keyfile}.new: $!\n");
    }
Leigh B. Stoller's avatar
Leigh B. Stoller committed
626 627 628 629 630 631
    elsif (-e "$sshdir/authorized_keys2") {
	#
	# Save to remove deprecated authorized_keys2 file at this point.
	#
	unlink("$sshdir/authorized_keys2");
    }
632 633 634
    return 0;
}

Russ Fish's avatar
Russ Fish committed
635 636 637
sub ParseXmlArgs($$$$$$) {
    my ($xmlfile, $table_name, $fields_ref, $debug,
	$args_ref, $errs_ref) = @_;
638 639 640 641 642
    #
    # Input args:
    #  $xmlfile	   - XML file path.
    #  $table_name - table_regex table_name for low-level checking patterns.
    #  $fields_ref - xmlfields specification (hash reference.)
Russ Fish's avatar
Russ Fish committed
643
    #  $debug
644 645 646 647 648
    #
    # Output args:
    #  $args_ref   - Parsed argument values (hash reference.)
    #  $errs_ref   - Error messages on failure (hash reference.)

Leigh B. Stoller's avatar
Leigh B. Stoller committed
649
    $debug = 0;
650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678

    #
    # Must wrap the parser in eval since it exits on error.
    #
    my $xmlparse = eval { XMLin($xmlfile,
				VarAttr => 'name',
				ContentKey => '-content',
				SuppressEmpty => undef); };
    if ($@) {
	$errs_ref->{"XML Parse Error"} = "Return code $@";
	return;
    }

    #
    # Make sure all the required arguments were provided.
    #
    my $key;
    foreach $key (keys(%{ $fields_ref })) {
	my (undef, $required, undef) = @{$fields_ref->{$key}};

	$errs_ref->{$key} = "Required value not provided"
	    if ($required & $SLOT_REQUIRED  &&
		! exists($xmlparse->{'attribute'}->{"$key"}));
    }
    return
	if (keys(%{ $errs_ref }));

    foreach $key (keys(%{ $xmlparse->{'attribute'} })) {
	my $value = $xmlparse->{'attribute'}->{"$key"}->{'value'};
679 680 681
	if (!defined($value)) {	# Empty string comes from XML as an undef value.
	    $xmlparse->{'attribute'}->{"$key"}->{'value'} = $value = "";
	}
682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720

	if ($debug) {
	    print STDERR "User attribute: '$key' -> '$value'\n";
	}

	$errs_ref->{$key} = "Unknown attribute"
	    if (!exists($fields_ref->{$key}));

	my ($dbslot, $required, $default) = @{$fields_ref->{$key}};

	if ($required & $SLOT_REQUIRED) {
	    # A slot that must be provided, so do not allow a null value.
	    if (!defined($value)) {
		$errs_ref->{$key} = "Must provide a non-null value";
		next;
	    }
	}
	if ($required & $SLOT_OPTIONAL) {
	    # Optional slot. If value is null skip it. Might not be the correct
	    # thing to do all the time?
	    if (!defined($value)) {
		next
		    if (!defined($default));
		$value = $default;
	    }
	}
	if ($required & $SLOT_ADMINONLY) {
	    # Admin implies optional, but thats probably not correct approach.
	    $errs_ref->{$key} = "Administrators only"
		if (! $this_user->IsAdmin());
	}

	# Now check that the value is legal.
	if (! TBcheck_dbslot($value, $table_name, $dbslot, 
			     TBDB_CHECKDBSLOT_ERROR)) {
	    $errs_ref->{$key} = TBFieldErrorString();
	    next;
	}

Russ Fish's avatar
Russ Fish committed
721
	$args_ref->{$key} = $value;
722 723 724
    }
}

725 726 727 728 729 730
sub fatal($) {
    my($mesg) = $_[0];

    die("*** $0:\n".
	"    $mesg\n");
}