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