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

Last change on this file since 1216 was 1216, checked in by ezyang, 13 years ago
Move copy functionality onto scripts server to remove dependence on Git locker.
File size: 6.6 KB
Line 
1package onserver;
2use strict;
3use Exporter;
4use Sys::Hostname;
5use File::Spec::Functions;
6use File::Basename;
7use File::Copy;
8use Socket;
9use Cwd qw(abs_path);
10use POSIX qw(strftime);
11use LWP::UserAgent;
12use IPC::Open2;
13use URI;
14our @ISA = qw(Exporter);
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);
16
17our $server = "scripts.mit.edu";
18
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);
20
21$tmp = ".scripts-tmp";
22sub totmp {
23  open(FILE, ">$tmp");
24  print FILE $_[0];
25  close(FILE);
26}
27
28$ua = LWP::UserAgent->new;
29push @{$ua->requests_redirectable}, 'POST';
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
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
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
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 
82  ($lname, $sname, $deploy, $addrend, $admin_username, $requires_sql, $scriptsdev, $human) = @ARGV;
83  chdir "$HOME/web_scripts/$addrend";
84  $email = "$human\@mit.edu";
85 
86  if($addrend =~ /^(.*)\/$/) {
87    $addrend = $1;
88  }
89  ($addrlast) = ($addrend =~ /([^\/]*)$/);
90 
91  $base_uri = "http://$server/~$USER/$addrend/";
92 
93  if($requires_sql) {
94    print "\nCreating SQL database for $sname...\n";
95   
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;
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";
112      open FAILED, ">.failed";
113      close FAILED;
114      exit 1;
115    }
116  }
117 
118  if(-e "$HOME/web_scripts/$addrend/.admin") { 
119    open ADMIN, "<$HOME/web_scripts/$addrend/.admin";
120    $admin_password=<ADMIN>;
121    chomp($admin_password);
122    close ADMIN;
123    unlink "$HOME/web_scripts/$addrend/.admin";
124  } 
125
126  # This code was originally in onathena
127  my $repo = "/mit/scripts/wizard$scriptsdev/srv/$deploy.git";
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 $!;
135    print HTACCESS "Deny from all";
136    close HTACCESS;
137    open ALTERNATES, '>', '.git/objects/info/alternates' or die $!;
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
175  print "\nConfiguring $sname...\n";
176  if($requires_sql) {
177    print "A copy of ${USER}'s SQL login info will be placed in\n/mit/$USER/web_scripts/$addrend.\n";
178  }
179 
180  if(-e "/mit/scripts/wizard$scriptsdev/srv/$deploy.git") {
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";
183    print GIT_IN "User autoinstalled application\n";
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  }
201
202  select STDOUT;
203  $| = 1; # STDOUT is *hot*!
204}
205
2061;
Note: See TracBrowser for help on using the repository browser.