cgi/p/editproj.cgi

   1 #!/usr/bin/perl
   2 # (c) Petr Baudis <pasky@suse.cz>
   3 # GPLv2
   4
   5 use strict;
   6 use warnings;
   7
   8 use lib qw(/home/repo/repomgr/cgi);
   9 use Git::RepoCGI;
  10
  11 my $repo = Git::RepoCGI->new('Project Settings');
  12 my $cgi = $repo->cgi;
  13
  14 my $name = $cgi->remote_user();
  15
  16 if (! -d "/srv/git/$name.git") {
  17   print "<p>Sorry but your project has not finished mirroring yet. If it takes inordinate amount of time, please tell the administrator.</p>\n";
  18   exit;
  19 }
  20
  21 sub load_project {
  22   my ($name) = @_;
  23   my ($email, $url, $desc, $hp, $crypt, $gid, @users);
  24   open F, "/home/repo/j/etc/group" or die "load_project failed: $!";
  25   while (<F>) {
  26     chomp;
  27     @_ = split /:+/;
  28     next unless (shift eq $name);
  29
  30     my $ulist;
  31     ($crypt, $gid, $ulist) = @_;
  32     @users = split /,/, $ulist;
  33
  34     open G, "/srv/git/$name.git/base_url" or die "base_url failed: $!"; chomp($url = <G>); close G;
  35     open G, "/srv/git/$name.git/owner" or die "owner failed: $!"; chomp($email = <G>); close G;
  36     open G, "/srv/git/$name.git/description" or die "desc failed: $!"; chomp($desc = <G>); close G;
  37     open G, "/srv/git/$name.git/homepage" or die "hp failed: $!"; chomp($hp = <G>); close G;
  38
  39     return ($email, $url, $desc, $hp, $crypt, $gid, @users);
  40   }
  41   close F;
  42   die "not found project $name, that's really weird!";
  43 }
  44
  45 my ($email, $url, $desc, $hp, $crypt, $gid, @users) = load_project($name);
  46
  47 sub scrypt {
  48   my ($pwd) = @_;
  49   crypt($pwd, join ('', ('.', '/', 0..9, 'A'..'Z', 'a'..'z')[rand 64, rand 64]));
  50 }
  51
  52 sub save_proj_data {
  53   my ($path, $url, $email, $desc, $hp) = @_;
  54   open F, ">$path/base_url" or die "base_url failed: $!"; print F "$url\n"; close F;
  55   open F, ">$path/owner" or die "owner failed: $!"; print F "$email\n"; close F;
  56   open F, ">$path/description" or die "desc failed: $!"; print F "$desc\n"; close F;
  57   open F, ">$path/homepage" or die "hp failed: $!"; print F "$hp\n"; close F;
  58 }
  59
  60 sub edit_group {
  61   my ($gid, $name, $pwd, $xtra) = @_;
  62   # racy!
  63   # at least basic protection, but there's still race window; I suck
  64   my ($size, $__, $mtime) = splice(@{[stat "/home/repo/j/etc/group"]}, 7, 3);
  65   open F, "/home/repo/j/etc/group" or die "group failed: $!";
  66   open G, ">/home/repo/j/etc/group.$$" or die "repogroup failed: $!";
  67   while (<F>) {
  68     chomp;
  69     if ($name eq (split /:/)[0]) {
  70       s/::([^:]*)$/:$1/ and $xtra = ":$xtra";
  71       print G "$name:$pwd:$gid:$xtra\n";
  72     } else {
  73       print G "$_\n";
  74     }
  75   }
  76   close G;
  77   close F;
  78   my ($size2, $__2, $mtime2) = splice(@{[stat "/home/repo/j/etc/group"]}, 7, 3);
  79   if ($size2 ne $size or $mtime2 ne $mtime) {
  80     die "sorry, hit a race window; please try submitting again";
  81   }
  82   chmod 0664, "/home/repo/j/etc/group.$$" or die "chmod failed: $!";
  83   rename "/home/repo/j/etc/group.$$", "/home/repo/j/etc/group" or die "rename failed: $!";
  84 }
  85
  86 sub update_project {
  87   my ($gid, $name, $pwd, $email, $url, $desc, $hp, @users) = @_;
  88   save_proj_data("/srv/git/$name.git", $url, $email, $desc, $hp);
  89   edit_group($gid, $name, $pwd, join(',', @users));
  90   print "<p>Project successfuly updated.</p>\n";
  91 }
  92
  93 if ($cgi->param('email')) {
  94   # submitted, let's see
  95   # FIXME: racy, do a lock
  96   $email = $repo->wparam('email');
  97   $url = $repo->wparam('url');
  98   $desc = $repo->wparam('desc');
  99   $hp = $repo->wparam('hp');
 100   @users = grep { $_ =~ /^[a-zA-Z0-9_+-]+$/ } $cgi->param('user');
 101   my $pwd = $cgi->param('pwd');
 102   if ($url) {
 103     $url =~ /^http:\/\/[a-zA-Z0-9-.]+\/[_\%a-zA-Z0-9.\/~-]+$/ or
 104     $url =~ /^git:\/\/[a-zA-Z0-9-.]+\/[_\%a-zA-Z0-9.\/~-]+$/
 105       or $repo->err "Invalid URL. Note that only HTTP and Git protocol is supported. If the URL contains funny characters, contact me.";
 106   }
 107   if ($hp) {
 108     $hp =~ /^http:\/\/[a-zA-Z0-9-.]+\/[_\%a-zA-Z0-9.\/~-]+$/
 109       or $repo->err "Invalid homepage URL. Note that only HTTP protocol is supported. If the URL contains funny characters, contact me.";
 110   }
 111   $email =~ /^[a-zA-Z0-9+._-]+@[a-zA-Z0-9-.]+$/
 112     or $repo->err "Your email sure looks weird...?";
 113   length($desc) <= 1024
 114       or $repo->err "<b>Short</b> description length > 1kb!";
 115   unless ($repo->err_check) {
 116     if ($pwd) {
 117       $pwd = scrypt($pwd);
 118     } else {
 119       $pwd = $crypt;
 120     }
 121     update_project($gid, $name, $pwd, $email, $url, $desc, $hp, @users);
 122   }
 123 }
 124
 125 my $hesc = html_esc($desc);
 126
 127 print <<EOT;
 128 <p>Here you can adjust project settings. Go wild. Only you can currently enable access only for a single user at a time so perhaps you will need to click a lot.</p>
 129 <form method="post">
 130 <p>Project name (w/o the .git suffix): $name</p>
 131 <p>Admin password: <input type="password" name="pwd" /> (leave empty to keep it at the current value)</p>
 132 <p>E-mail contact: <input type="text" name="email" value="$email" /></p>
 133 <p>Repository URL: <input type="text" name="url" value="$url" /></p>
 134 <p>Description: <input type="text" name="desc" value="$desc" /></p>
 135 <p>Homepage URL: <input type="text" name="hp" value="$hp" /></p>
 136 <p>Users:</p>
 137 <ul>
 138 EOT
 139 foreach my $user (@users) {
 140   print "<li><input type=\"checkbox\" name=\"user\" value=\"$user\" checked=\"1\" /> $user</li>\n";
 141 }
 142 print <<EOT;
 143 <li>Add user: <input type="text" name="user" /></li>
 144 </ul>
 145 <p><input type="submit" name="y0" value="Update" /></p>
 146 </form>
 147 EOT