IkiWiki/Rcs/monotone.pm

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