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