source: trunk/locker/deploy/bin/onserver.pm @ 1215

Last change on this file since 1215 was 1215, checked in by ezyang, 15 years ago
Implement enhanced logic for Git-style installs; namely, removing patching facilities that are built into Git and generating an empty commit when performing the install to subsume .scripts-version.
File size: 4.7 KB
Line 
1package onserver;
2use strict;
3use Exporter;
4use Sys::Hostname;
5use File::Spec::Functions;
6use File::Basename;
7use Socket;
8use Cwd qw(abs_path);
9use POSIX qw(strftime);
10use LWP::UserAgent;
11use IPC::Open2;
12use URI;
13our @ISA = qw(Exporter);
14our @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);
15
16our $server = "scripts.mit.edu";
17
18our ($tmp, $USER, $HOME, $sname, $deploy, $addrend, $base_uri, $ua, $admin_username, $requires_sql, $addrlast, $sqlhost, $sqluser, $sqlpass, $sqldb, $admin_password, $scriptsdev, $human, $email);
19
20$tmp = ".scripts-tmp";
21sub totmp {
22  open(FILE, ">$tmp");
23  print FILE $_[0];
24  close(FILE);
25}
26
27$ua = LWP::UserAgent->new;
28push @{$ua->requests_redirectable}, 'POST';
29
30sub fetch_uri {
31    my ($uri, $get, $post) = @_;
32    my $u = URI->new($uri);
33    my $req;
34    if (defined $post) {
35        $u->query_form($post);
36        my $content = $u->query;
37        $u->query_form($get);
38        $req = HTTP::Request->new(POST => $u->abs($base_uri));
39        $req->content_type('application/x-www-form-urlencoded');
40        $req->content($content);
41    } else {
42        $u->query_form($get) if (defined $get);
43        $req = HTTP::Request->new(GET => $u->abs($base_uri));
44    }
45    my $res = $ua->request($req);
46    if ($res->is_success) {
47        return $res->content;
48    } else {
49        print STDERR "Error fetching configuration page: ", $res->status_line, "\n";
50        return undef;
51    }
52}
53
54sub print_login_info {
55  print "\nYou will be able to log in to $sname using the following:\n";
56  print "  username: $admin_username\n";
57  print "  password: $admin_password\n";
58}
59
60sub getclienthostname {
61    if (my $sshclient = $ENV{"SSH_CLIENT"}) {
62        my ($clientip) = split(' ', $sshclient);
63        my $hostname = gethostbyaddr(inet_aton($clientip), AF_INET);
64        return $hostname || $clientip;
65    } else {
66        return hostname();
67    }
68}
69
70sub press_enter {
71  local $/ = "\n";
72  print "Press [enter] to continue with the install.";
73  my $enter = <STDIN>; 
74}
75
76sub setup {
77  $ENV{PATH} = '/bin:/usr/bin';
78  $USER = $ENV{USER};
79  $HOME = $ENV{HOME};
80 
81  ($sname, $deploy, $addrend, $admin_username, $requires_sql, $scriptsdev, $human) = @ARGV;
82  chdir "$HOME/web_scripts/$addrend";
83  $email = "$human\@mit.edu";
84 
85  if($addrend =~ /^(.*)\/$/) {
86    $addrend = $1;
87  }
88  ($addrlast) = ($addrend =~ /([^\/]*)$/);
89 
90  $base_uri = "http://$server/~$USER/$addrend/";
91 
92  if($requires_sql) {
93    print "\nCreating SQL database for $sname...\n";
94   
95    open GETPWD, '-|', "/mit/scripts/sql/bin$scriptsdev/get-password";
96    ($sqlhost, $sqluser, $sqlpass) = split(/\s/, <GETPWD>);
97    close GETPWD;
98    open SQLDB, '-|', "/mit/scripts/sql/bin$scriptsdev/get-next-database", $addrlast;
99    $sqldb = <SQLDB>;
100    close SQLDB;
101    open SQLDB, '-|', "/mit/scripts/sql/bin$scriptsdev/create-database", $sqldb;
102    $sqldb = <SQLDB>;
103    close SQLDB;
104    if($sqldb eq "") {
105      print "\nERROR:\n";
106      print "Your SQL account failed to create a SQL database.\n";
107      print "You should log in at http://sql.mit.edu to check whether\n";
108      print "your SQL account is at its database limit or its storage limit.\n";
109      print "If you cannot determine the cause of the problem, please\n";
110      print "feel free to contact sql\@mit.edu for assistance.\n";
111      open FAILED, ">.failed";
112      close FAILED;
113      exit 1;
114    }
115  }
116 
117  if(-e "$HOME/web_scripts/$addrend/.admin") { 
118    open ADMIN, "<$HOME/web_scripts/$addrend/.admin";
119    $admin_password=<ADMIN>;
120    chomp($admin_password);
121    close ADMIN;
122    unlink "$HOME/web_scripts/$addrend/.admin";
123  } 
124
125  print "\nConfiguring $sname...\n";
126  if($requires_sql) {
127    print "A copy of ${USER}'s SQL login info will be placed in\n/mit/$USER/web_scripts/$addrend.\n";
128  }
129 
130  if(-e "/mit/scripts/wizard$scriptsdev/srv/$deploy.git") {
131    # fake an empty commit to get version info
132    my $pid = open2(\*GIT_OUT, \*GIT_IN, "git commit-tree HEAD: -p HEAD") or die "Can't execute git process";
133    print GIT_IN "User autoinstalled application\n";
134    print GIT_IN "Installed-by: ", $ENV{'USER'}, '@', getclienthostname(), "\n";
135    close(GIT_IN);
136    my $hash=<GIT_OUT>;
137    chomp($hash);
138    close(GIT_OUT);
139    waitpid $pid, 0; # reap zombies
140    system("git reset $hash");
141  } else {
142    open(VERSION, ">.scripts-version") or die "Can't write scripts-version file: $!\n";
143    print VERSION strftime("%F %T %z\n", localtime);
144    print VERSION $ENV{'USER'}, '@', getclienthostname(), "\n";
145    my $tarball = abs_path("/mit/scripts/deploy$scriptsdev/$deploy.tar.gz");
146    print VERSION $tarball, "\n";
147    $tarball =~ s|/deploydev/|/deploy/|;
148    print VERSION dirname($tarball), "\n";
149    close(VERSION);
150  }
151
152  select STDOUT;
153  $| = 1; # STDOUT is *hot*!
154}
155
1561;
Note: See TracBrowser for help on using the repository browser.