IkiWiki/Rcs/monotone.pm

   1 #!/usr/bin/perl
   2 use warnings;
   3 use strict;
   4 use IkiWiki;
   5 use Monotone;
   6 use Date::Parse qw(str2time);
   7 use Date::Format qw(time2str);
   8
   9 package IkiWiki;
  10
  11 my $sha1_pattern = qr/[0-9a-fA-F]{40}/; # pattern to validate sha1sums
  12
  13 sub check_config() { #{{{
  14         if (!defined($config{mtnrootdir})) {
  15                 $config{mtnrootdir} = $config{srcdir};
  16         }
  17         if (! -d "$config{mtnrootdir}/_MTN") {
  18                 error("Ikiwiki srcdir does not seem to be a Monotone workspace (or set the mtnrootdir)!");
  19         }
  20
  21         chdir $config{srcdir}
  22             or error("Cannot chdir to $config{srcdir}: $!");
  23
  24         my $child = open(MTN, "-|");
  25         if (! $child) {
  26                 open STDERR, ">/dev/null";
  27                 exec("mtn", "version") || error("mtn version failed to run");
  28         }
  29
  30         my $version=undef;
  31         while (<MTN>) {
  32                 if (/^monotone (\d+\.\d+) /) {
  33                         $version=$1;
  34                 }
  35         }
  36
  37         close MTN || debug("mtn version exited $?");
  38
  39         if (!defined($version)) {
  40                 error("Cannot determine monotone version");
  41         }
  42         if ($version < 0.38) {
  43                 error("Monotone version too old, is $version but required 0.38");
  44         }
  45 } #}}}
  46
  47 sub get_rev () { #{{{
  48         my $sha1 = `mtn --root=$config{mtnrootdir} automate get_base_revision_id`;
  49
  50         ($sha1) = $sha1 =~ m/($sha1_pattern)/; # sha1 is untainted now
  51         if (! $sha1) {
  52                 debug("Unable to get base revision for '$config{srcdir}'.")
  53         }
  54
  55         return $sha1;
  56 } #}}}
  57
  58 sub get_rev_auto ($) { #{{{
  59         my $automator=shift;
  60
  61         my @results = $automator->call("get_base_revision_id");
  62
  63         my $sha1 = $results[0];
  64         ($sha1) = $sha1 =~ m/($sha1_pattern)/; # sha1 is untainted now
  65         if (! $sha1) {
  66                 debug("Unable to get base revision for '$config{srcdir}'.")
  67         }
  68
  69         return $sha1;
  70 } #}}}
  71
  72 sub mtn_merge ($$$$) { #{{{
  73         my $leftRev=shift;
  74         my $rightRev=shift;
  75         my $branch=shift;
  76         my $author=shift;
  77
  78         my $mergeRev;
  79
  80         my $child = open(MTNMERGE, "-|");
  81         if (! $child) {
  82                 open STDERR, ">&STDOUT";
  83                 exec("mtn", "--root=$config{mtnrootdir}",
  84                      "explicit_merge", $leftRev, $rightRev,
  85                      $branch, "--author", $author, "--key",
  86                      $config{mtnkey}) || error("mtn merge failed to run");
  87         }
  88
  89         while (<MTNMERGE>) {
  90                 if (/^mtn.\s.merged.\s($sha1_pattern)$/) {
  91                         $mergeRev=$1;
  92                 }
  93         }
  94
  95         close MTNMERGE || return undef;
  96
  97         debug("merged $leftRev, $rightRev to make $mergeRev");
  98
  99         return $mergeRev;
 100 } #}}}
 101
 102 sub commit_file_to_new_rev($$$$$$$$) { #{{{
 103         my $automator=shift;
 104         my $wsfilename=shift;
 105         my $oldFileID=shift;
 106         my $newFileContents=shift;
 107         my $oldrev=shift;
 108         my $branch=shift;
 109         my $author=shift;
 110         my $message=shift;
 111
 112         #store the file
 113         my ($out, $err) = $automator->call("put_file", $oldFileID, $newFileContents);
 114         my ($newFileID) = ($out =~ m/^($sha1_pattern)$/);
 115         error("Failed to store file data for $wsfilename in repository")
 116                 if (! defined $newFileID || length $newFileID != 40);
 117
 118         # get the mtn filename rather than the workspace filename
 119         ($out, $err) = $automator->call("get_corresponding_path", $oldrev, $wsfilename, $oldrev);
 120         my ($filename) = ($out =~ m/^file "(.*)"$/);
 121         error("Couldn't find monotone repository path for file $wsfilename") if (! $filename);
 122         debug("Converted ws filename of $wsfilename to repos filename of $filename");
 123
 124         # then stick in a new revision for this file
 125         my $manifest = "format_version \"1\"\n\n".
 126                        "new_manifest [0000000000000000000000000000000000000000]\n\n".
 127                        "old_revision [$oldrev]\n\n".
 128                        "patch \"$filename\"\n".
 129                        " from [$oldFileID]\n".
 130                        "   to [$newFileID]\n";
 131         ($out, $err) = $automator->call("put_revision", $manifest);
 132         my ($newRevID) = ($out =~ m/^($sha1_pattern)$/);
 133         error("Unable to make new monotone repository revision")
 134                 if (! defined $newRevID || length $newRevID != 40);
 135         debug("put revision: $newRevID");
 136
 137         # now we need to add certs for this revision...
 138         # author, branch, changelog, date
 139         $automator->call("cert", $newRevID, "author", $author);
 140         $automator->call("cert", $newRevID, "branch", $branch);
 141         $automator->call("cert", $newRevID, "changelog", $message);
 142         $automator->call("cert", $newRevID, "date",
 143                 time2str("%Y-%m-%dT%T", time, "UTC"));
 144
 145         debug("Added certs for rev: $newRevID");
 146         return $newRevID;
 147 } #}}}
 148
 149 sub read_certs ($$) { #{{{
 150         my $automator=shift;
 151         my $rev=shift;
 152         my @results = $automator->call("certs", $rev);
 153         my @ret;
 154
 155         my $line = $results[0];
 156         while ($line =~ m/\s+key\s"(.*?)"\nsignature\s"(ok|bad|unknown)"\n\s+name\s"(.*?)"\n\s+value\s"(.*?)"\n\s+trust\s"(trusted|untrusted)"\n/sg) {
 157                 push @ret, {
 158                         key => $1,
 159                         signature => $2,
 160                         name => $3,
 161                         value => $4,
 162                         trust => $5,
 163                 };
 164         }
 165
 166         return @ret;
 167 } #}}}
 168
 169 sub get_changed_files ($$) { #{{{
 170         my $automator=shift;
 171         my $rev=shift;
 172
 173         my @results = $automator->call("get_revision", $rev);
 174         my $changes=$results[0];
 175
 176         my @ret;
 177         my %seen = ();
 178
 179         while ($changes =~ m/\s*(add_file|patch|delete|rename)\s"(.*?)(?<!\\)"\n/sg) {
 180                 my $file = $2;
 181                 # don't add the same file multiple times
 182                 if (! $seen{$file}) {
 183                         push @ret, $file;
 184                         $seen{$file} = 1;
 185                 }
 186         }
 187
 188         return @ret;
 189 } #}}}
 190
 191 sub rcs_update () { #{{{
 192         check_config();
 193
 194         if (defined($config{mtnsync}) && $config{mtnsync}) {
 195                 if (system("mtn", "--root=$config{mtnrootdir}", "sync",
 196                            "--quiet", "--ticker=none",
 197                            "--key", $config{mtnkey}) != 0) {
 198                         debug("monotone sync failed before update");
 199                 }
 200         }
 201
 202         if (system("mtn", "--root=$config{mtnrootdir}", "update", "--quiet") != 0) {
 203                 debug("monotone update failed");
 204         }
 205 } #}}}
 206
 207 sub rcs_prepedit ($) { #{{{
 208         my $file=shift;
 209
 210         check_config();
 211
 212         # For monotone, return the revision of the file when
 213         # editing begins.
 214         return get_rev();
 215 } #}}}
 216
 217 sub rcs_commit ($$$;$$) { #{{{
 218         # Tries to commit the page; returns undef on _success_ and
 219         # a version of the page with the rcs's conflict markers on failure.
 220         # The file is relative to the srcdir.
 221         my $file=shift;
 222         my $message=shift;
 223         my $rcstoken=shift;
 224         my $user=shift;
 225         my $ipaddr=shift;
 226         my $author;
 227
 228         if (defined $user) {
 229                 $author="Web user: " . $user;
 230         }
 231         elsif (defined $ipaddr) {
 232                 $author="Web IP: " . $ipaddr;
 233         }
 234         else {
 235                 $author="Web: Anonymous";
 236         }
 237
 238         check_config();
 239
 240         my ($oldrev)= $rcstoken=~ m/^($sha1_pattern)$/; # untaint
 241         my $rev = get_rev();
 242         if (defined $rev && defined $oldrev && $rev ne $oldrev) {
 243                 my $automator = Monotone->new();
 244                 $automator->open_args("--root", $config{mtnrootdir}, "--key", $config{mtnkey});
 245
 246                 # Something has been committed, has this file changed?
 247                 my ($out, $err);
 248                 $automator->setOpts("r", $oldrev, "r", $rev);
 249                 ($out, $err) = $automator->call("content_diff", $file);
 250                 debug("Problem committing $file") if ($err ne "");
 251                 my $diff = $out;
 252
 253                 if ($diff) {
 254                         # Commit a revision with just this file changed off
 255                         # the old revision.
 256                         #
 257                         # first get the contents
 258                         debug("File changed: forming branch");
 259                         my $newfile=readfile("$config{srcdir}/$file");
 260
 261                         # then get the old content ID from the diff
 262                         if ($diff !~ m/^---\s$file\s+($sha1_pattern)$/m) {
 263                                 error("Unable to find previous file ID for $file");
 264                         }
 265                         my $oldFileID = $1;
 266
 267                         # get the branch we're working in
 268                         ($out, $err) = $automator->call("get_option", "branch");
 269                         chomp $out;
 270                         error("Illegal branch name in monotone workspace") if ($out !~ m/^([-\@\w\.]+)$/);
 271                         my $branch = $1;
 272
 273                         # then put the new content into the DB (and record the new content ID)
 274                         my $newRevID = commit_file_to_new_rev($automator, $file, $oldFileID, $newfile, $oldrev, $branch, $author, $message);
 275
 276                         $automator->close();
 277
 278                         # if we made it to here then the file has been committed... revert the local copy
 279                         if (system("mtn", "--root=$config{mtnrootdir}", "revert", $file) != 0) {
 280                                 debug("Unable to revert $file after merge on conflicted commit!");
 281                         }
 282                         debug("Divergence created! Attempting auto-merge.");
 283
 284                         # see if it will merge cleanly
 285                         $ENV{MTN_MERGE}="fail";
 286                         my $mergeResult = mtn_merge($newRevID, $rev, $branch, $author);
 287                         $ENV{MTN_MERGE}="";
 288
 289                         # push any changes so far
 290                         if (defined($config{mtnsync}) && $config{mtnsync}) {
 291                                 if (system("mtn", "--root=$config{mtnrootdir}", "push", "--quiet", "--ticker=none", "--key", $config{mtnkey}) != 0) {
 292                                         debug("monotone push failed");
 293                                 }
 294                         }
 295
 296                         if (defined($mergeResult)) {
 297                                 # everything is merged - bring outselves up to date
 298                                 if (system("mtn", "--root=$config{mtnrootdir}",
 299                                            "update", "-r", $mergeResult) != 0) {
 300                                         debug("Unable to update to rev $mergeResult after merge on conflicted commit!");
 301                                 }
 302                         }
 303                         else {
 304                                 debug("Auto-merge failed.  Using diff-merge to add conflict markers.");
 305
 306                                 $ENV{MTN_MERGE}="diffutils";
 307                                 $ENV{MTN_MERGE_DIFFUTILS}="partial=true";
 308                                 $mergeResult = mtn_merge($newRevID, $rev, $branch, $author);
 309                                 $ENV{MTN_MERGE}="";
 310                                 $ENV{MTN_MERGE_DIFFUTILS}="";
 311
 312                                 if (!defined($mergeResult)) {
 313                                         debug("Unable to insert conflict markers!");
 314                                         error("Your commit succeeded. Unfortunately, someone else committed something to the same ".
 315                                                 "part of the wiki at the same time. Both versions are stored in the monotone repository, ".
 316                                                 "but at present the different versions cannot be reconciled through the web interface. ".
 317                                                 "Please use the non-web interface to resolve the conflicts.");
 318                                 }
 319
 320                                 if (system("mtn", "--root=$config{mtnrootdir}",
 321                                            "update", "-r", $mergeResult) != 0) {
 322                                         debug("Unable to update to rev $mergeResult after conflict-enhanced merge on conflicted commit!");
 323                                 }
 324
 325                                 # return "conflict enhanced" file to the user
 326                                 # for cleanup note, this relies on the fact
 327                                 # that ikiwiki seems to call rcs_prepedit()
 328                                 # again after we return
 329                                 return readfile("$config{srcdir}/$file");
 330                         }
 331                         return undef;
 332                 }
 333                 $automator->close();
 334         }
 335
 336         # If we reached here then the file we're looking at hasn't changed
 337         # since $oldrev. Commit it.
 338
 339         if (system("mtn", "--root=$config{mtnrootdir}", "commit", "--quiet",
 340                    "--author", $author, "--key", $config{mtnkey}, "-m",
 341                    possibly_foolish_untaint($message), $file) != 0) {
 342                 debug("Traditional commit failed! Returning data as conflict.");
 343                 my $conflict=readfile("$config{srcdir}/$file");
 344                 if (system("mtn", "--root=$config{mtnrootdir}", "revert",
 345                            "--quiet", $file) != 0) {
 346                         debug("monotone revert failed");
 347                 }
 348                 return $conflict;
 349         }
 350         if (defined($config{mtnsync}) && $config{mtnsync}) {
 351                 if (system("mtn", "--root=$config{mtnrootdir}", "push",
 352                            "--quiet", "--ticker=none", "--key",
 353                            $config{mtnkey}) != 0) {
 354                         debug("monotone push failed");
 355                 }
 356         }
 357
 358         return undef # success
 359 } #}}}
 360
 361 sub rcs_add ($) { #{{{
 362         my $file=shift;
 363
 364         check_config();
 365
 366         if (system("mtn", "--root=$config{mtnrootdir}", "add", "--quiet",
 367                    $file) != 0) {
 368                 error("Monotone add failed");
 369         }
 370 } #}}}
 371
 372 sub rcs_recentchanges ($) { #{{{
 373         my $num=shift;
 374         my @ret;
 375
 376         check_config();
 377
 378         # use log --brief to get a list of revs, as this
 379         # gives the results in a nice order
 380         # (otherwise we'd have to do our own date sorting)
 381
 382         my @revs;
 383
 384         my $child = open(MTNLOG, "-|");
 385         if (! $child) {
 386                 exec("mtn", "log", "--root=$config{mtnrootdir}", "--no-graph",
 387                      "--brief") || error("mtn log failed to run");
 388         }
 389
 390         while (($num >= 0) and (my $line = <MTNLOG>)) {
 391                 if ($line =~ m/^($sha1_pattern)/) {
 392                         push @revs, $1;
 393                         $num -= 1;
 394                 }
 395         }
 396         close MTNLOG || debug("mtn log exited $?");
 397
 398         my $automator = Monotone->new();
 399         $automator->open(undef, $config{mtnrootdir});
 400
 401         while (@revs != 0) {
 402                 my $rev = shift @revs;
 403                 # first go through and figure out the messages, etc
 404
 405                 my $certs = [read_certs($automator, $rev)];
 406
 407                 my $user;
 408                 my $when;
 409                 my $committype;
 410                 my (@pages, @message);
 411
 412                 foreach my $cert (@$certs) {
 413                         if ($cert->{signature} eq "ok" &&
 414                             $cert->{trust} eq "trusted") {
 415                                 if ($cert->{name} eq "author") {
 416                                         $user = $cert->{value};
 417                                         # detect the source of the commit
 418                                         # from the changelog
 419                                         if ($cert->{key} eq $config{mtnkey}) {
 420                                                 $committype = "web";
 421                                         } else {
 422                                                 $committype = "monotone";
 423                                         }
 424                                 } elsif ($cert->{name} eq "date") {
 425                                         $when = str2time($cert->{value}, 'UTC');
 426                                 } elsif ($cert->{name} eq "changelog") {
 427                                         my $messageText = $cert->{value};
 428                                         # split the changelog into multiple
 429                                         # lines
 430                                         foreach my $msgline (split(/\n/, $messageText)) {
 431                                                 push @message, { line => $msgline };
 432                                         }
 433                                 }
 434                         }
 435                 }
 436
 437                 my @changed_files = get_changed_files($automator, $rev);
 438                 my $file;
 439
 440                 my ($out, $err) = $automator->call("parents", $rev);
 441                 my @parents = ($out =~ m/^($sha1_pattern)$/);
 442                 my $parent = $parents[0];
 443
 444                 foreach $file (@changed_files) {
 445                         next unless length $file;
 446
 447                         if (defined $config{diffurl} and (@parents == 1)) {
 448                                 my $diffurl=$config{diffurl};
 449                                 $diffurl=~s/\[\[r1\]\]/$parent/g;
 450                                 $diffurl=~s/\[\[r2\]\]/$rev/g;
 451                                 $diffurl=~s/\[\[file\]\]/$file/g;
 452                                 push @pages, {
 453                                         page => pagename($file),
 454                                         diffurl => $diffurl,
 455                                 };
 456                         }
 457                         else {
 458                                 push @pages, {
 459                                         page => pagename($file),
 460                                 }
 461                         }
 462                 }
 463
 464                 push @ret, {
 465                         rev => $rev,
 466                         user => $user,
 467                         committype => $committype,
 468                         when => $when,
 469                         message => [@message],
 470                         pages => [@pages],
 471                 } if @pages;
 472         }
 473
 474         $automator->close();
 475
 476         return @ret;
 477 } #}}}
 478
 479 sub rcs_diff ($) { #{{{
 480         # TODO
 481 } #}}}
 482
 483 sub rcs_getctime ($) { #{{{
 484         my $file=shift;
 485
 486         check_config();
 487
 488         my $child = open(MTNLOG, "-|");
 489         if (! $child) {
 490                 exec("mtn", "log", "--root=$config{mtnrootdir}", "--no-graph",
 491                      "--brief", $file) || error("mtn log $file failed to run");
 492         }
 493
 494         my $firstRev;
 495         while (<MTNLOG>) {
 496                 if (/^($sha1_pattern)/) {
 497                         $firstRev=$1;
 498                 }
 499         }
 500         close MTNLOG || debug("mtn log $file exited $?");
 501
 502         if (! defined $firstRev) {
 503                 debug "failed to parse mtn log for $file";
 504                 return 0;
 505         }
 506
 507         my $automator = Monotone->new();
 508         $automator->open(undef, $config{mtnrootdir});
 509
 510         my $certs = [read_certs($automator, $firstRev)];
 511
 512         $automator->close();
 513
 514         my $date;
 515
 516         foreach my $cert (@$certs) {
 517                 if ($cert->{signature} eq "ok" && $cert->{trust} eq "trusted") {
 518                         if ($cert->{name} eq "date") {
 519                                 $date = $cert->{value};
 520                         }
 521                 }
 522         }
 523
 524         if (! defined $date) {
 525                 debug "failed to find date cert for revision $firstRev when looking for creation time of $file";
 526                 return 0;
 527         }
 528
 529         $date=str2time($date, 'UTC');
 530         debug("found ctime ".localtime($date)." for $file");
 531         return $date;
 532 } #}}}
 533
 534 1