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         if (!defined($config{mtnmergerc})) {
  22                 $config{mtnmergerc} = "$config{mtnrootdir}/_MTN/mergerc";
  23         }
  24
  25         chdir $config{srcdir}
  26             or error("Cannot chdir to $config{srcdir}: $!");
  27 }
  28
  29 sub get_rev () {
  30         my $sha1 = `mtn --root=$config{mtnrootdir} automate get_base_revision_id`;
  31
  32         ($sha1) = $sha1 =~ m/($sha1_pattern)/; # sha1 is untainted now
  33         if (! $sha1) {
  34                 warn("Unable to get base revision for '$config{srcdir}'.")
  35         }
  36
  37         return $sha1;
  38 }
  39
  40 sub get_rev_auto ($) {
  41         my $automator=shift;
  42
  43         my @results = $automator->call("get_base_revision_id");
  44
  45         my $sha1 = $results[0];
  46         ($sha1) = $sha1 =~ m/($sha1_pattern)/; # sha1 is untainted now
  47         if (! $sha1) {
  48                 warn("Unable to get base revision for '$config{srcdir}'.")
  49         }
  50
  51         return $sha1;
  52 }
  53
  54 sub mtn_merge ($$$$$) {
  55     my $leftRev=shift;
  56     my $rightRev=shift;
  57     my $branch=shift;
  58     my $author=shift;
  59     my $message=shift;  # ignored for the moment because mtn doesn't support it
  60
  61     my $mergeRev;
  62
  63         my $mergerc = $config{mtnmergerc};
  64
  65         my $child = open(MTNMERGE, "-|");
  66         if (! $child) {
  67                 open STDERR, ">&STDOUT";
  68                 exec("mtn", "--root=$config{mtnrootdir}", "--rcfile", $mergerc, "explicit_merge", $leftRev, $rightRev, $branch, "--author", $author, "--key", $config{mtnkey}) || error("mtn merge failed to run");
  69         }
  70
  71         while (<MTNMERGE>) {
  72                 if (/^mtn.\s.merged.\s($sha1_pattern)$/) {
  73                         $mergeRev=$1;
  74                 }
  75         }
  76
  77         close MTNMERGE || return undef;
  78
  79         warn("merged $leftRev, $rightRev to make $mergeRev");
  80
  81         return $mergeRev;
  82 }
  83
  84 sub commit_file_to_new_rev($$$$$$$$) {
  85         my $automator=shift;
  86         my $wsfilename=shift;
  87         my $oldFileID=shift;
  88         my $newFileContents=shift;
  89         my $oldrev=shift;
  90         my $branch=shift;
  91         my $author=shift;
  92         my $message=shift;
  93
  94         #store the file
  95         my ($out, $err) = $automator->call("put_file", $oldFileID, $newFileContents);
  96         my ($newFileID) = ($out =~ m/^($sha1_pattern)$/);
  97         error("Failed to store file data for $wsfilename in repository") if (!defined($newFileID) || 40 != length $newFileID);
  98
  99         # get the mtn filename rather than the workspace filename
 100         ($out, $err) = $automator->call("get_corresponding_path", $oldrev, $wsfilename, $oldrev);
 101         my ($filename) = ($out =~ m/^file "(.*)"$/);
 102         error("Couldn't find monotone repository path for file $wsfilename") if (! $filename);
 103         warn("Converted ws filename of $wsfilename to repos filename of $filename");
 104
 105         # then stick in a new revision for this file
 106         my $manifest =  "format_version \"1\"\n\n".
 107                                         "new_manifest [0000000000000000000000000000000000000000]\n\n".
 108                                         "old_revision [$oldrev]\n\n".
 109                                         "patch \"$filename\"\n".
 110                                         " from [$oldFileID]\n".
 111                                         "   to [$newFileID]\n";
 112         ($out, $err) = $automator->call("put_revision", $manifest);
 113         my ($newRevID) = ($out =~ m/^($sha1_pattern)$/);
 114         error("Unable to make new monotone repository revision") if (!defined($newRevID) || 40 != length $newRevID);
 115         warn("put revision: $newRevID");
 116
 117         # now we need to add certs for this revision...
 118         # author, branch, changelog, date
 119         $automator->call("cert", $newRevID, "author", $author);
 120         $automator->call("cert", $newRevID, "branch", $branch);
 121         $automator->call("cert", $newRevID, "changelog", $message);
 122         $automator->call("cert", $newRevID, "date", time2str("%Y-%m-%dT%T", time, "UTC"));
 123
 124         warn("Added certs for rev: $newRevID");
 125         return $newRevID;
 126 }
 127
 128 sub check_mergerc() {
 129         my $mergerc = $config{mtnmergerc};
 130         if (! -r $mergerc ) {
 131                 warn("$mergerc doesn't exist.  Creating file with default mergers.");
 132                 open(my $out, ">$mergerc") or error("can't open $mergerc: $!");
 133                 print $out <DATA>;
 134                 close $out;
 135         }
 136 }
 137
 138 sub read_certs ($$) {
 139         my $automator=shift;
 140         my $rev=shift;
 141         my @results = $automator->call("certs", $rev);
 142         my @ret;
 143
 144         my $line = $results[0];
 145         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) {
 146                 push @ret, {
 147                         key => $1,
 148                         signature => $2,
 149                         name => $3,
 150                         value => $4,
 151                         trust => $5,
 152                 };
 153         }
 154
 155         return @ret;
 156 }
 157
 158 sub get_changed_files ($$) {
 159         my $automator=shift;
 160         my $rev=shift;
 161
 162         my @results = $automator->call("get_revision", $rev);
 163         my $changes=$results[0];
 164
 165         my @ret;
 166         my %seen = ();
 167
 168         while ($changes =~ m/\s*(add_file|patch|delete|rename)\s"(.*?)(?<!\\)"\n/sg) {
 169                 my $file = $2;
 170                 if (! $seen{$file}) {   # don't add the same file multiple times
 171                         push @ret, $file;
 172                         $seen{$file} = 1;
 173                 }
 174         }
 175
 176         return @ret;
 177 }
 178
 179 # The following functions are the ones actually called by Ikiwiki
 180
 181 sub rcs_update () {
 182         # Update working directory to current version.
 183
 184         check_config();
 185
 186         if (defined($config{mtnsync}) && $config{mtnsync}) {
 187                 if (system("mtn", "--root=$config{mtnrootdir}", "sync", "--quiet", "--ticker=none", "--key", $config{mtnkey}) != 0) {
 188                         warn("monotone sync failed before update\n");
 189                 }
 190         }
 191
 192         if (system("mtn", "--root=$config{mtnrootdir}", "update", "--quiet") != 0) {
 193                 warn("monotone update failed\n");
 194         }
 195 }
 196
 197 sub rcs_prepedit ($) {
 198         # Prepares to edit a file under revision control. Returns a token
 199         # that must be passed into rcs_commit when the file is ready
 200         # for committing.
 201         # The file is relative to the srcdir.
 202         my $file=shift;
 203
 204         check_config();
 205
 206         # For monotone, return the revision of the file when
 207         # editing begins.
 208         return get_rev();
 209 }
 210
 211 sub rcs_commit ($$$;$$) {
 212         # Tries to commit the page; returns undef on _success_ and
 213         # a version of the page with the rcs's conflict markers on failure.
 214         # The file is relative to the srcdir.
 215         my $file=shift;
 216         my $message=shift;
 217         my $rcstoken=shift;
 218         my $user=shift;
 219         my $ipaddr=shift;
 220         my $author;
 221
 222         if (defined $user) {
 223                 $author="Web user: " . $user;
 224         }
 225         elsif (defined $ipaddr) {
 226                 $author="Web IP: " . $ipaddr;
 227         }
 228         else {
 229                 $author="Web: Anonymous";
 230         }
 231
 232         check_config();
 233
 234         my ($oldrev)= $rcstoken=~ m/^($sha1_pattern)$/; # untaint
 235         my $rev = get_rev();
 236         if (defined $rev && defined $oldrev && $rev ne $oldrev) {
 237                 my $automator = Monotone->new();
 238                 $automator->open_args("--root", $config{mtnrootdir}, "--key", $config{mtnkey});
 239
 240                 # Something has been committed, has this file changed?
 241                 my ($out, $err);
 242                 #$automator->setOpts("-r", $oldrev, "-r", $rev);
 243                 #my ($out, $err) = $automator->call("content_diff", $file);
 244                 #debug("Problem committing $file") if ($err ne "");
 245                 # FIXME: use of $file in these backticks is not wise from a
 246                 # security POV. Probably safe, but should be avoided
 247                 # anyway.
 248                 my $diff = `mtn --root=$config{mtnrootdir} au content_diff -r $oldrev -r $rev $file`; # was just $out;
 249
 250                 if ($diff) {
 251                         # this file has changed
 252                         # commit a revision with just this file changed off
 253                         # the old revision
 254                         # first get the contents
 255                         warn("File changed: forming branch\n");
 256                         my $newfile=readfile("$config{srcdir}/$file");
 257
 258                         # then get the old content ID from the diff
 259                         if ($diff !~ m/^---\s$file\s+($sha1_pattern)$/m) {
 260                                 error("Unable to find previous file ID for $file");
 261                         }
 262                         my $oldFileID = $1;
 263
 264                         # get the branch we're working in
 265                         ($out, $err) = $automator->call("get_option", "branch");
 266                         chomp $out;
 267                         error("Illegal branch name in monotone workspace") if ($out !~ m/^([-\@\w\.]+)$/);
 268                         my $branch = $1;
 269
 270                         # then put the new content into the DB (and record the new content ID)
 271                         my $newRevID = commit_file_to_new_rev($automator, $file, $oldFileID, $newfile, $oldrev, $branch, $author, $message);
 272
 273                         $automator->close();
 274
 275                         # if we made it to here then the file has been committed... revert the local copy
 276                         if (system("mtn", "--root=$config{mtnrootdir}", "revert", $file) != 0) {
 277                                 warn("Unable to revert $file after merge on conflicted commit!");
 278                         }
 279                         warn("Divergence created!  Attempting auto-merge.");
 280
 281                         check_mergerc();
 282
 283                         # see if it will merge cleanly
 284                         $ENV{MTN_MERGE}="fail";
 285                         my $mergeResult = mtn_merge($newRevID, $rev, $branch, $author, "Auto-merging parallel web edits.");
 286                         $ENV{MTN_MERGE}="";
 287
 288                         # push any changes so far
 289                         if (defined($config{mtnsync}) && $config{mtnsync}) {
 290                                 if (system("mtn", "--root=$config{mtnrootdir}", "push", "--quiet", "--ticker=none", "--key", $config{mtnkey}) != 0) {
 291                                         warn("monotone push failed\n");
 292                                 }
 293                         }
 294
 295                         if (defined($mergeResult)) {
 296                                 # everything is merged - bring outselves up to date
 297                                 if (system("mtn", "--root=$config{mtnrootdir}", "update", "-r", $mergeResult) != 0) {
 298                                         warn("Unable to update to rev $mergeResult after merge on conflicted commit!");
 299                                 }
 300                         } else {
 301                                 warn("Auto-merge failed.  Using diff-merge to add conflict markers.");
 302
 303                                 $ENV{MTN_MERGE}="diffutils_force";
 304                                 $mergeResult = mtn_merge($newRevID, $rev, $branch, $author, "Merge parallel conflicting web edits (adding inline conflict markers).\nThis revision should be cleaned up manually.");
 305                                 $ENV{MTN_MERGE}="";
 306
 307                                 if (!defined($mergeResult)) {
 308                                         warn("Unable to insert conflict markers!");
 309                                         error("Your commit succeeded.  Unfortunately, someone else committed something to the same\n".
 310                                                 "part of the wiki at the same time.  Both versions are stored in the monotone repository,\n".
 311                                                 "but at present the different versions cannot be reconciled through the web interface.\n\n".
 312                                                 "Please use the non-web interface to resolve the conflicts.\n");
 313                                 }
 314
 315                                 # suspend this revision because it has conflict markers...
 316                                 if (system("mtn", "--root=$config{mtnrootdir}", "update", "-r", $mergeResult) != 0) {
 317                                         warn("Unable to update to rev $mergeResult after conflict-enhanced merge on conflicted commit!");
 318                                 }
 319
 320                                 # return "conflict enhanced" file to the user for cleanup
 321                                 # note, this relies on the fact that ikiwiki seems to call rcs_prepedit() again
 322                                 # after we return
 323                                 return readfile("$config{srcdir}/$file");
 324                         }
 325                         return undef;
 326                 }
 327                 $automator->close();
 328         }
 329
 330         # if we reached here then the file we're looking at hasn't changed since $oldrev.  Commit it.
 331
 332         if (system("mtn", "--root=$config{mtnrootdir}", "commit", "--quiet", "--author", $author, "--key", $config{mtnkey},
 333                                 "-m", possibly_foolish_untaint($message), $file) != 0) {
 334                 warn("Traditional commit failed!\nReturning data as conflict.\n");
 335                 my $conflict=readfile("$config{srcdir}/$file");
 336                 if (system("mtn", "--root=$config{mtnrootdir}", "revert", "--quiet", $file) != 0) {
 337                         warn("monotone revert failed\n");
 338                 }
 339                 return $conflict;
 340         }
 341         if (defined($config{mtnsync}) && $config{mtnsync}) {
 342                 if (system("mtn", "--root=$config{mtnrootdir}", "sync", "--quiet", "--ticker=none", "--key", $config{mtnkey}) != 0) {
 343                         warn("monotone sync failed\n");
 344                 }
 345         }
 346
 347         return undef # success
 348 }
 349
 350 sub rcs_add ($) {
 351         # Add a file. The filename is relative to the root of the srcdir.
 352         my $file=shift;
 353
 354         check_config();
 355
 356         if (system("mtn", "--root=$config{mtnrootdir}", "add", "--quiet", "$config{srcdir}/$file") != 0) {
 357                 error("Monotone add failed");
 358         }
 359 }
 360
 361 sub rcs_recentchanges ($) {
 362         # Examine the RCS history and generate a list of recent changes.
 363         # The data structure returned for each change is:
 364         # {
 365         #       user => # name of user who made the change,
 366         #       committype => # either "web" or the name of the rcs,
 367         #       when => # time when the change was made,
 368         #       message => [
 369         #               { line => "commit message line" },
 370         #               { line => "commit message line" },
 371         #               # etc,
 372         #       ],
 373         #       pages => [
 374         #               {
 375         #                       page => # name of page changed,
 376         #                       diffurl => # optional url to a diff showing
 377         #                                  # the changes,
 378         #               },
 379         #               # repeat for each page changed in this commit,
 380         #       ],
 381         # }
 382
 383         my $num=shift;
 384         my @ret;
 385
 386         check_config();
 387
 388         # use log --brief to get a list of revs, as this
 389         # gives the results in a nice order
 390         # (otherwise we'd have to do our own date sorting)
 391
 392         my @revs;
 393
 394         my $child = open(MTNLOG, "-|");
 395         if (! $child) {
 396                 exec("mtn", "log", "--root=$config{mtnrootdir}", "--no-graph", "--brief") || error("mtn log failed to run");
 397         }
 398
 399         my $line;
 400
 401         while (($num >= 0) and ($line = <MTNLOG>)) {
 402                 if ($line =~ m/^($sha1_pattern)/) {
 403                         push @revs, $1;
 404                         $num -= 1;
 405                 }
 406         }
 407         close MTNLOG || warn "mtn log exited $?";
 408
 409         my $automator = Monotone->new();
 410         $automator->open(undef, $config{mtnrootdir});
 411
 412         while (@revs != 0) {
 413                 my $rev = shift @revs;
 414                 # first go through and figure out the messages, etc
 415
 416                 my $certs = [read_certs($automator, $rev)];
 417
 418                 my $user;
 419                 my $when;
 420                 my $committype;
 421                 my (@pages, @message);
 422
 423                 foreach my $cert (@$certs) {
 424                         if ($cert->{signature} eq "ok" && $cert->{trust} eq "trusted") {
 425                                 if ($cert->{name} eq "author") {
 426                                         $user = $cert->{value};
 427                                         # detect the source of the commit from the changelog
 428                                         if ($cert->{key} eq $config{mtnkey}) {
 429                                                 $committype = "web";
 430                                         } else {
 431                                                 $committype = "monotone";
 432                                         }
 433                                 } elsif ($cert->{name} eq "date") {
 434                                         $when = time - str2time($cert->{value}, 'UTC');
 435                                 } elsif ($cert->{name} eq "changelog") {
 436                                         my $messageText = $cert->{value};
 437                                         # split the changelog into multiple lines
 438                                         foreach my $msgline (split(/\n/, $messageText)) {
 439                                                 push @message, { line => $msgline };
 440                                         }
 441                                 }
 442                         }
 443                 }
 444
 445                 my @changed_files = get_changed_files($automator, $rev);
 446                 my $file;
 447
 448                 foreach $file (@changed_files) {
 449                         push @pages, {
 450                                 page => pagename($file),
 451                         } if length $file;
 452                 }
 453
 454                 push @ret, {
 455                         rev => $rev,
 456                         user => $user,
 457                         committype => $committype,
 458                         when => $when,
 459                         message => [@message],
 460                         pages => [@pages],
 461                 } if @pages;
 462         }
 463
 464         $automator->close();
 465
 466         return @ret;
 467 }
 468
 469 sub rcs_notify () {
 470         # This function is called when a change is committed to the wiki,
 471         # and ikiwiki is running as a post-commit hook from the RCS.
 472         # It should examine the repository to somehow determine what pages
 473         # changed, and then send emails to users subscribed to those pages.
 474
 475         warn("The monotone rcs_notify function is currently untested.  Use at own risk!");
 476
 477         if (! exists $ENV{REV}) {
 478                 error(gettext("REV is not set, not running from mtn post-commit hook, cannot send notifications"));
 479         }
 480         if ($ENV{REV} !~ m/($sha1_pattern)/) { # sha1 is untainted now
 481                 error(gettext("REV is not a valid revision identifier, cannot send notifications"));
 482         }
 483         my $rev = $1;
 484
 485         check_config();
 486
 487         my $automator = Monotone->new();
 488         $automator->open(undef, $config{mtnrootdir});
 489
 490         my $certs = [read_certs($automator, $rev)];
 491         my $user;
 492         my $message;
 493         my $when;
 494
 495         foreach my $cert (@$certs) {
 496                 if ($cert->{signature} eq "ok" && $cert->{trust} eq "trusted") {
 497                         if ($cert->{name} eq "author") {
 498                                 $user = $cert->{value};
 499                         } elsif ($cert->{name} eq "date") {
 500                                 $when = $cert->{value};
 501                         } elsif ($cert->{name} eq "changelog") {
 502                                 $message = $cert->{value};
 503                         }
 504                 }
 505         }
 506
 507         my @changed_pages = get_changed_files($automator, $rev);
 508
 509         $automator->close();
 510
 511         require IkiWiki::UserInfo;
 512         send_commit_mails(
 513                 sub {
 514                         return $message;
 515                 },
 516                 sub {
 517                         `mtn --root=$config{mtnrootdir} au content_diff -r $rev`;
 518                 }, $user, @changed_pages);
 519 }
 520
 521 sub rcs_getctime ($) {
 522         # Optional, used to get the page creation time from the RCS.
 523         # error gettext("getctime not implemented");
 524         my $file=shift;
 525
 526         check_config();
 527
 528         my $child = open(MTNLOG, "-|");
 529         if (! $child) {
 530                 exec("mtn", "log", "--root=$config{mtnrootdir}", "--no-graph", "--brief", $file) || error("mtn log $file failed to run");
 531         }
 532
 533         my $firstRev;
 534         while (<MTNLOG>) {
 535                 if (/^($sha1_pattern)/) {
 536                         $firstRev=$1;
 537                 }
 538         }
 539         close MTNLOG || warn "mtn log $file exited $?";
 540
 541         if (! defined $firstRev) {
 542                 warn "failed to parse mtn log for $file\n";
 543                 return 0;
 544         }
 545
 546         my $automator = Monotone->new();
 547         $automator->open(undef, $config{mtnrootdir});
 548
 549         my $certs = [read_certs($automator, $firstRev)];
 550
 551         $automator->close();
 552
 553         my $date;
 554
 555         foreach my $cert (@$certs) {
 556                 if ($cert->{signature} eq "ok" && $cert->{trust} eq "trusted") {
 557                         if ($cert->{name} eq "date") {
 558                                 $date = $cert->{value};
 559                         }
 560                 }
 561         }
 562
 563         if (! defined $date) {
 564                 warn "failed to find date cert for revision $firstRev when looking for creation time of $file\n";
 565                 return 0;
 566         }
 567
 568         $date=str2time($date, 'UTC');
 569         debug("found ctime ".localtime($date)." for $file");
 570         return $date;
 571 }
 572
 573 1
 574
 575 # default mergerc content
 576 __DATA__
 577         function local_execute_redirected(stdin, stdout, stderr, path, ...)
 578            local pid
 579            local ret = -1
 580            io.flush();
 581            pid = spawn_redirected(stdin, stdout, stderr, path, unpack(arg))
 582            if (pid ~= -1) then ret, pid = wait(pid) end
 583            return ret
 584         end
 585         if (not execute_redirected) then -- use standard function if available
 586            execute_redirected = local_execute_redirected
 587         end
 588         if (not mergers.fail) then -- use standard merger if available
 589            mergers.fail = {
 590               cmd = function (tbl) return false end,
 591               available = function () return true end,
 592               wanted = function () return true end
 593            }
 594         end
 595         mergers.diffutils_force = {
 596            cmd = function (tbl)
 597               local ret = execute_redirected(
 598                   "",
 599                   tbl.outfile,
 600                   "",
 601                   "diff3",
 602                   "--merge",
 603                   "--show-overlap",
 604                   "--label", string.format("[Yours]",     tbl.left_path ),
 605                   "--label", string.format("[Original]",  tbl.anc_path  ),
 606                   "--label", string.format("[Theirs]",    tbl.right_path),
 607                   tbl.lfile,
 608                   tbl.afile,
 609                   tbl.rfile
 610               )
 611               if (ret > 1) then
 612                  io.write(gettext("Error running GNU diffutils 3-way difference tool 'diff3'"))
 613                  return false
 614               end
 615               return tbl.outfile
 616            end,
 617            available =
 618               function ()
 619                   return program_exists_in_path("diff3");
 620               end,
 621            wanted =
 622               function ()
 623                    return true
 624               end
 625         }
 626 EOF