cgi/Git/RepoCGI.pm

   1 package Git::RepoCGI;
   2
   3 use strict;
   4 use warnings;
   5
   6 ### Administrativa
   7
   8 my ( $bin_path, $jail_path, $repomgr_path, $repodata_path, $repo_path );
   9 my ( $site_domain, $group_file, $user_file, $sshkeys_path, $doghouse_path );
  10 BEGIN {
  11         our $VERSION = '0.1';
  12         our @ISA = qw(Exporter);
  13         our @EXPORT = qw(genpwd scrypt html_esc jailed_file
  14                          lock_file unlock_file
  15                          filedb_atomic_append filedb_atomic_edit
  16                          proj_get_forkee_name proj_get_forkee_path
  17                          valid_proj_name valid_user_name valid_email valid_repo_url valid_web_url);
  18
  19         use CGI qw(:standard :escapeHTML -nosticky);
  20         use CGI::Util qw(unescape);
  21         use CGI::Carp qw(fatalsToBrowser);
  22         use Digest::SHA1 qw(sha1_hex);
  23         use Git::RepoCGI::Config;
  24
  25         $bin_path = $Git::RepoCGI::Config::defaults{bin_path};
  26         $jail_path = $Git::RepoCGI::Config::defaults{jail_path};
  27         $repomgr_path = $Git::RepoCGI::Config::defaults{repomgr_path};
  28         $repodata_path = $Git::RepoCGI::Config::defaults{repodata_path};
  29         $repo_path = $Git::RepoCGI::Config::defaults{repo_path};
  30
  31         $group_file = $Git::RepoCGI::Config::defaults{group_path};
  32         $user_file = $Git::RepoCGI::Config::defaults{user_file};
  33         $sshkeys_path = $Git::RepoCGI::Config::defaults{sshkeys_path};
  34         $doghouse_path = $Git::RepoCGI::Config::defaults{doghouse_path};
  35
  36         $site_domain = $Git::RepoCGI::Config::defaults{site_domain};
  37
  38         $ENV{PATH} = $bin_path . ':' . $ENV{PATH};
  39 }
  40
  41
  42 ### RepoCGI object
  43
  44 sub new {
  45         my $class = shift;
  46         my ($heading) = @_;
  47         my $repo = {};
  48
  49         $repo->{cgi} = CGI->new;
  50
  51         print $repo->{cgi}->header(-type=>'text/html', -charset => 'utf-8');
  52
  53         print <<EOT;
  54 <?xml version="1.0" encoding="utf-8"?>
  55 <!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">
  56 <html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en-US" lang="en-US">
  57
  58 <head>
  59 <title>$site_domain :: $heading</title>
  60 <link rel="stylesheet" type="text/css" href="/gitweb.css"/>
  61 <link rel="shortcut icon" href="/git-favicon.png" type="image/png"/>
  62 </head>
  63
  64 <body>
  65
  66 <div class="page_header">
  67 <a href="http://git.or.cz/" title="Git homepage"><img src="/git-logo.png" width="72" height="27" alt="git" style="float:right; border-width:0px;"/></a>
  68 <a href="/">$site_domain</a> / administration / $heading
  69 </div>
  70
  71 EOT
  72
  73         bless $repo, $class;
  74 }
  75
  76 sub DESTROY {
  77         my $self = shift;
  78         my $cgi = $self->cgi;
  79         my $cginame = $cgi->url(-absolute => 1);
  80         $cginame =~ s#^/m/##;
  81         if ($cginame =~ /^[a-zA-Z0-9_.\/-]+\.cgi$/) {
  82                 print <<EOT;
  83 <div align="right">
  84 <a href="http://$site_domain/w/repo.git?a=blob;f=cgi/$cginame">(view source)</a>
  85 </div>
  86 EOT
  87         }
  88         print <<EOT;
  89 </body>
  90 </html>
  91 EOT
  92 }
  93
  94 sub cgi {
  95         my $self = shift;
  96         $self->{cgi};
  97 }
  98
  99 sub bye {
 100         my $self = shift;
 101         print "<p>", @_, "</p>\n" if @_;
 102         exit
 103 }
 104
 105 sub err {
 106         my $self = shift;
 107         print "<p style=\"color: red\">@_</p>\n";
 108         $self->{err}++;
 109 }
 110
 111 sub err_check {
 112         my $self = shift;
 113         my $err = $self->{err};
 114         $err and print "<p style=\"font-weight: bold\">Operation aborted due to $err errors.</p>\n";
 115         $err;
 116 }
 117
 118 sub sparam {
 119         my ( $self, $param ) = @_;
 120         $self->{cgi}->param($param) || '';
 121 }
 122 sub wparam {
 123         my $self = shift;
 124         my $val = $self->sparam(@_);
 125         $val =~ s/^\s*(.*?)\s*$/$1/;
 126         $val;
 127 }
 128
 129
 130 ### Random utility functions
 131
 132 sub genpwd {
 133         # FLUFFY!
 134         substr(crypt(rand, rand), 2);
 135 }
 136
 137 sub scrypt {
 138         my ($pwd) = @_;
 139         crypt($pwd, join ('', ('.', '/', 2..9, 'A'..'Z', 'a'..'z')[rand 64, rand 64]));
 140 }
 141
 142 sub html_esc {
 143         my ($str) = @_;
 144         $str =~ s/&/&amp;/g;
 145         $str =~ s/</&lt;/g; $str =~ s/>/&gt;/g;
 146         $str =~ s/"/&quot;/g;
 147         $str;
 148 }
 149
 150 sub site_domain {
 151         return $site_domain;
 152 }
 153
 154 sub jailed_file {
 155         my ($filename) = @_;
 156         "$jail_path/$filename";
 157 }
 158
 159 sub lock_file {
 160         my ($path) = @_;
 161
 162         $path .= '.lock';
 163
 164         use Errno qw(EEXIST);
 165         use Fcntl qw(O_WRONLY O_CREAT O_EXCL);
 166         use IO::Handle;
 167         my $handle = new IO::Handle;
 168
 169         unless (sysopen($handle, $path, O_WRONLY|O_CREAT|O_EXCL)) {
 170                 my $cnt = 0;
 171                 while (not sysopen($handle, $path, O_WRONLY|O_CREAT|O_EXCL)) {
 172                         ($! == EEXIST) or die "$path open failed: $!";
 173                         ($cnt++ < 16) or die "$path open failed: cannot open lockfile";
 174                         sleep(1);
 175                 }
 176         }
 177         # XXX: filedb-specific
 178         chmod 0664, $path or die "$path g+w failed: $!";
 179
 180         $handle;
 181 }
 182
 183 sub unlock_file {
 184         my ($path) = @_;
 185
 186         rename "$path.lock", $path or die "$path unlock failed: $!";
 187 }
 188
 189 sub filedb_atomic_append {
 190         my ($file, $line) = @_;
 191         my $id = 65536;
 192
 193         open my $src, $file or die "$file open for reading failed: $!";
 194         my $dst = lock_file($file);
 195
 196         while (<$src>) {
 197                 my $aid = (split /:/)[2];
 198                 $id = $aid + 1 if ($aid >= $id);
 199
 200                 print $dst $_ or die "$file(l) write failed: $!";
 201         }
 202
 203         $line =~ s/\\i/$id/g;
 204         print $dst "$line\n" or die "$file(l) write failed: $!";
 205
 206         close $dst or die "$file(l) close failed: $!";
 207         close $src;
 208
 209         unlock_file($file);
 210
 211         $id;
 212 }
 213
 214 sub filedb_atomic_edit {
 215         my ($file, $fn) = @_;
 216
 217         open my $src, $file or die "$file open for reading failed: $!";
 218         my $dst = lock_file($file);
 219
 220         while (<$src>) {
 221                 print $dst $fn->($_) or die "$file(l) write failed: $!";
 222         }
 223
 224         close $dst or die "$file(l) close failed: $!";
 225         close $src;
 226
 227         unlock_file($file);
 228 }
 229
 230 sub proj_get_forkee_name {
 231         $_ = $_[0];
 232         (m#^(.*)/.*?$#)[0];
 233 }
 234 sub proj_get_forkee_path {
 235         my $forkee = $repo_path . proj_get_forkee_name($_[0]).'.git';
 236         -d $forkee ? $forkee : '';
 237 }
 238 sub valid_proj_name {
 239         $_ = $_[0];
 240         (not m#/# or -d proj_get_forkee_path($_)) # will also catch ^/
 241                 and (not m#\./#)
 242                 and (not m#/$#)
 243                 and m#^[a-zA-Z0-9+./_-]+$#;
 244 }
 245 sub valid_user_name {
 246         $_ = $_[0];
 247         /^[a-zA-Z0-9+._-]+$/;
 248 }
 249 sub valid_email {
 250         $_ = $_[0];
 251         /^[a-zA-Z0-9+._-]+@[a-zA-Z0-9-.]+$/;
 252 }
 253 sub valid_web_url {
 254         $_ = $_[0];
 255         /^http:\/\/[a-zA-Z0-9-.]+(\/[_\%a-zA-Z0-9.\/~-]*)?(#[a-zA-Z0-9._-]+)?$/;
 256 }
 257 sub valid_repo_url {
 258         $_ = $_[0];
 259         /^http:\/\/[a-zA-Z0-9-.]+(\/[_\%a-zA-Z0-9.\/~-]*)?$/ or
 260          /^git:\/\/[a-zA-Z0-9-.]+(\/[_\%a-zA-Z0-9.\/~-]*)?$/;
 261 }
 262
 263 sub load_project {
 264         my ( $self, $name ) = @_;
 265
 266         $self->bye("I need the project name as an argument now.")
 267                 unless $name;
 268
 269         $self->bye("Invalid project name. Go away, sorcerer.")
 270                 unless valid_proj_name($name);
 271
 272         $self->bye("Sorry but this project does not exist. "
 273                         . "Now, how did you <em>get</em> here?!")
 274                 unless Git::RepoCGI::Project::does_exist($name);
 275
 276         $self->bye("Sorry but your project has not finished mirroring yet.  "
 277                         . "If this process takes excessive time, "
 278                         . "please inform the site administrator.")
 279                 unless Git::RepoCGI::Project::available($name);
 280
 281         my $proj = Git::RepoCGI::Project->load($name);
 282         die "not found project $name, that's really weird!" unless $proj;
 283         $proj
 284 }
 285
 286 sub load_user {
 287         my ( $self, $name ) = @_;
 288         $self->bye("User '$name' is not registered.")
 289                 unless valid_user_name($name)
 290                         && Git::RepoCGI::User::does_exist($name);
 291
 292         my $user = Git::RepoCGI::User->load($name);
 293         $self->bye("User '$name' failed to load") unless $user;
 294         return $user;
 295 }
 296
 297 ### Project object
 298
 299 package Git::RepoCGI::Project;
 300
 301 BEGIN { use Git::RepoCGI; }
 302
 303 sub _mkdir_forkees {
 304         my $self = shift;
 305         my @pelems = split('/', $self->{name});
 306         pop @pelems; # do not create dir for the project itself
 307         my $path = $self->{base_path};
 308         foreach my $pelem (@pelems) {
 309                 $path .= "/$pelem";
 310                 (-d "$path") or mkdir $path or die "mkdir $path: $!";
 311                 chmod 0775, $path; # ok if fails (dir may already exist and be owned by someone else)
 312         }
 313 }
 314
 315 sub has_forks {
 316         my $self = shift;
 317         glob($self->{base_path} . '/' . $self->{name} . '/*');
 318 }
 319
 320 sub push_url {
 321         my $self = shift;
 322         my $name = $self->{name} . ".git";
 323         return "git+ssh://" . $site_domain . $self->{base_name} . "/" . $name;
 324 }
 325
 326 our %propmap = (
 327         url => 'base_url',
 328         email => 'owner',
 329         desc => 'description',
 330         README => 'README.html',
 331         hp => 'homepage',
 332 );
 333
 334 sub _property_path {
 335         my $self = shift;
 336         my ($name) = @_;
 337         $self->{path}.'/'.$name;
 338 }
 339
 340 sub _property_fget {
 341         my $self = shift;
 342         my ($name) = @_;
 343         $propmap{$name} or die "unknown property: $name";
 344         open P, $self->_property_path($propmap{$name}) or return undef;
 345         my @value = <P>;
 346         close P;
 347         my $value = join('', @value); chomp $value;
 348         $value;
 349 }
 350
 351 sub _property_fput {
 352         my $self = shift;
 353         my ($name, $value) = @_;
 354         $propmap{$name} or die "unknown property: $name";
 355
 356         my $P = lock_file($self->_property_path($propmap{$name}));
 357         $value ne '' and print $P "$value\n";
 358         close $P;
 359         unlock_file($self->_property_path($propmap{$name}));
 360 }
 361
 362 sub _properties_load {
 363         my $self = shift;
 364         foreach my $prop (keys %propmap) {
 365                 $self->{$prop} = $self->_property_fget($prop);
 366         }
 367 }
 368
 369 sub _properties_save {
 370         my $self = shift;
 371         foreach my $prop (keys %propmap) {
 372                 $self->_property_fput($prop, $self->{$prop});
 373         }
 374 }
 375
 376 sub _nofetch_path {
 377         my $self = shift;
 378         $self->_property_path('.nofetch');
 379 }
 380
 381 sub _nofetch {
 382         my $self = shift;
 383         my ($nofetch) = @_;
 384         my $np = $self->_nofetch_path;
 385         if ($nofetch) {
 386                 open X, '>'.$np or die "nofetch failed: $!";
 387                 close X;
 388         } else {
 389                 unlink $np or die "yesfetch failed: $!";
 390         }
 391 }
 392
 393 sub _alternates_setup {
 394         my $self = shift;
 395         return unless $self->{name} =~ m#/#;
 396         my $forkee_name = proj_get_forkee_name($self->{name});
 397         my $forkee_path = proj_get_forkee_path($self->{name});
 398         return unless -d $forkee_path;
 399         mkdir $self->{path}.'/refs'; chmod 0775, $self->{path}.'/refs';
 400         mkdir $self->{path}.'/objects'; chmod 0775, $self->{path}.'/objects';
 401         mkdir $self->{path}.'/objects/info'; chmod 0775, $self->{path}.'/objects/info';
 402
 403         # We set up both alternates and http_alternates since we cannot use
 404         # relative path in alternates - that doesn't work recursively.
 405
 406         my $filename = $self->{path}.'/objects/info/alternates';
 407         open X, '>'.$filename or die "alternates failed: $!";
 408         print X "$forkee_path/objects\n";
 409         close X;
 410         chmod 0664, $filename or warn "cannot chmod $filename: $!";
 411
 412         $filename = $self->{path}.'/objects/info/http-alternates';
 413         open X, '>'.$filename or die "http-alternates failed: $!";
 414         my $upfork = $forkee_name;
 415         do { print X "/r/$upfork.git/objects\n"; } while ($upfork =~ s#/?.+?$## and $upfork);
 416         close X;
 417         chmod 0664, $filename or warn "cannot chmod $filename: $!";
 418
 419         symlink "$forkee_path/refs", $self->{path}.'/refs/forkee';
 420 }
 421
 422 sub _ctags_setup {
 423         my $self = shift;
 424         mkdir $self->{path}.'/ctags'; chmod 0775, $self->{path}.'/ctags';
 425 }
 426
 427 sub _group_add {
 428         my $self = shift;
 429         my ($xtra) = @_;
 430         $xtra .= join(',', @{$self->{users}});
 431         filedb_atomic_append(jailed_file($group_file),
 432                 join(':', $self->{name}, $self->{crypt}, '\i', $xtra));
 433 }
 434
 435 sub _group_update {
 436         my $self = shift;
 437         my $xtra = join(',', @{$self->{users}});
 438         filedb_atomic_edit(jailed_file($group_file),
 439                 sub {
 440                         $_ = $_[0];
 441                         chomp;
 442                         if ($self->{name} eq (split /:/)[0]) {
 443                                 # preserve readonly flag
 444                                 s/::([^:]*)$/:$1/ and $xtra = ":$xtra";
 445                                 return join(':', $self->{name}, $self->{crypt}, $self->{gid}, $xtra)."\n";
 446                         } else {
 447                                 return "$_\n";
 448                         }
 449                 }
 450         );
 451 }
 452
 453 sub _group_remove {
 454         my $self = shift;
 455         filedb_atomic_edit(jailed_file($group_file),
 456                 sub {
 457                         $self->{name} ne (split /:/)[0] and return $_;
 458                 }
 459         );
 460 }
 461
 462 sub _hook_path {
 463         my $self = shift;
 464         my ($name) = @_;
 465         $self->{path}.'/hooks/'.$name;
 466 }
 467
 468 sub _hook_install {
 469         my $self = shift;
 470         my ($name) = @_;
 471         open SRC, "$repomgr_path/$name-hook" or die "cannot open hook $name: $!";
 472         open DST, '>'.$self->_hook_path($name) or die "cannot open hook $name for writing: $!";
 473         while (<SRC>) { print DST $_; }
 474         close DST;
 475         close SRC;
 476         chmod 0775, $self->_hook_path($name) or die "cannot chmod hook $name: $!";
 477 }
 478
 479 sub _hooks_install {
 480         my $self = shift;
 481         foreach my $hook ('update') {
 482                 $self->_hook_install($hook);
 483         }
 484 }
 485
 486 # private constructor, do not use
 487 sub _new {
 488         my $class = shift;
 489         my ($name, $base_path, $path) = @_;
 490         valid_proj_name($name) or die "refusing to create project with invalid name ($name)!";
 491         $path ||= "$base_path/$name.git";
 492         my $proj = { name => $name, base_path => $base_path, path => $path };
 493
 494         bless $proj, $class;
 495 }
 496
 497 # public constructor #0
 498 # creates a virtual project not connected to disk image
 499 # you can conjure() it later to disk
 500 sub ghost {
 501         my $class = shift;
 502         my ($name, $mirror) = @_;
 503
 504         my $path = $mirror ? "$repodata_path/to-clone" : $repo_path;
 505         my $repo = "$path/$name";
 506         $repo .= '.git' unless $mirror;
 507
 508         my $self = $class->_new($name, $path, $repo);
 509         $self->{users} = [];
 510         $self->{mirror} = $mirror;
 511         $self;
 512 }
 513
 514 # public constructor #1
 515 sub load {
 516         my $class = shift;
 517         my ($name) = @_;
 518
 519         open F, jailed_file($group_file) or die "project load failed: $!";
 520         while (<F>) {
 521                 chomp;
 522                 @_ = split /:+/;
 523                 next unless (shift eq $name);
 524
 525                 my $self = $class->_new($name, $repo_path);
 526                 (-d $self->{path}) or die "invalid path (".$self->{path}.") for project ".$self->{name};
 527
 528                 my $ulist;
 529                 ($self->{crypt}, $self->{gid}, $ulist) = @_;
 530                 $ulist ||= '';
 531                 $self->{users} = [split /,/, $ulist];
 532                 $self->{mirror} = ! -e $self->_nofetch_path;
 533                 $self->{ccrypt} = $self->{crypt};
 534
 535                 $self->_properties_load;
 536                 return $self;
 537         }
 538         close F;
 539         undef;
 540 }
 541
 542 # $proj may not be in sane state if this returns false!
 543 sub cgi_fill {
 544         my $self = shift;
 545         my ($repo) = @_;
 546         my $cgi = $repo->cgi;
 547
 548         my $pwd = $cgi->param('pwd');
 549         if ($pwd ne '' or not $self->{crypt}) {
 550                 $self->{crypt} = scrypt($pwd);
 551         }
 552
 553         if ($cgi->param('pwd2') and $pwd ne $cgi->param('pwd2')) {
 554                 $repo->err("Our high-paid security consultants have determined that the admin passwords you have entered do not match each other.");
 555         }
 556
 557         $self->{cpwd} = $cgi->param('cpwd');
 558
 559         $self->{email} = $repo->wparam('email');
 560         valid_email($self->{email})
 561                 or $repo->err("Your email sure looks weird...?");
 562
 563         $self->{url} = $repo->wparam('url');
 564         if ($self->{url}) {
 565                 valid_repo_url($self->{url})
 566                         or $repo->err("Invalid URL. Note that only HTTP and Git protocol is supported. If the URL contains funny characters, contact me.");
 567         }
 568
 569         $self->{desc} = $repo->wparam('desc');
 570         length($self->{desc}) <= 1024
 571                 or $repo->err("<b>Short</b> description length > 1kb!");
 572
 573         $self->{README} = $repo->wparam('README');
 574         length($self->{README}) <= 8192
 575                 or $repo->err("README length > 8kb!");
 576
 577         $self->{hp} = $repo->wparam('hp');
 578         if ($self->{hp}) {
 579                 valid_web_url($self->{hp})
 580                         or $repo->err("Invalid homepage URL. Note that only HTTP protocol is supported. If the URL contains funny characters, contact me.");
 581         }
 582
 583         # FIXME: Permit only existing users
 584         $self->{users} = [grep { valid_user_name($_) } $cgi->param('user')];
 585
 586         not $repo->err_check;
 587 }
 588
 589 sub form_defaults {
 590         my $self = shift;
 591         (
 592                 name => $self->{name},
 593                 email => $self->{email},
 594                 url => $self->{url},
 595                 desc => html_esc($self->{desc}),
 596                 README => html_esc($self->{README}),
 597                 hp => $self->{hp},
 598                 users => $self->{users},
 599         );
 600 }
 601
 602 sub authenticate {
 603         my $self = shift;
 604         my ($repo) = @_;
 605
 606         $self->{ccrypt} or die "Can't authenticate against a project with no password";
 607         $self->{cpwd} or $repo->err("No password entered.");
 608         unless ($self->{ccrypt} eq crypt($self->{cpwd}, $self->{ccrypt})) {
 609                 $repo->err("Your admin password does not match!");
 610                 return 0;
 611         }
 612         return 1;
 613 }
 614
 615 sub premirror {
 616         my $self = shift;
 617
 618         $self->_mkdir_forkees;
 619         mkdir $self->{path} or die "mkdir failed: $!";
 620         chmod 0775, $self->{path} or die "chmod failed: $!";
 621         $self->_properties_save;
 622         $self->_alternates_setup;
 623         $self->_ctags_setup;
 624         $self->_group_add(':');
 625 }
 626
 627 sub conjure {
 628         my $self = shift;
 629
 630         $self->_mkdir_forkees;
 631         system('cg-admin-setuprepo', '-g', 'repo', $self->{path}) == 0
 632                 or die "cg-admin-setuprepo failed: $?";
 633         system('git', '--git-dir='.$self->{path}, 'config', 'receive.denyNonFastforwards', 'false');
 634         $self->_nofetch(1);
 635         $self->_properties_save;
 636         $self->_alternates_setup;
 637         $self->_ctags_setup;
 638         $self->_group_add;
 639         $self->_hooks_install;
 640 }
 641
 642 sub update {
 643         my $self = shift;
 644
 645         $self->_properties_save;
 646         $self->_group_update;
 647 }
 648
 649 sub update_password {
 650         my $self = shift;
 651         my ($pwd) = @_;
 652
 653         $self->{crypt} = scrypt($pwd);
 654         $self->_group_update;
 655 }
 656
 657 # You can explicitly do this just on a ghost() repository too.
 658 sub delete {
 659         my $self = shift;
 660
 661         if (-d $self->{path}) {
 662                 system('rm', '-r', $self->{path}) == 0
 663                         or die "rm -r failed: $?";
 664         }
 665         $self->_group_remove;
 666 }
 667
 668 # static method
 669 sub does_exist {
 670         my ($name) = @_;
 671         valid_proj_name($name) or die "tried to query for project with invalid name $name!";
 672         (available($name)
 673                 or -d "$repodata_path/cloning/$name"
 674                 or -d "$repodata_path/to-clone/$name");
 675 }
 676 sub available {
 677         my ($name) = @_;
 678         valid_proj_name($name) or die "tried to query for project with invalid name $name!";
 679         (-d "$repo_path/$name.git");
 680 }
 681
 682 # watchdog method
 683 sub load_watchdogs {
 684         my ( $self, %opts ) = @_;
 685         return Git::RepoCGI::Watch::load_watchdogs(%opts,
 686                 type=> 'project', name => $self->{name});
 687 }
 688
 689 ### User object
 690
 691 package Git::RepoCGI::User;
 692
 693 BEGIN { use Git::RepoCGI; }
 694
 695 sub _passwd_text {
 696         my $self = shift;
 697         join(':', $self->{name}, $self->{crypt}, $self->{uid}, 65534, $self->{email}, '/', '/bin/git-shell')
 698 }
 699
 700 sub _user_update {
 701         my $self = shift;
 702         my $xtra = join(',', @{$self->{users}});
 703         filedb_atomic_edit(jailed_file($user_file),
 704                 sub {
 705                         $_ = $_[0];
 706                         chomp;
 707                         if ($self->{name} eq (split /:/)[0]) {
 708                                 return $self->_passwd_text . "\n";
 709                         } else {
 710                                 return "$_\n";
 711                         }
 712                 }
 713         );
 714 }
 715
 716 sub _passwd_add {
 717         my $self = shift;
 718         $self->{uid} = '\i';
 719         filedb_atomic_append(jailed_file($user_file), $self->_passwd_text);
 720 }
 721
 722 sub update_password {
 723         my $self = shift;
 724         my ($pwd) = @_;
 725
 726         $self->{crypt} = scrypt($pwd);
 727         $self->_user_update;
 728 }
 729 sub authenticate {
 730         my $self = shift;
 731         my ($repo) = @_;
 732
 733         $self->{ccrypt} or die "Can't authenticate against a user with no password";
 734         $self->{cpwd} or $repo->err("No password entered.");
 735         unless ($self->{ccrypt} eq crypt($self->{cpwd}, $self->{ccrypt})) {
 736                 $repo->err("Your admin password does not match!");
 737                 return 0;
 738         }
 739         return 1;
 740 }
 741
 742 sub _sshkey_path {
 743         my $self = shift;
 744         $sshkeys_path . '/' . $self->{name};
 745 }
 746
 747 sub _sshkey_load {
 748         my $self = shift;
 749         open F, "<".jailed_file($self->_sshkey_path) or die "sshkey load failed: $!";
 750         my @keys;
 751         my $auth;
 752         while (<F>) {
 753                 chomp;
 754                 if (/^ssh-(?:dss|rsa) /) {
 755                         push @keys, $_;
 756                 } elsif (/^# REPOAUTH ([0-9a-f]+) (\d+)/) {
 757                         my $expire = $2;
 758                         $auth = $1 unless (time >= $expire);
 759                 }
 760         }
 761         close F;
 762         my $keys = join('', @keys); chomp $keys;
 763         ($keys, $auth);
 764 }
 765
 766 sub _sshkey_save {
 767         my $self = shift;
 768         open F, ">".jailed_file($self->_sshkey_path) or die "sshkey failed: $!";
 769         if (defined($self->{auth}) && $self->{auth}) {
 770                 my $expire = time + 24 * 3600;
 771                 print F "# REPOAUTH $self->{auth} $expire\n";
 772         }
 773         print F $self->{keys}."\n";
 774         close F;
 775         chmod 0664, jailed_file($self->_sshkey_path);
 776 }
 777
 778 # private constructor, do not use
 779 sub _new {
 780         my $class = shift;
 781         my ($name) = @_;
 782         valid_user_name($name) or die "refusing to create user with invalid name ($name)!";
 783         my $proj = { name => $name };
 784
 785         bless $proj, $class;
 786 }
 787
 788 # public constructor #0
 789 # creates a virtual user not connected to disk record
 790 # you can conjure() it later to disk
 791 sub ghost {
 792         my $class = shift;
 793         my ($name) = @_;
 794         my $self = $class->_new($name);
 795         $self;
 796 }
 797
 798 # public constructor #1
 799 sub load {
 800         my $class = shift;
 801         my ($name) = @_;
 802
 803         open F, jailed_file($user_file) or die "user load failed: $!";
 804         while (<F>) {
 805                 chomp;
 806                 @_ = split /:+/;
 807                 next unless (shift eq $name);
 808
 809                 my $self = $class->_new($name);
 810
 811                 ($self->{crypt}, $self->{uid}, undef, $self->{email}) = @_;
 812                 ($self->{keys}, $self->{auth}) = $self->_sshkey_load;
 813                 $self->{ccrypt} = $self->{crypt};
 814
 815                 return $self;
 816         }
 817         close F;
 818         undef;
 819 }
 820
 821 # $user may not be in sane state if this returns false!
 822 sub cgi_fill {
 823         my $self = shift;
 824         my ($repo) = @_;
 825
 826         $self->{name} = $repo->wparam('name');
 827         valid_user_name($self->{name})
 828                 or $repo->err("Name contains invalid characters.");
 829
 830         $self->{email} = $repo->wparam('email');
 831         valid_email($self->{email})
 832                 or $repo->err("Your email sure looks weird...?");
 833
 834         my $pwd = $repo->sparam('pwd');
 835         if ($pwd ne '' or not $self->{crypt}) {
 836                 $self->{crypt} = scrypt($pwd);
 837         }
 838
 839         if ($repo->sparam('pwd2') and $pwd ne $repo->sparam('pwd2')) {
 840                 $repo->err("Our high-paid security consultants have determined that the passwords you have entered do not match each other.");
 841         }
 842
 843         $self->{cpwd} = $repo->sparam('cpwd');
 844
 845         $self->keys_fill($repo);
 846 }
 847
 848 sub keys_fill {
 849         my $self = shift;
 850         my ($repo) = @_;
 851         my $cgi = $repo->cgi;
 852
 853         $self->{keys} = $cgi->param('keys');
 854         length($self->{keys}) <= 4096
 855                 or $repo->err("The list of keys is more than 4kb. Do you really need that much?");
 856         foreach (split /\r?\n/, $self->{keys}) {
 857                 /^ssh-(?:dss|rsa) .* \S+@\S+$/ or $repo->err("Your ssh key (\"$_\") appears to have invalid format (does not start by ssh-dss|rsa or does not end with @-identifier) - maybe your browser has split a single key to multiple lines?");
 858         }
 859
 860         not $repo->err_check;
 861 }
 862
 863 sub keys_save {
 864         my $self = shift;
 865
 866         $self->_sshkey_save;
 867 }
 868
 869 sub gen_auth {
 870         my $self = shift;
 871
 872         $self->{auth} = Digest::SHA1::sha1_hex(time . $$ . rand() . $self->{keys});
 873         $self->_sshkey_save;
 874         $self->{auth};
 875 }
 876
 877 sub del_auth {
 878         my $self = shift;
 879
 880         delete $self->{auth};
 881 }
 882
 883 sub conjure {
 884         my $self = shift;
 885
 886         $self->_passwd_add;
 887         $self->_sshkey_save;
 888 }
 889
 890 # static method
 891 sub does_exist {
 892         my ($name) = @_;
 893         valid_user_name($name) or die "tried to query for user with invalid name $name!";
 894         (-e jailed_file("$sshkeys_path/$name"));
 895 }
 896 sub available {
 897         does_exist(@_);
 898 }
 899
 900 # watchdog method
 901 sub load_watchdogs {
 902         my ( $self, %opts ) = @_;
 903         return Git::RepoCGI::Watch::load_watchdogs(%opts,
 904                 type=> 'user', name => $self->{name});
 905 }
 906
 907 ### Watch object
 908
 909 package Git::RepoCGI::Watch;
 910
 911 BEGIN { use Git::RepoCGI; }
 912
 913 # public constructor #1
 914 sub new {
 915         my ( $class, $user, $project, $branch, $path ) = @_;
 916         my $self = { user => $user,
 917                 project => $project, branch => $branch, path => $path };
 918         bless $self, $class;
 919 }
 920
 921 sub _try_match {
 922         my ( $self, $opts, $key ) = @_;
 923         # if watchdog does not specify it, then it matches
 924         return 1 unless $self->{$key};
 925         my $val = $self->{$key};
 926         return $opts->{$key} =~ qr/$val/;
 927 }
 928
 929 sub match {
 930         my ( $self, %opts ) = @_;
 931         my @match_keys = qw( project branch path user );
 932         return ! grep { !$self->_try_match(\%opts, $_) } @match_keys;
 933 }
 934
 935 sub _find_keys {
 936         my ( $self, $key, $opts ) = @_;
 937         for ($opts->{type}) {
 938         /^project$/ and do { return ( $key, $opts->{name} ) };
 939         /^user$/ and do { return ( $opts->{name}, $key ) };
 940         die "unknown type of watchdog: $_";
 941         }
 942 }
 943 # constructor: loads all watchdogs
 944 #   Valid options:
 945 #       type => 'project' or 'user'
 946 #       name => name of the project or user
 947 #       user, project, branch, path => regular expression filters
 948 #   Returns a list of watchdog objects
 949 sub load {
 950         my ( %opts ) = @_;
 951         my $doghouse = "$doghouse_path/$opts{type}/$opts{name}";
 952         return () unless -f $doghouse;
 953
 954         open F, jailed_file($doghouse) or die "loading '$doghouse' failed: $!";
 955         my @dogs = ();
 956         while (<F>) {
 957                 chomp;
 958                 my ( $key, $branch, $path ) = @_ = split /:+/;
 959                 my ( $user, $project ) = _find_keys($key, \%opts);
 960
 961                 my $dog = __PACKAGE__->new($user, $project, $branch, $path);
 962                 next unless $dog->match(%opts);
 963
 964                 for ($opts{type}) {
 965                 /^user$/ and do {
 966                         my $proj = Git::RepoCGI::Project->_new($project, $repo_path);
 967                         die "invalid watchdog for user $user: "
 968                                         . "project '$project' is missing."
 969                                 unless -d $proj->{path};
 970                 };
 971                 /^project$/ and do {
 972                         die "invalid watchdog for project $project: "
 973                                         . "user '$user' is not valid."
 974                                 unless valid_user_name($user);
 975                 };
 976                 die "unknown type of watchdog: $_";
 977                 }
 978                 push @dogs, $dog;
 979         }
 980         close F;
 981         return @dogs;
 982 }
 983
 984 sub authenticate {
 985         my ( $self, $repo ) = @_;
 986
 987         my $cpwd = $repo->sparam('cpwd');
 988         my $user = $repo->load_user($self->{user});
 989         $user->{cpwd} = $cpwd;
 990         return 1 if $user->authenticate($repo);
 991
 992         my $proj = $repo->load_project($self->{project});
 993         $proj->{cpwd} = $cpwd;
 994         $repo->bye("Authentication failed") unless $proj->authenticate($repo);
 995
 996 }
 997 sub _watch_file {
 998         my ( $self, $type ) = @_;
 999         my $key = $self->{$type};
1000         return jailed_file("$doghouse_path/$type/$key");
1001 }
1002
1003 sub add {
1004         my ( $self ) = @_;
1005
1006         my ( $user, $project, $branch, $path ) =
1007                         map { $self->{$_} } qw( user project branch path );
1008         filedb_atomic_append($self->_watch_file('user'),
1009                 join(':', $project, $branch, $path));
1010         filedb_atomic_append($self->_watch_file('project'),
1011                 join(':', $user, $branch, $path));
1012 }
1013 sub remove {
1014         my ( $self ) = @_;
1015         my $remove_args = sub {
1016                 my $key = $_[0];
1017                 my $e = sub { $self->{$key} ne (split /:/)[0] and return $_ };
1018                 ( $self->_watch_file($key), $e ) };
1019         filedb_atomic_edit($remove_args->('user'));
1020         filedb_atomic_edit($remove_args->('project'));
1021 }
1022
1023 1;