### Local Variables: ***
### mode:perl ***
### comment-column:0 ***
### comment-start: "### " ***
### comment-end: "***" ***
### End: ***
#
# ****************DO NOT MOVE OR CHANGE LINES ABOVE THIS*********************
#
# The first set of lines runs perl from any shell. The second set of lines
# identifies the rest of the file as PERL for EMACS autoformatting.
# See end of copyright for more information.
#
#
# -------------------------------------------------------------------
# X-BONE
#
# http://www.isi.edu/xbone
# USC Information Sciences Institute (USC/ISI)
# Marina del Rey, California 90292, USA
# Copyright (c) 1998-2005
#
# -------------------------------------------------------------------
#
# Copyright (c) 1998-2005 by the University of Southern California.
# All rights reserved.
#
# Permission to use, copy, modify, and distribute this software and
# its documentation in source and binary forms for non-commercial
# purposes and without fee is hereby granted, provided that the above
# copyright notice appear in all copies and that both the copyright
# notice and this permission notice appear in supporting
# documentation, and that any documentation, advertising materials,
# and other materials related to such distribution and use acknowledge
# that the software was developed by the University of Southern
# California, Information Sciences Institute. The name of the
# University may not be used to endorse or promote products derived
# from this software without specific prior written permission.
#
# THE UNIVERSITY OF SOUTHERN CALIFORNIA MAKES NO REPRESENTATIONS ABOUT
# THE SUITABILITY OF THIS SOFTWARE FOR ANY PURPOSE. THIS SOFTWARE IS
# PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED WARRANTIES,
# INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF
# MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE.
#
# Other copyrights might apply to parts of this software and are so
# noted when applicable.
#
# -------------------------------------------------------------------
#
# Effort partly sponsored by the Defense Advanced Research Projects
# Agency (DARPA) and Air Force Research Laboratory, Air Force Materiel
# Command, USAF, under agreement numbers F30602-98-1-0200 (X-Bone) and
# F30602-01-2-0529 (DynaBone). The views and conclusions contained
# herein are those of the authors and should not be interpreted as
# necessarily representing the official policies or endorsements,
# either expressed or implied, of the Defense Advanced Research
# Projects Agency (DARPA), the Air Force Research Laboratory, or the
# U.S. Government.
#
# This work was partly supported by the NSF STI-XTEND (ANI-0230789)
# and NETFS (ANI-0129689) projects. Any opinions, findings, and
# conclusions or recommendations expressed in this material are those
# of the authors and do not necessarily reflect the views of the
# National Science Foundation.
#
# -------------------------------------------------------------------
# $RCSfile: XB_AppDeploy.pm,v $
#
# $Revision: 1.9 $
# $Author: pingali $
# $Date: 2005/03/31 07:03:53 $
# $State: Exp $
# ----------------------------------------------------------------------------
#
# Primary Author: Yu-Shun Wang
#
# Modules for XBone Application Deployment:
#
# - get_script: download the application script from the given URL
# - exec_script: execute the script with given arguments & UID
#
# - get_app_info: for OM to extract application info from the script
# (2) XB_AppCmds.pm:
# - grep_script: for RD to extract the script from commands & save it
#
package XB_AppDeploy;
require Exporter;
@ISA = qw(Exporter);
@EXPORT = qw(get_script exec_script app_dir);
@EXPORT_OK = qw ();
use strict;
use sigtrap;
use English;
use LWP::Simple;
#use XB_Params;
#use XB_Log;
my $modname = "XB_AppDeploy::";
# Description:
# Get the object specified in given URL.
# Arguments:
# $url url of the object to fetch
# $path location to place the object
# $chksum checksum of the script (optional)
# Returns:
# $file complete path/filename of the downloaded object
# Exceptions:
# "XB_AppDeploy::get_script" on error, nothing to clean up by caller
#
sub get_script ($$;$){
my ($url, $path, $chksum) = @_;
my $procname = $modname. "get_script";
if(! defined $chksum){ $chksum = ''; }
my ($script, $file);
XB_Log::log "info", "-> $procname $url,\n $path, $chksum";
eval {
# extract the filename from the URL
if($url =~ /\S+\/(\S+)$/){
$script = $1;
}else{
XB_Log::log "err", " [$procname] script name missing"
and die "name";
}
unless(-d "$path"){
XB_Log::log "err", " [$procname] path $path doesn't exist"
and die "path";
}
$file = "$path/$script";
XB_Log::log "debug2", " [$procname] download to $file";
# use mirror to avoid unnecessary download.
my $rc = mirror($url, $file);
if(is_error($rc)){
XB_Log::log "err", " [$procname] LWP::mirror: ". status_message($rc)
and die "mirror";
}else{
XB_Log::log "debug2", " [$procname] download result: ".
status_message($rc);
}
my $md5sum;
if($XB_Params::node_opts{os} =~ /linux/i){
$md5sum = `md5sum $file`;
chomp ($md5sum);
$md5sum =~ s/ .*$//g; # chop everything after the first space
} else {
$md5sum = `md5 -q $file`;
chomp ($md5sum);
}
XB_Log::log "debug2", " [$procname] md5 checksum: $md5sum";
unless($chksum eq ''){
unless($chksum eq $md5sum){
unlink $file; # delete the file if checksum mismatch
XB_Log::log "err", " [$procname] checksum for $url mismatch";
die "chksum";
}
}else{
XB_Log::log "warning", " [$procname] no checksum for $file";
}
};
XB_Log::log "info", "<- $procname $file";
return $file unless $@;
unless($@ =~ /^(name|path|mirror|chksum)/){
XB_Log::log "warning", " ! $procname caught unknown exception: $@";
}
die "$procname";
}
# Description:
# Execute the script with given arguments and UID.
# Arguments:
# $script the script to execute
# $args (ref) arguments to the script
# $uid effective UID to execute the script with
# Returns:
# $result exit value of the script execution
# Exceptions:
# "XB_AppDeploy::exec_script" on error, nothing to clean up by caller
# Note:
# To run the script with given privilege, fork and change (reduce) the
# privilege in the child, then run the script in the child.
#
sub exec_script($$$)
{
my ($script, $args, $uid) = @_;
my ($result);
my $procname = $modname. "exec_script";
XB_Log::log "info", "-> $procname @_";
eval{
#-> check uid
unless ($uid =~ /\b(root|nobody|vhost)\b/i){
XB_Log::log "err", " [$procname] unsupported UID: $uid, only ".
"root, nobody, and vhost are supported.";
die "uid";
}
#-> check script
my $cnt = chmod 0755, $script;
unless($cnt){
XB_Log::log "err", " [$procname] failed to chmod 755 $script";
die "chmod";
}
#-> construct command array
my @cmd = ($script, @$args);
my $cmdstr = "";
for my $c (@cmd){ $cmdstr .= "$c "; }
#-> execute based on uid
my $pid;
unless($uid eq 'vhost'){
#-> get numeric uid & gid
my @new_uid = getpwnam $uid;
unless(@new_uid > 0){
XB_Log::log "err", " [$procname] UID: $uid does not exist";
die "getpwnam";
}
my $new_uid = $new_uid[2];
my $new_gid = $new_uid[3];
#-> fork and execute command in child
unless(defined($pid = open(KID, "-|"))){
XB_Log::log "err", " [$procname] can't fork: $!" and die "fork";
}
#die "fork: $!" unless defined($pid = open(KID, "-|"));
if($pid){
#-> parent
while(<KID>){
XB_Log::log "info", " [$procname:fork] ". $_;
}
close KID;
#-> get the exit value of the child and analyze it before return
#$result = 0xffff & $?;
$result = $?;
XB_Log::log "debug2", " [$procname] child $pid returns $?";
#printf "- child returned %#04x: ", $result;
if($result == 0){
XB_Log::log "debug2", " [$procname] child exit code: $result";
}elsif($result == 0xff00){
XB_Log::log "debug2", " [$procname] child exec failed: $!";
die "system";
}elsif($result > 0x80){
$result >>= 8;
XB_Log::log "debug2", " [$procname] child exit code: $result";
}else{
XB_Log::log "warning", " [$procname] unknown exit code: $result";
}
}else{
#-> child
#-- construct the command array
my ($orig_uid, $orig_gid, $orig_euid, $orig_egid) =
($UID, $GID, $EUID, $EGID);
#-- drop privileges
$UID = $new_uid;
$EUID = $new_uid;
$GID = $new_gid;
$EGID = $new_gid;
$ENV{PATH} = "/bin:/usr/bin"; # Minimal PATH
#print "orig UID/EUID: $orig_uid, $orig_euid\n";
#print "new UID/EUID: $UID, $EUID\n";
#-- execute the command with system & get the exit value
my $rc = 0xffff & system (@cmd);
printf "system(%s) returned %#04x: ", "@cmd", $rc;
#-- process & analyze the exit value
if($rc == 0){
print "normal exit: 0\n";
}elsif($rc == 0xff00){
print "command failed: $!\n";
}elsif($rc > 0x80){
$rc >>= 8;
print "non-zero exit status: $rc\n";
}else{
print "unknown exist status: $rc\n";
}
#-- need to do this to keep SSL sockets open in the parent
XB_Common::child_close($procname);
#-- return the exit value
exit $rc;
}
}else{
XB_Log::log "err", " [$procname] deploy application in vhost is not".
" yet supported";
die "vhost";
}
};
XB_Log::log "info", "<- XB_AppCmds::exec_script $result";
return $result unless $@;
unless ($@ =~ /^(uid|chmod|getpwnam|fork|system|vhost)/){
XB_Log::log "warning", " ! $procname caught unknown exception: $@";
}
die "$procname";
}
# Description:
# Prepare the runtime directory for the app deployment
# Arguments:
# $name overlay name
# $appname application name
# $script script
# $uid effective UID to execute the script
# Returns:
# $script new script (full path)
# $appdir application directory
# Exceptions:
# "XB_AppDeploy::app_dir" on error, nothing to clean up by caller
#
sub app_dir($$$$){
my ($name, $appname, $script, $uid) = @_;
my $procname = $modname. "app_dir";
my ($new_script, $app_dir);
XB_Log::log "info", "-> $procname $name, $appname, $script, $uid";
eval{
my $workdir = $XB_Params::node_opts{workdir};
$app_dir = "$workdir/$name-$appname";
my @cmd = ('mkdir', '-p', "$app_dir");
my $rc = 0xff & system (@cmd);
($rc == 0 ) or
XB_Log::log "err", " [$procname] mkdir $app_dir failed: $!" and
die "mkdir";
chmod 0755, $app_dir or
XB_Log::log "err", " [$procname] chmod 0755, $app_dir failed: $!" and
die "chmod";
if($script =~ /\S+\/(\S+)$/){
$new_script = $1;
}else{
XB_Log::log "err", " [$procname] could not grep script name from\n".
" $script";
die "name";
}
$new_script = "$app_dir/$new_script";
@cmd = ('cp', "$script", "$new_script");
$rc = 0xff & system (@cmd);
($rc == 0 ) or
XB_Log::log "err", " [$procname] could not copy $script to ".
"$new_script" and die "cp";
$uid = ($uid eq 'vhost')? 'root': $uid;
my @new_uid = getpwnam $uid;
unless(@new_uid > 0){
XB_Log::log "err", " [$procname] UID: $uid does not exist";
die "getpwnam";
}
my $new_uid = $new_uid[2];
my $new_gid = $new_uid[3];
my $cnt = chown $new_uid, $new_gid, $new_script, $app_dir;
unless($cnt == 2){
XB_Log::log "err", " [$procname] chown $new_uid, $new_gid, ".
"$new_script and $app_dir failed: $!" and die "chown";
}
};
XB_Log::log "info", "<- $procname $new_script, $app_dir";
return ($new_script, $app_dir) unless $@;
unless($@ =~ /(check_create_dir|mkdir|chmod|name|cp|getpwnam|chown)/){
XB_Log::log "warning", " ! $procname caught unknown exception: $@";
}
die "$procname";
}
1;
syntax highlighted by Code2HTML, v. 0.9.1