### 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(){ 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;