git.oblomov.eu Git - ikiwiki/blob - 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                 #my ($out, $err) = $automator->call("content_diff", $file);
 244                 #debug("Problem committing $file") if ($err ne "");
 245                 # FIXME: use of $file in these backticks is not wise from a
 246                 # security POV. Probably safe, but should be avoided
 247                 # anyway.
 248                 # At the moment the backticks are used because the above call using the automate
 249                 # interface was failing.  When that bug in monotone is fixed, we should switch
 250                 # back.
 251                 my $diff = `mtn --root=$config{mtnrootdir} au content_diff -r $oldrev -r $rev $file`; # was just $out;
 252
 253                 if ($diff) {
 254                         # Commit a revision with just this file changed off
 255                         # the old revision.
 256                         #
 257                         # first get the contents
 258                         debug("File changed: forming branch");
 259                         my $newfile=readfile("$config{srcdir}/$file");
 260
 261                         # then get the old content ID from the diff
 262                         if ($diff !~ m/^---\s$file\s+($sha1_pattern)$/m) {
 263                                 error("Unable to find previous file ID for $file");
 264                         }
 265                         my $oldFileID = $1;
 266
 267                         # get the branch we're working in
 268                         ($out, $err) = $automator->call("get_option", "branch");
 269                         chomp $out;
 270                         error("Illegal branch name in monotone workspace") if ($out !~ m/^([-\@\w\.]+)$/);
 271                         my $branch = $1;
 272
 273                         # then put the new content into the DB (and record the new content ID)
 274                         my $newRevID = commit_file_to_new_rev($automator, $file, $oldFileID, $newfile, $oldrev, $branch, $author, $message);
 275
 276                         $automator->close();
 277
 278                         # if we made it to here then the file has been committed... revert the local copy
 279                         if (system("mtn", "--root=$config{mtnrootdir}", "revert", $file) != 0) {
 280                                 debug("Unable to revert $file after merge on conflicted commit!");
 281                         }
 282                         debug("Divergence created! Attempting auto-merge.");
 283
 284                         check_mergerc();
 285
 286                         # see if it will merge cleanly
 287                         $ENV{MTN_MERGE}="fail";
 288                         my $mergeResult = mtn_merge($newRevID, $rev, $branch, $author);
 289                         $ENV{MTN_MERGE}="";
 290
 291                         # push any changes so far
 292                         if (defined($config{mtnsync}) && $config{mtnsync}) {
 293                                 if (system("mtn", "--root=$config{mtnrootdir}", "push", "--quiet", "--ticker=none", "--key", $config{mtnkey}) != 0) {
 294                                         debug("monotone push failed");
 295                                 }
 296                         }
 297
 298                         if (defined($mergeResult)) {
 299                                 # everything is merged - bring outselves up to date
 300                                 if (system("mtn", "--root=$config{mtnrootdir}",
 301                                            "update", "-r", $mergeResult) != 0) {
 302                                         debug("Unable to update to rev $mergeResult after merge on conflicted commit!");
 303                                 }
 304                         }
 305                         else {
 306                                 debug("Auto-merge failed.  Using diff-merge to add conflict markers.");
 307
 308                                 $ENV{MTN_MERGE}="diffutils_force";
 309                                 $mergeResult = mtn_merge($newRevID, $rev, $branch, $author);
 310                                 $ENV{MTN_MERGE}="";
 311
 312                                 if (!defined($mergeResult)) {
 313                                         debug("Unable to insert conflict markers!");
 314                                         error("Your commit succeeded. Unfortunately, someone else committed something to the same ".
 315                                                 "part of the wiki at the same time. Both versions are stored in the monotone repository, ".
 316                                                 "but at present the different versions cannot be reconciled through the web interface. ".
 317                                                 "Please use the non-web interface to resolve the conflicts.");
 318                                 }
 319
 320                                 if (system("mtn", "--root=$config{mtnrootdir}",
 321                                            "update", "-r", $mergeResult) != 0) {
 322                                         debug("Unable to update to rev $mergeResult after conflict-enhanced merge on conflicted commit!");
 323                                 }
 324
 325                                 # return "conflict enhanced" file to the user
 326                                 # for cleanup note, this relies on the fact
 327                                 # that ikiwiki seems to call rcs_prepedit()
 328                                 # again after we return
 329                                 return readfile("$config{srcdir}/$file");
 330                         }
 331                         return undef;
 332                 }
 333                 $automator->close();
 334         }
 335
 336         # If we reached here then the file we're looking at hasn't changed
 337         # since $oldrev. Commit it.
 338
 339         if (system("mtn", "--root=$config{mtnrootdir}", "commit", "--quiet",
 340                    "--author", $author, "--key", $config{mtnkey}, "-m",
 341                    possibly_foolish_untaint($message), $file) != 0) {
 342                 debug("Traditional commit failed! Returning data as conflict.");
 343                 my $conflict=readfile("$config{srcdir}/$file");
 344                 if (system("mtn", "--root=$config{mtnrootdir}", "revert",
 345                            "--quiet", $file) != 0) {
 346                         debug("monotone revert failed");
 347                 }
 348                 return $conflict;
 349         }
 350         if (defined($config{mtnsync}) && $config{mtnsync}) {
 351                 if (system("mtn", "--root=$config{mtnrootdir}", "sync",
 352                            "--quiet", "--ticker=none", "--key",
 353                            $config{mtnkey}) != 0) {
 354                         debug("monotone sync failed");
 355                 }
 356         }
 357
 358         return undef # success
 359 } #}}}
 360
 361 sub rcs_add ($) { #{{{
 362         my $file=shift;
 363
 364         check_config();
 365
 366         if (system("mtn", "--root=$config{mtnrootdir}", "add", "--quiet",
 367                    $file) != 0) {
 368                 error("Monotone add failed");
 369         }
 370 } #}}}
 371
 372 sub rcs_recentchanges ($) { #{{{
 373         my $num=shift;
 374         my @ret;
 375
 376         check_config();
 377
 378         # use log --brief to get a list of revs, as this
 379         # gives the results in a nice order
 380         # (otherwise we'd have to do our own date sorting)
 381
 382         my @revs;
 383
 384         my $child = open(MTNLOG, "-|");
 385         if (! $child) {
 386                 exec("mtn", "log", "--root=$config{mtnrootdir}", "--no-graph",
 387                      "--brief") || error("mtn log failed to run");
 388         }
 389
 390         while (($num >= 0) and (my $line = <MTNLOG>)) {
 391                 if ($line =~ m/^($sha1_pattern)/) {
 392                         push @revs, $1;
 393                         $num -= 1;
 394                 }
 395         }
 396         close MTNLOG || debug("mtn log exited $?");
 397
 398         my $automator = Monotone->new();
 399         $automator->open(undef, $config{mtnrootdir});
 400
 401         while (@revs != 0) {
 402                 my $rev = shift @revs;
 403                 # first go through and figure out the messages, etc
 404
 405                 my $certs = [read_certs($automator, $rev)];
 406
 407                 my $user;
 408                 my $when;
 409                 my $committype;
 410                 my (@pages, @message);
 411
 412                 foreach my $cert (@$certs) {
 413                         if ($cert->{signature} eq "ok" &&
 414                             $cert->{trust} eq "trusted") {
 415                                 if ($cert->{name} eq "author") {
 416                                         $user = $cert->{value};
 417                                         # detect the source of the commit
 418                                         # from the changelog
 419                                         if ($cert->{key} eq $config{mtnkey}) {
 420                                                 $committype = "web";
 421                                         } else {
 422                                                 $committype = "monotone";
 423                                         }
 424                                 } elsif ($cert->{name} eq "date") {
 425                                         $when = time - str2time($cert->{value}, 'UTC');
 426                                 } elsif ($cert->{name} eq "changelog") {
 427                                         my $messageText = $cert->{value};
 428                                         # split the changelog into multiple
 429                                         # lines
 430                                         foreach my $msgline (split(/\n/, $messageText)) {
 431                                                 push @message, { line => $msgline };
 432                                         }
 433                                 }
 434                         }
 435                 }
 436
 437                 my @changed_files = get_changed_files($automator, $rev);
 438                 my $file;
 439
 440                 foreach $file (@changed_files) {
 441                         push @pages, {
 442                                 page => pagename($file),
 443                         } if length $file;
 444                 }
 445
 446                 push @ret, {
 447                         rev => $rev,
 448                         user => $user,
 449                         committype => $committype,
 450                         when => $when,
 451                         message => [@message],
 452                         pages => [@pages],
 453                 } if @pages;
 454         }
 455
 456         $automator->close();
 457
 458         return @ret;
 459 } #}}}
 460
 461 sub rcs_notify () { #{{{
 462         debug("The monotone rcs_notify function is currently untested. Use at own risk!");
 463
 464         if (! exists $ENV{REV}) {
 465                 error(gettext("REV is not set, not running from mtn post-commit hook, cannot send notifications"));
 466         }
 467         if ($ENV{REV} !~ m/($sha1_pattern)/) { # sha1 is untainted now
 468                 error(gettext("REV is not a valid revision identifier, cannot send notifications"));
 469         }
 470         my $rev = $1;
 471
 472         check_config();
 473
 474         my $automator = Monotone->new();
 475         $automator->open(undef, $config{mtnrootdir});
 476
 477         my $certs = [read_certs($automator, $rev)];
 478         my $user;
 479         my $message;
 480         my $when;
 481
 482         foreach my $cert (@$certs) {
 483                 if ($cert->{signature} eq "ok" && $cert->{trust} eq "trusted") {
 484                         if ($cert->{name} eq "author") {
 485                                 $user = $cert->{value};
 486                         } elsif ($cert->{name} eq "date") {
 487                                 $when = $cert->{value};
 488                         } elsif ($cert->{name} eq "changelog") {
 489                                 $message = $cert->{value};
 490                         }
 491                 }
 492         }
 493
 494         my @changed_pages = get_changed_files($automator, $rev);
 495
 496         $automator->close();
 497
 498         require IkiWiki::UserInfo;
 499         send_commit_mails(
 500                 sub {
 501                         return $message;
 502                 },
 503                 sub {
 504                         `mtn --root=$config{mtnrootdir} au content_diff -r $rev`;
 505                 },
 506                 $user, @changed_pages);
 507 } #}}}
 508
 509 sub rcs_getctime ($) { #{{{
 510         my $file=shift;
 511
 512         check_config();
 513
 514         my $child = open(MTNLOG, "-|");
 515         if (! $child) {
 516                 exec("mtn", "log", "--root=$config{mtnrootdir}", "--no-graph",
 517                      "--brief", $file) || error("mtn log $file failed to run");
 518         }
 519
 520         my $firstRev;
 521         while (<MTNLOG>) {
 522                 if (/^($sha1_pattern)/) {
 523                         $firstRev=$1;
 524                 }
 525         }
 526         close MTNLOG || debug("mtn log $file exited $?");
 527
 528         if (! defined $firstRev) {
 529                 debug "failed to parse mtn log for $file";
 530                 return 0;
 531         }
 532
 533         my $automator = Monotone->new();
 534         $automator->open(undef, $config{mtnrootdir});
 535
 536         my $certs = [read_certs($automator, $firstRev)];
 537
 538         $automator->close();
 539
 540         my $date;
 541
 542         foreach my $cert (@$certs) {
 543                 if ($cert->{signature} eq "ok" && $cert->{trust} eq "trusted") {
 544                         if ($cert->{name} eq "date") {
 545                                 $date = $cert->{value};
 546                         }
 547                 }
 548         }
 549
 550         if (! defined $date) {
 551                 debug "failed to find date cert for revision $firstRev when looking for creation time of $file";
 552                 return 0;
 553         }
 554
 555         $date=str2time($date, 'UTC');
 556         debug("found ctime ".localtime($date)." for $file");
 557         return $date;
 558 } #}}}
 559
 560 1
 561
 562 # default mergerc content
 563 __DATA__
 564         function local_execute_redirected(stdin, stdout, stderr, path, ...)
 565            local pid
 566            local ret = -1
 567            io.flush();
 568            pid = spawn_redirected(stdin, stdout, stderr, path, unpack(arg))
 569            if (pid ~= -1) then ret, pid = wait(pid) end
 570            return ret
 571         end
 572         if (not execute_redirected) then -- use standard function if available
 573            execute_redirected = local_execute_redirected
 574         end
 575         if (not mergers.fail) then -- use standard merger if available
 576            mergers.fail = {
 577               cmd = function (tbl) return false end,
 578               available = function () return true end,
 579               wanted = function () return true end
 580            }
 581         end
 582         mergers.diffutils_force = {
 583            cmd = function (tbl)
 584               local ret = execute_redirected(
 585                   "",
 586                   tbl.outfile,
 587                   "",
 588                   "diff3",
 589                   "--merge",
 590                   "--show-overlap",
 591                   "--label", string.format("[Yours]",     tbl.left_path ),
 592                   "--label", string.format("[Original]",  tbl.anc_path  ),
 593                   "--label", string.format("[Theirs]",    tbl.right_path),
 594                   tbl.lfile,
 595                   tbl.afile,
 596                   tbl.rfile
 597               )
 598               if (ret > 1) then
 599                  io.write(gettext("Error running GNU diffutils 3-way difference tool 'diff3'"))
 600                  return false
 601               end
 602               return tbl.outfile
 603            end,
 604            available =
 605               function ()
 606                   return program_exists_in_path("diff3");
 607               end,
 608            wanted =
 609               function ()
 610                    return true
 611               end
 612         }
 613 EOF