source: branches/locker-dev/locker/deploy/bin/onserver.pm @ 1232

Last change on this file since 1232 was 1232, checked in by ezyang, 15 years ago
Fix missing trailing newlines and double-newline.
File size: 6.5 KB
RevLine 
[127]1package onserver;
2use strict;
3use Exporter;
[456]4use Sys::Hostname;
5use File::Spec::Functions;
6use File::Basename;
[1224]7use File::Copy;
[456]8use Socket;
9use Cwd qw(abs_path);
10use POSIX qw(strftime);
[466]11use LWP::UserAgent;
[1224]12use IPC::Open2;
[466]13use URI;
[127]14our @ISA = qw(Exporter);
[476]15our @EXPORT = qw(setup totmp fetch_uri print_login_info press_enter $server $tmp $USER $HOME $sname $deploy $addrend $base_uri $ua $admin_username $requires_sql $addrlast $sqlhost $sqluser $sqlpass $sqldb $admin_password $scriptsdev $human $email);
[127]16
17our $server = "scripts.mit.edu";
18
[1224]19our ($tmp, $USER, $HOME, $lname, $sname, $deploy, $addrend, $base_uri, $ua, $admin_username, $requires_sql, $addrlast, $sqlhost, $sqluser, $sqlpass, $sqldb, $admin_password, $scriptsdev, $human, $email);
[127]20
21$tmp = ".scripts-tmp";
22sub totmp {
23  open(FILE, ">$tmp");
24  print FILE $_[0];
25  close(FILE);
26}
27
[472]28$ua = LWP::UserAgent->new;
[475]29push @{$ua->requests_redirectable}, 'POST';
[466]30
31sub fetch_uri {
32    my ($uri, $get, $post) = @_;
33    my $u = URI->new($uri);
34    my $req;
35    if (defined $post) {
36        $u->query_form($post);
37        my $content = $u->query;
38        $u->query_form($get);
39        $req = HTTP::Request->new(POST => $u->abs($base_uri));
40        $req->content_type('application/x-www-form-urlencoded');
41        $req->content($content);
42    } else {
43        $u->query_form($get) if (defined $get);
44        $req = HTTP::Request->new(GET => $u->abs($base_uri));
45    }
46    my $res = $ua->request($req);
47    if ($res->is_success) {
48        return $res->content;
49    } else {
50        print STDERR "Error fetching configuration page: ", $res->status_line, "\n";
51        return undef;
52    }
53}
54
[127]55sub print_login_info {
56  print "\nYou will be able to log in to $sname using the following:\n";
57  print "  username: $admin_username\n";
58  print "  password: $admin_password\n";
59}
60
[456]61sub getclienthostname {
62    if (my $sshclient = $ENV{"SSH_CLIENT"}) {
63        my ($clientip) = split(' ', $sshclient);
64        my $hostname = gethostbyaddr(inet_aton($clientip), AF_INET);
65        return $hostname || $clientip;
66    } else {
67        return hostname();
68    }
69}
70
[127]71sub press_enter {
72  local $/ = "\n";
73  print "Press [enter] to continue with the install.";
74  my $enter = <STDIN>; 
75}
76
77sub setup {
78  $ENV{PATH} = '/bin:/usr/bin';
79  $USER = $ENV{USER};
80  $HOME = $ENV{HOME};
81 
[1224]82  ($lname, $sname, $deploy, $addrend, $admin_username, $requires_sql, $scriptsdev, $human) = @ARGV;
[127]83  chdir "$HOME/web_scripts/$addrend";
[476]84  $email = "$human\@mit.edu";
[127]85 
86  if($addrend =~ /^(.*)\/$/) {
87    $addrend = $1;
88  }
89  ($addrlast) = ($addrend =~ /([^\/]*)$/);
90 
[466]91  $base_uri = "http://$server/~$USER/$addrend/";
92 
[127]93  if($requires_sql) {
94    print "\nCreating SQL database for $sname...\n";
95   
[467]96    open GETPWD, '-|', "/mit/scripts/sql/bin$scriptsdev/get-password";
97    ($sqlhost, $sqluser, $sqlpass) = split(/\s/, <GETPWD>);
98    close GETPWD;
99    open SQLDB, '-|', "/mit/scripts/sql/bin$scriptsdev/get-next-database", $addrlast;
100    $sqldb = <SQLDB>;
101    close SQLDB;
102    open SQLDB, '-|', "/mit/scripts/sql/bin$scriptsdev/create-database", $sqldb;
103    $sqldb = <SQLDB>;
104    close SQLDB;
[127]105    if($sqldb eq "") {
106      print "\nERROR:\n";
107      print "Your SQL account failed to create a SQL database.\n";
108      print "You should log in at http://sql.mit.edu to check whether\n";
109      print "your SQL account is at its database limit or its storage limit.\n";
110      print "If you cannot determine the cause of the problem, please\n";
111      print "feel free to contact sql\@mit.edu for assistance.\n";
[462]112      open FAILED, ">.failed";
113      close FAILED;
[127]114      exit 1;
115    }
116  }
117 
[239]118  if(-e "$HOME/web_scripts/$addrend/.admin") { 
[462]119    open ADMIN, "<$HOME/web_scripts/$addrend/.admin";
120    $admin_password=<ADMIN>;
[240]121    chomp($admin_password);
[462]122    close ADMIN;
[240]123    unlink "$HOME/web_scripts/$addrend/.admin";
124  } 
125
[1224]126  # This code was originally in onathena
[1229]127  my $repo = "/mit/scripts/git/autoinstalls$scriptsdev/$deploy.git";
[1224]128  if(-e $repo) {
129    # Much of this can be replaced with
130    # system("git", "clone", "--shared", $repo, ".");
131    # but only once we complete the FC11 transition and are running
132    # a version of Git more recent than 1.6.1 on all servers.
133    `git init`;
134    open HTACCESS, '>', '.git/.htaccess' or die $!;
[1232]135    print HTACCESS "Deny from all\n";
[1224]136    close HTACCESS;
[1232]137    open ALTERNATES, '>', ".git/objects/info/alternates" or die $!;
[1224]138    print ALTERNATES "$repo/objects";
139    close ALTERNATES;
140    system("git", "remote", "add", "origin", $repo);
141    `git config branch.master.remote origin`;
142    `git config branch.master.merge refs/heads/master`;
143    `git fetch origin`;
144    `git branch --track master origin/master`;
145    system("git checkout master"); # to get output
146  } else {
147    system("tar", "zxpf", "/mit/scripts/deploy$scriptsdev/$deploy.tar.gz");
148    my @files = glob("* .*"); # You /don't/ want to match dotfiles
149    if (@files == 3) {
150      chdir $files[0] or die $!;
151      for (glob("{,.??}*")) {
152        move($_, catfile("..", $_)) || die $!;
153      }
154      chdir ".."
155    }
156    rmdir $files[0];
157  }
158  if(-f "/mit/scripts/deploy$scriptsdev/php.ini/$deploy") {
159    # Copy in PHP file,  perform substitutions, and make symlinks
160    # to php.ini in all subdirectories
161    my $nodot = $lname; $nodot =~ s/\.//;
162    open(PHPIN, "/mit/scripts/deploy$scriptsdev/php.ini/$deploy") || die $!;
163    open(PHPOUT, ">", "php.ini") || die $!;
164    while(<PHPIN>) {
165      s/SCRIPTS_USER/$lname/;
166      s/SCRIPTS_NODOT/$nodot/;
167      print PHPOUT $_ or die $!;
168    }
169    close(PHPOUT) || die $!;
170    close(PHPIN) || die $!;
171    # athrun doesn't exist on scripts.  But find exists!  Use alternate script
172    system("/mit/scripts/bin/fix-php-ini-scripts");
173  }
174
[127]175  print "\nConfiguring $sname...\n";
[691]176  if($requires_sql) {
[728]177    print "A copy of ${USER}'s SQL login info will be placed in\n/mit/$USER/web_scripts/$addrend.\n";
[691]178  }
[127]179 
[1229]180  if(-e $repo) {
[1224]181    # fake an empty commit to get version info
182    my $pid = open2(\*GIT_OUT, \*GIT_IN, "git commit-tree HEAD: -p HEAD") or die "Can't execute git process";
[1232]183    print GIT_IN "User autoinstalled application\n\n";
[1224]184    print GIT_IN "Installed-by: ", $ENV{'USER'}, '@', getclienthostname(), "\n";
185    close(GIT_IN);
186    my $hash=<GIT_OUT>;
187    chomp($hash);
188    close(GIT_OUT);
189    waitpid $pid, 0; # reap zombies
190    system("git reset $hash");
191  } else {
192    open(VERSION, ">.scripts-version") or die "Can't write scripts-version file: $!\n";
193    print VERSION strftime("%F %T %z\n", localtime);
194    print VERSION $ENV{'USER'}, '@', getclienthostname(), "\n";
195    my $tarball = abs_path("/mit/scripts/deploy$scriptsdev/$deploy.tar.gz");
196    print VERSION $tarball, "\n";
197    $tarball =~ s|/deploydev/|/deploy/|;
198    print VERSION dirname($tarball), "\n";
199    close(VERSION);
200  }
[127]201
202  select STDOUT;
203  $| = 1; # STDOUT is *hot*!
204}
[466]205
2061;
Note: See TracBrowser for help on using the repository browser.