IkiWiki/Rcs/monotone.pm

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