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