cgi/Git/RepoCGI.pm

   1 package Git::RepoCGI;
   2
   3 use strict;
   4 use warnings;
   5
   6 $Git::RepoCGI::basedir = '/home/repo/repomgr'; # path to the Girocco files (checkout of this project)
   7 $Git::RepoCGI::mqueuedir = '/home/repo/repodata'; # path to the directory of the mirror queue
   8 $Git::RepoCGI::chroot = "/home/repo/j"; # ssh push chroot
   9 $Git::RepoCGI::reporoot = "/srv/git"; # repository collection
  10 $Git::RepoCGI::name = "repo.or.cz"; # title of the service
  11 $Git::RepoCGI::gitweburl = "http://repo.or.cz/w"; # URL of gitweb (pathinfo mode)
  12 $Git::RepoCGI::webadmurl = "http://repo.or.cz/m"; # URL of the 'repo' CGI web admin interface
  13 $Git::RepoCGI::httppullurl = "http://repo.or.cz/r"; # HTTP URL of the repository collection
  14 $Git::RepoCGI::gitpullurl = "git://repo.or.cz/"; # Git URL of the repository collection
  15 $Git::RepoCGI::pushurl = "ssh://repo.or.cz/srv/git"; # Pushy URL of the repository collection
  16 $Git::RepoCGI::jurisdiction = "Czech Republic"; # legal jurisdiction of the site
  17 $Git::RepoCGI::giroccourl = "$Git::RepoCGI::gitweburl/repo.git"; # URL of gitweb of this Girocco instance (set as undef if you're not nice to the community)
  18 $Git::RepoCGI::mob = "mob"; # set to undef to disable the special 'mob' user
  19 $Git::RepoCGI::moburl = "/mob.html"; # URL of the explanation of the mob user
  20 $Git::RepoCGI::mirror = 1; # enable mirroring mode
  21 $Git::RepoCGI::push = 1; # enable push mode
  22 $Git::RepoCGI::group = 'repo'; # UNIX group owning the repositories
  23 $Git::RepoCGI::git_bin = '/home/pasky/bin/git'; # path to Git binary to use
  24
  25 ### Administrativa
  26
  27 BEGIN {
  28         our $VERSION = '0.1';
  29         our @ISA = qw(Exporter);
  30         our @EXPORT = qw(scrypt html_esc jailed_file
  31                          lock_file unlock_file
  32                          filedb_atomic_append filedb_atomic_edit
  33                          proj_get_forkee_name proj_get_forkee_path
  34                          valid_proj_name valid_user_name valid_email valid_repo_url valid_web_url);
  35
  36         use CGI qw(:standard :escapeHTML -nosticky);
  37         use CGI::Util qw(unescape);
  38         use CGI::Carp qw(fatalsToBrowser);
  39         use Digest::SHA1 qw(sha1_hex);
  40 }
  41
  42
  43 ### RepoCGI object
  44
  45 sub new {
  46         my $class = shift;
  47         my ($heading) = @_;
  48         my $repo = {};
  49
  50         $repo->{cgi} = CGI->new;
  51
  52         print $repo->{cgi}->header(-type=>'text/html', -charset => 'utf-8');
  53
  54         print <<EOT;
  55 <?xml version="1.0" encoding="utf-8"?>
  56 <!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">
  57 <html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en-US" lang="en-US">
  58
  59 <head>
  60 <title>$Git::RepoCGI::name :: $heading</title>
  61 <link rel="stylesheet" type="text/css" href="/gitweb.css"/>
  62 <link rel="shortcut icon" href="/git-favicon.png" type="image/png"/>
  63 </head>
  64
  65 <body>
  66
  67 <div class="page_header">
  68 <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>
  69 <a href="/">$Git::RepoCGI::name</a> / administration / $heading
  70 </div>
  71
  72 EOT
  73
  74         bless $repo, $class;
  75 }
  76
  77 sub DESTROY {
  78         my $self = shift;
  79         my $cgi = $self->cgi;
  80         my $cgiurl = $cgi->url(-absolute => 1);
  81         my ($cginame) = ($cgiurl =~ m#^.*/\([a-zA-Z0-9_.\/-]+?\.cgi\)$#); #
  82         if ($cginame and $Git::RepoCGI::giroccourl) {
  83                 print <<EOT;
  84 <div align="right">
  85 <a href="$Git::RepoCGI::giroccourl?a=blob;f=cgi/$cginame">(view source)</a>
  86 </div>
  87 EOT
  88         }
  89         print <<EOT;
  90 </body>
  91 </html>
  92 EOT
  93 }
  94
  95 sub cgi {
  96         my $self = shift;
  97         $self->{cgi};
  98 }
  99
 100 sub err {
 101         my $self = shift;
 102         print "<p style=\"color: red\">@_</p>\n";
 103         $self->{err}++;
 104 }
 105
 106 sub err_check {
 107         my $self = shift;
 108         my $err = $self->{err};
 109         $err and print "<p style=\"font-weight: bold\">Operation aborted due to $err errors.</p>\n";
 110         $err;
 111 }
 112
 113 sub wparam {
 114         my $self = shift;
 115         my ($param) = @_;
 116         my $val = $self->{cgi}->param($param);
 117         $val =~ s/^\s*(.*?)\s*$/$1/;
 118         $val;
 119 }
 120
 121
 122 ### Random utility functions
 123
 124 sub scrypt {
 125         my ($pwd) = @_;
 126         crypt($pwd, join ('', ('.', '/', 2..9, 'A'..'Z', 'a'..'z')[rand 64, rand 64]));
 127 }
 128
 129 sub html_esc {
 130         my ($str) = @_;
 131         $str =~ s/&/&amp;/g;
 132         $str =~ s/</&lt;/g; $str =~ s/>/&gt;/g;
 133         $str =~ s/"/&quot;/g;
 134         $str;
 135 }
 136
 137 sub jailed_file {
 138         my ($filename) = @_;
 139         $Git::RepoCGI::chroot."/$filename";
 140 }
 141
 142 sub lock_file {
 143         my ($path) = @_;
 144
 145         $path .= '.lock';
 146
 147         use Errno qw(EEXIST);
 148         use Fcntl qw(O_WRONLY O_CREAT O_EXCL);
 149         use IO::Handle;
 150         my $handle = new IO::Handle;
 151
 152         unless (sysopen($handle, $path, O_WRONLY|O_CREAT|O_EXCL)) {
 153                 my $cnt = 0;
 154                 while (not sysopen($handle, $path, O_WRONLY|O_CREAT|O_EXCL)) {
 155                         ($! == EEXIST) or die "$path open failed: $!";
 156                         ($cnt++ < 16) or die "$path open failed: cannot open lockfile";
 157                         sleep(1);
 158                 }
 159         }
 160         # XXX: filedb-specific
 161         chmod 0664, $path or die "$path g+w failed: $!";
 162
 163         $handle;
 164 }
 165
 166 sub unlock_file {
 167         my ($path) = @_;
 168
 169         rename "$path.lock", $path or die "$path unlock failed: $!";
 170 }
 171
 172 sub filedb_atomic_append {
 173         my ($file, $line) = @_;
 174         my $id = 65536;
 175
 176         open my $src, $file or die "$file open for reading failed: $!";
 177         my $dst = lock_file($file);
 178
 179         while (<$src>) {
 180                 my $aid = (split /:/)[2];
 181                 $id = $aid + 1 if ($aid >= $id);
 182
 183                 print $dst $_ or die "$file(l) write failed: $!";
 184         }
 185
 186         $line =~ s/\\i/$id/g;
 187         print $dst "$line\n" or die "$file(l) write failed: $!";
 188
 189         close $dst or die "$file(l) close failed: $!";
 190         close $src;
 191
 192         unlock_file($file);
 193
 194         $id;
 195 }
 196
 197 sub filedb_atomic_edit {
 198         my ($file, $fn) = @_;
 199
 200         open my $src, $file or die "$file open for reading failed: $!";
 201         my $dst = lock_file($file);
 202
 203         while (<$src>) {
 204                 print $dst $fn->($_) or die "$file(l) write failed: $!";
 205         }
 206
 207         close $dst or die "$file(l) close failed: $!";
 208         close $src;
 209
 210         unlock_file($file);
 211 }
 212
 213 sub proj_get_forkee_name {
 214         $_ = $_[0];
 215         (m#^(.*)/.*?$#)[0];
 216 }
 217 sub proj_get_forkee_path {
 218         my $forkee = $Git::RepoCGI::reporoot.'/'.proj_get_forkee_name($_[0]).'.git';
 219         -d $forkee ? $forkee : '';
 220 }
 221 sub valid_proj_name {
 222         $_ = $_[0];
 223         (not m#/# or -d proj_get_forkee_path($_)) # will also catch ^/
 224                 and (not m#\./#)
 225                 and (not m#/$#)
 226                 and m#^[a-zA-Z0-9+./_-]+$#;
 227 }
 228 sub valid_user_name {
 229         $_ = $_[0];
 230         /^[a-zA-Z0-9+._-]+$/;
 231 }
 232 sub valid_email {
 233         $_ = $_[0];
 234         /^[a-zA-Z0-9+._-]+@[a-zA-Z0-9-.]+$/;
 235 }
 236 sub valid_web_url {
 237         $_ = $_[0];
 238         /^http:\/\/[a-zA-Z0-9-.]+(\/[_\%a-zA-Z0-9.\/~-]*)?(#[a-zA-Z0-9._-]+)?$/;
 239 }
 240 sub valid_repo_url {
 241         $_ = $_[0];
 242         /^http:\/\/[a-zA-Z0-9-.]+(\/[_\%a-zA-Z0-9.\/~-]*)?$/ or
 243          /^git:\/\/[a-zA-Z0-9-.]+(\/[_\%a-zA-Z0-9.\/~-]*)?$/;
 244 }
 245
 246
 247 ### Project object
 248
 249 package Git::RepoCGI::Project;
 250
 251 BEGIN { use Git::RepoCGI; }
 252
 253 sub _mkdir_forkees {
 254         my $self = shift;
 255         my @pelems = split('/', $self->{name});
 256         pop @pelems; # do not create dir for the project itself
 257         my $path = $self->{base_path};
 258         foreach my $pelem (@pelems) {
 259                 $path .= "/$pelem";
 260                 (-d "$path") or mkdir $path or die "mkdir $path: $!";
 261                 chmod 0775, $path; # ok if fails (dir may already exist and be owned by someone else)
 262         }
 263 }
 264
 265 our %propmap = (
 266         url => 'base_url',
 267         email => 'owner',
 268         desc => 'description',
 269         README => 'README.html',
 270         hp => 'homepage',
 271 );
 272
 273 sub _property_path {
 274         my $self = shift;
 275         my ($name) = @_;
 276         $self->{path}.'/'.$name;
 277 }
 278
 279 sub _property_fget {
 280         my $self = shift;
 281         my ($name) = @_;
 282         $propmap{$name} or die "unknown property: $name";
 283         open P, $self->_property_path($propmap{$name}) or return undef;
 284         my @value = <P>;
 285         close P;
 286         my $value = join('', @value); chomp $value;
 287         $value;
 288 }
 289
 290 sub _property_fput {
 291         my $self = shift;
 292         my ($name, $value) = @_;
 293         $propmap{$name} or die "unknown property: $name";
 294
 295         my $P = lock_file($self->_property_path($propmap{$name}));
 296         $value ne '' and print $P "$value\n";
 297         close $P;
 298         unlock_file($self->_property_path($propmap{$name}));
 299 }
 300
 301 sub _properties_load {
 302         my $self = shift;
 303         foreach my $prop (keys %propmap) {
 304                 $self->{$prop} = $self->_property_fget($prop);
 305         }
 306 }
 307
 308 sub _properties_save {
 309         my $self = shift;
 310         foreach my $prop (keys %propmap) {
 311                 $self->_property_fput($prop, $self->{$prop});
 312         }
 313 }
 314
 315 sub _nofetch_path {
 316         my $self = shift;
 317         $self->_property_path('.nofetch');
 318 }
 319
 320 sub _nofetch {
 321         my $self = shift;
 322         my ($nofetch) = @_;
 323         my $np = $self->_nofetch_path;
 324         if ($nofetch) {
 325                 open X, '>'.$np or die "nofetch failed: $!";
 326                 close X;
 327         } else {
 328                 unlink $np or die "yesfetch failed: $!";
 329         }
 330 }
 331
 332 sub _alternates_setup {
 333         my $self = shift;
 334         return unless $self->{name} =~ m#/#;
 335         my $forkee_name = proj_get_forkee_name($self->{name});
 336         my $forkee_path = proj_get_forkee_path($self->{name});
 337         return unless -d $forkee_path;
 338         mkdir $self->{path}.'/refs'; chmod 0775, $self->{path}.'/refs';
 339         mkdir $self->{path}.'/objects'; chmod 0775, $self->{path}.'/objects';
 340         mkdir $self->{path}.'/objects/info'; chmod 0775, $self->{path}.'/objects/info';
 341
 342         # We set up both alternates and http_alternates since we cannot use
 343         # relative path in alternates - that doesn't work recursively.
 344
 345         my $filename = $self->{path}.'/objects/info/alternates';
 346         open X, '>'.$filename or die "alternates failed: $!";
 347         print X "$forkee_path/objects\n";
 348         close X;
 349         chmod 0664, $filename or warn "cannot chmod $filename: $!";
 350
 351         if ($Git::RepoCGI::httppullurl) {
 352                 $filename = $self->{path}.'/objects/info/http-alternates';
 353                 open X, '>'.$filename or die "http-alternates failed: $!";
 354                 my $upfork = $forkee_name;
 355                 do { print X "$Git::RepoCGI::httppullurl/$upfork.git/objects\n"; } while ($upfork =~ s#/?.+?$## and $upfork);
 356                 close X;
 357                 chmod 0664, $filename or warn "cannot chmod $filename: $!";
 358         }
 359
 360         symlink "$forkee_path/refs", $self->{path}.'/refs/forkee';
 361 }
 362
 363 sub _ctags_setup {
 364         my $self = shift;
 365         mkdir $self->{path}.'/ctags'; chmod 0775, $self->{path}.'/ctags';
 366 }
 367
 368 sub _group_add {
 369         my $self = shift;
 370         my ($xtra) = @_;
 371         $xtra .= join(',', @{$self->{users}});
 372         filedb_atomic_append(jailed_file('/etc/group'),
 373                 join(':', $self->{name}, $self->{crypt}, '\i', $xtra));
 374 }
 375
 376 sub _group_update {
 377         my $self = shift;
 378         my $xtra = join(',', @{$self->{users}});
 379         filedb_atomic_edit(jailed_file('/etc/group'),
 380                 sub {
 381                         $_ = $_[0];
 382                         chomp;
 383                         if ($self->{name} eq (split /:/)[0]) {
 384                                 # preserve readonly flag
 385                                 s/::([^:]*)$/:$1/ and $xtra = ":$xtra";
 386                                 return join(':', $self->{name}, $self->{crypt}, $self->{gid}, $xtra)."\n";
 387                         } else {
 388                                 return "$_\n";
 389                         }
 390                 }
 391         );
 392 }
 393
 394 sub _group_remove {
 395         my $self = shift;
 396         filedb_atomic_edit(jailed_file('/etc/group'),
 397                 sub {
 398                         $self->{name} ne (split /:/)[0] and return $_;
 399                 }
 400         );
 401 }
 402
 403 sub _hook_path {
 404         my $self = shift;
 405         my ($name) = @_;
 406         $self->{path}.'/hooks/'.$name;
 407 }
 408
 409 sub _hook_install {
 410         my $self = shift;
 411         my ($name) = @_;
 412         open SRC, "$Git::RepoCGI::basedir/$name-hook" or die "cannot open hook $name: $!";
 413         open DST, '>'.$self->_hook_path($name) or die "cannot open hook $name for writing: $!";
 414         while (<SRC>) { print DST $_; }
 415         close DST;
 416         close SRC;
 417         chmod 0775, $self->_hook_path($name) or die "cannot chmod hook $name: $!";
 418 }
 419
 420 sub _hooks_install {
 421         my $self = shift;
 422         foreach my $hook ('update') {
 423                 $self->_hook_install($hook);
 424         }
 425 }
 426
 427 # private constructor, do not use
 428 sub _new {
 429         my $class = shift;
 430         my ($name, $base_path, $path) = @_;
 431         valid_proj_name($name) or die "refusing to create project with invalid name ($name)!";
 432         $path ||= "$base_path/$name.git";
 433         my $proj = { name => $name, base_path => $base_path, path => $path };
 434
 435         bless $proj, $class;
 436 }
 437
 438 # public constructor #0
 439 # creates a virtual project not connected to disk image
 440 # you can conjure() it later to disk
 441 sub ghost {
 442         my $class = shift;
 443         my ($name, $mirror) = @_;
 444         my $self = $class->_new($name, $mirror ? "$Git::RepoCGI::mqueuedir/to-clone" : $Git::RepoCGI::reporoot,
 445                                 $mirror ? "$Git::RepoCGI::mqueuedir/to-clone/$name" : $Git::RepoCGI::reporoot."/$name.git");
 446         $self->{users} = [];
 447         $self->{mirror} = $mirror;
 448         $self;
 449 }
 450
 451 # public constructor #1
 452 sub load {
 453         my $class = shift;
 454         my ($name) = @_;
 455
 456         open F, jailed_file("/etc/group") or die "project load failed: $!";
 457         while (<F>) {
 458                 chomp;
 459                 @_ = split /:+/;
 460                 next unless (shift eq $name);
 461
 462                 my $self = $class->_new($name, $Git::RepoCGI::reporoot);
 463                 (-d $self->{path}) or die "invalid path (".$self->{path}.") for project ".$self->{name};
 464
 465                 my $ulist;
 466                 ($self->{crypt}, $self->{gid}, $ulist) = @_;
 467                 $ulist ||= '';
 468                 $self->{users} = [split /,/, $ulist];
 469                 $self->{mirror} = ! -e $self->_nofetch_path;
 470                 $self->{ccrypt} = $self->{crypt};
 471
 472                 $self->_properties_load;
 473                 return $self;
 474         }
 475         close F;
 476         undef;
 477 }
 478
 479 # $proj may not be in sane state if this returns false!
 480 sub cgi_fill {
 481         my $self = shift;
 482         my ($repo) = @_;
 483         my $cgi = $repo->cgi;
 484
 485         my $pwd = $cgi->param('pwd');
 486         if ($pwd ne '' or not $self->{crypt}) {
 487                 $self->{crypt} = scrypt($pwd);
 488         }
 489
 490         if ($cgi->param('pwd2') and $pwd ne $cgi->param('pwd2')) {
 491                 $repo->err("Our high-paid security consultants have determined that the admin passwords you have entered do not match each other.");
 492         }
 493
 494         $self->{cpwd} = $cgi->param('cpwd');
 495
 496         $self->{email} = $repo->wparam('email');
 497         valid_email($self->{email})
 498                 or $repo->err("Your email sure looks weird...?");
 499
 500         $self->{url} = $repo->wparam('url');
 501         if ($self->{url}) {
 502                 valid_repo_url($self->{url})
 503                         or $repo->err("Invalid URL. Note that only HTTP and Git protocol is supported. If the URL contains funny characters, contact me.");
 504         }
 505
 506         $self->{desc} = $repo->wparam('desc');
 507         length($self->{desc}) <= 1024
 508                 or $repo->err("<b>Short</b> description length &gt; 1kb!");
 509
 510         $self->{README} = $repo->wparam('README');
 511         length($self->{README}) <= 8192
 512                 or $repo->err("README length &gt; 8kb!");
 513
 514         $self->{hp} = $repo->wparam('hp');
 515         if ($self->{hp}) {
 516                 valid_web_url($self->{hp})
 517                         or $repo->err("Invalid homepage URL. Note that only HTTP protocol is supported. If the URL contains funny characters, contact me.");
 518         }
 519
 520         # FIXME: Permit only existing users
 521         $self->{users} = [grep { valid_user_name($_) } $cgi->param('user')];
 522
 523         not $repo->err_check;
 524 }
 525
 526 sub form_defaults {
 527         my $self = shift;
 528         (
 529                 name => $self->{name},
 530                 email => $self->{email},
 531                 url => $self->{url},
 532                 desc => html_esc($self->{desc}),
 533                 README => html_esc($self->{README}),
 534                 hp => $self->{hp},
 535                 users => $self->{users},
 536         );
 537 }
 538
 539 sub authenticate {
 540         my $self = shift;
 541         my ($repo) = @_;
 542
 543         $self->{ccrypt} or die "Can't authenticate against a project with no password";
 544         $self->{cpwd} or $repo->err("No password entered.");
 545         unless ($self->{ccrypt} eq crypt($self->{cpwd}, $self->{ccrypt})) {
 546                 $repo->err("Your admin password does not match!");
 547                 return 0;
 548         }
 549         return 1;
 550 }
 551
 552 sub premirror {
 553         my $self = shift;
 554
 555         $self->_mkdir_forkees;
 556         mkdir $self->{path} or die "mkdir failed: $!";
 557         chmod 0775, $self->{path} or die "chmod failed: $!";
 558         $self->_properties_save;
 559         $self->_alternates_setup;
 560         $self->_ctags_setup;
 561         $self->_group_add(':');
 562 }
 563
 564 sub conjure {
 565         my $self = shift;
 566
 567         $self->_mkdir_forkees;
 568
 569         mkdir($self->{path}) or die "mkdir $self->{path} failed: $!";
 570         my $gid = scalar(getgrnam($Git::RepoCGI::group));
 571         chown(-1, $gid, $self->{path}) or die "chgrp $gid $self->{path} failed: $!";
 572         chmod(2775, $self->{path}) or die "chmod 2775 $self->{path} failed: $!";
 573         system($Git::RepoCGI::git_bin, '--git-dir='.$self->{path}, 'init', '--bare', '--shared=group')
 574                 or die "git init $self->{path} failed: $!";
 575         system($Git::RepoCGI::git_bin, '--git-dir='.$self->{path}, 'config', 'receive.denyNonFastforwards', 'false')
 576                 or die "disabling receive.denyNonFastforwards failed: $!";
 577
 578         $self->_nofetch(1);
 579         $self->_properties_save;
 580         $self->_alternates_setup;
 581         $self->_ctags_setup;
 582         $self->_group_add;
 583         $self->_hooks_install;
 584 }
 585
 586 sub update {
 587         my $self = shift;
 588
 589         $self->_properties_save;
 590         $self->_group_update;
 591 }
 592
 593 sub update_password {
 594         my $self = shift;
 595         my ($pwd) = @_;
 596
 597         $self->{crypt} = scrypt($pwd);
 598         $self->_group_update;
 599 }
 600
 601 # You can explicitly do this just on a ghost() repository too.
 602 sub delete {
 603         my $self = shift;
 604
 605         if (-d $self->{path}) {
 606                 system('rm', '-r', $self->{path}) == 0
 607                         or die "rm -r failed: $?";
 608         }
 609         $self->_group_remove;
 610 }
 611
 612 sub has_forks {
 613         my $self = shift;
 614
 615         return glob($Git::RepoCGI::reporoot.'/'.$self->{name}.'/*');
 616 }
 617
 618 # static method
 619 sub does_exist {
 620         my ($name) = @_;
 621         valid_proj_name($name) or die "tried to query for project with invalid name $name!";
 622         (available($name)
 623                 or -d $Git::RepoCGI::mqueuedir."/cloning/$name"
 624                 or -d $Git::RepoCGI::mqueuedir."/to-clone/$name");
 625 }
 626 sub available {
 627         my ($name) = @_;
 628         valid_proj_name($name) or die "tried to query for project with invalid name $name!";
 629         (-d $Git::RepoCGI::reporoot."/$name.git");
 630 }
 631
 632
 633 ### User object
 634
 635 package Git::RepoCGI::User;
 636
 637 BEGIN { use Git::RepoCGI; }
 638
 639 sub _passwd_add {
 640         my $self = shift;
 641         filedb_atomic_append(jailed_file('/etc/passwd'),
 642                 join(':', $self->{name}, 'x', '\i', 65534, $self->{email}, '/', '/bin/git-shell'));
 643 }
 644
 645 sub _sshkey_path {
 646         my $self = shift;
 647         '/etc/sshkeys/'.$self->{name};
 648 }
 649
 650 sub _sshkey_load {
 651         my $self = shift;
 652         open F, "<".jailed_file($self->_sshkey_path) or die "sshkey load failed: $!";
 653         my @keys;
 654         my $auth;
 655         while (<F>) {
 656                 chomp;
 657                 if (/^ssh-(?:dss|rsa) /) {
 658                         push @keys, $_;
 659                 } elsif (/^# REPOAUTH ([0-9a-f]+) (\d+)/) {
 660                         my $expire = $2;
 661                         $auth = $1 unless (time >= $expire);
 662                 }
 663         }
 664         close F;
 665         my $keys = join('', @keys); chomp $keys;
 666         ($keys, $auth);
 667 }
 668
 669 sub _sshkey_save {
 670         my $self = shift;
 671         open F, ">".jailed_file($self->_sshkey_path) or die "sshkey failed: $!";
 672         if (defined($self->{auth}) && $self->{auth}) {
 673                 my $expire = time + 24 * 3600;
 674                 print F "# REPOAUTH $self->{auth} $expire\n";
 675         }
 676         print F $self->{keys}."\n";
 677         close F;
 678         chmod 0664, jailed_file($self->_sshkey_path);
 679 }
 680
 681 # private constructor, do not use
 682 sub _new {
 683         my $class = shift;
 684         my ($name) = @_;
 685         valid_user_name($name) or die "refusing to create user with invalid name ($name)!";
 686         my $proj = { name => $name };
 687
 688         bless $proj, $class;
 689 }
 690
 691 # public constructor #0
 692 # creates a virtual user not connected to disk record
 693 # you can conjure() it later to disk
 694 sub ghost {
 695         my $class = shift;
 696         my ($name) = @_;
 697         my $self = $class->_new($name);
 698         $self;
 699 }
 700
 701 # public constructor #1
 702 sub load {
 703         my $class = shift;
 704         my ($name) = @_;
 705
 706         open F, jailed_file("/etc/passwd") or die "user load failed: $!";
 707         while (<F>) {
 708                 chomp;
 709                 @_ = split /:+/;
 710                 next unless (shift eq $name);
 711
 712                 my $self = $class->_new($name);
 713
 714                 (undef, $self->{uid}, undef, $self->{email}) = @_;
 715                 ($self->{keys}, $self->{auth}) = $self->_sshkey_load;
 716
 717                 return $self;
 718         }
 719         close F;
 720         undef;
 721 }
 722
 723 # $user may not be in sane state if this returns false!
 724 sub cgi_fill {
 725         my $self = shift;
 726         my ($repo) = @_;
 727         my $cgi = $repo->cgi;
 728
 729         $self->{name} = $repo->wparam('name');
 730         valid_user_name($self->{name})
 731                 or $repo->err("Name contains invalid characters.");
 732
 733         $self->{email} = $repo->wparam('email');
 734         valid_email($self->{email})
 735                 or $repo->err("Your email sure looks weird...?");
 736
 737         $self->keys_fill($repo);
 738 }
 739
 740 sub keys_fill {
 741         my $self = shift;
 742         my ($repo) = @_;
 743         my $cgi = $repo->cgi;
 744
 745         $self->{keys} = $cgi->param('keys');
 746         length($self->{keys}) <= 4096
 747                 or $repo->err("The list of keys is more than 4kb. Do you really need that much?");
 748         foreach (split /\r?\n/, $self->{keys}) {
 749                 /^ssh-(?:dss|rsa) .* \S+@\S+$/ or $repo->err("Your ssh key (\"$_\") appears to have invalid format (do not start by ssh-dss|rsa or do not end with @-identifier) - maybe your browser has split a single key to multiple lines?");
 750         }
 751
 752         not $repo->err_check;
 753 }
 754
 755 sub keys_save {
 756         my $self = shift;
 757
 758         $self->_sshkey_save;
 759 }
 760
 761 sub gen_auth {
 762         my $self = shift;
 763
 764         $self->{auth} = Digest::SHA1::sha1_hex(time . $$ . rand() . $self->{keys});
 765         $self->_sshkey_save;
 766         $self->{auth};
 767 }
 768
 769 sub del_auth {
 770         my $self = shift;
 771
 772         delete $self->{auth};
 773 }
 774
 775 sub conjure {
 776         my $self = shift;
 777
 778         $self->_passwd_add;
 779         $self->_sshkey_save;
 780 }
 781
 782 # static method
 783 sub does_exist {
 784         my ($name) = @_;
 785         valid_user_name($name) or die "tried to query for user with invalid name $name!";
 786         (-e jailed_file("/etc/sshkeys/$name"));
 787 }
 788 sub available {
 789         does_exist(@_);
 790 }
 791
 792
 793 1;