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