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                 my $diff = `mtn --root=$config{mtnrootdir} au content_diff -r $oldrev -r $rev $file`; # was just $out;
 249
 250                 if ($diff) {
 251                         # Commit a revision with just this file changed off
 252                         # the old revision.
 253                         #
 254                         # first get the contents
 255                         debug("File changed: forming branch");
 256                         my $newfile=readfile("$config{srcdir}/$file");
 257
 258                         # then get the old content ID from the diff
 259                         if ($diff !~ m/^---\s$file\s+($sha1_pattern)$/m) {
 260                                 error("Unable to find previous file ID for $file");
 261                         }
 262                         my $oldFileID = $1;
 263
 264                         # get the branch we're working in
 265                         ($out, $err) = $automator->call("get_option", "branch");
 266                         chomp $out;
 267                         error("Illegal branch name in monotone workspace") if ($out !~ m/^([-\@\w\.]+)$/);
 268                         my $branch = $1;
 269
 270                         # then put the new content into the DB (and record the new content ID)
 271                         my $newRevID = commit_file_to_new_rev($automator, $file, $oldFileID, $newfile, $oldrev, $branch, $author, $message);
 272
 273                         $automator->close();
 274
 275                         # if we made it to here then the file has been committed... revert the local copy
 276                         if (system("mtn", "--root=$config{mtnrootdir}", "revert", $file) != 0) {
 277                                 debug("Unable to revert $file after merge on conflicted commit!");
 278                         }
 279                         debug("Divergence created! Attempting auto-merge.");
 280
 281                         check_mergerc();
 282
 283                         # see if it will merge cleanly
 284                         $ENV{MTN_MERGE}="fail";
 285                         my $mergeResult = mtn_merge($newRevID, $rev, $branch, $author);
 286                         $ENV{MTN_MERGE}="";
 287
 288                         # push any changes so far
 289                         if (defined($config{mtnsync}) && $config{mtnsync}) {
 290                                 if (system("mtn", "--root=$config{mtnrootdir}", "push", "--quiet", "--ticker=none", "--key", $config{mtnkey}) != 0) {
 291                                         debug("monotone push failed");
 292                                 }
 293                         }
 294
 295                         if (defined($mergeResult)) {
 296                                 # everything is merged - bring outselves up to date
 297                                 if (system("mtn", "--root=$config{mtnrootdir}",
 298                                            "update", "-r", $mergeResult) != 0) {
 299                                         debug("Unable to update to rev $mergeResult after merge on conflicted commit!");
 300                                 }
 301                         }
 302                         else {
 303                                 debug("Auto-merge failed.  Using diff-merge to add conflict markers.");
 304
 305                                 $ENV{MTN_MERGE}="diffutils_force";
 306                                 $mergeResult = mtn_merge($newRevID, $rev, $branch, $author);
 307                                 $ENV{MTN_MERGE}="";
 308
 309                                 if (!defined($mergeResult)) {
 310                                         debug("Unable to insert conflict markers!");
 311                                         error("Your commit succeeded. Unfortunately, someone else committed something to the same ".
 312                                                 "part of the wiki at the same time. Both versions are stored in the monotone repository, ".
 313                                                 "but at present the different versions cannot be reconciled through the web interface. ".
 314                                                 "Please use the non-web interface to resolve the conflicts.");
 315                                 }
 316
 317                                 # suspend this revision because it has
 318                                 # conflict markers...
 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}", "sync",
 351                            "--quiet", "--ticker=none", "--key",
 352                            $config{mtnkey}) != 0) {
 353                         debug("monotone sync 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                    "$config{srcdir}/$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 = time - 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                 foreach $file (@changed_files) {
 440                         push @pages, {
 441                                 page => pagename($file),
 442                         } if length $file;
 443                 }
 444
 445                 push @ret, {
 446                         rev => $rev,
 447                         user => $user,
 448                         committype => $committype,
 449                         when => $when,
 450                         message => [@message],
 451                         pages => [@pages],
 452                 } if @pages;
 453         }
 454
 455         $automator->close();
 456
 457         return @ret;
 458 } #}}}
 459
 460 sub rcs_notify () { #{{{
 461         debug("The monotone rcs_notify function is currently untested. Use at own risk!");
 462
 463         if (! exists $ENV{REV}) {
 464                 error(gettext("REV is not set, not running from mtn post-commit hook, cannot send notifications"));
 465         }
 466         if ($ENV{REV} !~ m/($sha1_pattern)/) { # sha1 is untainted now
 467                 error(gettext("REV is not a valid revision identifier, cannot send notifications"));
 468         }
 469         my $rev = $1;
 470
 471         check_config();
 472
 473         my $automator = Monotone->new();
 474         $automator->open(undef, $config{mtnrootdir});
 475
 476         my $certs = [read_certs($automator, $rev)];
 477         my $user;
 478         my $message;
 479         my $when;
 480
 481         foreach my $cert (@$certs) {
 482                 if ($cert->{signature} eq "ok" && $cert->{trust} eq "trusted") {
 483                         if ($cert->{name} eq "author") {
 484                                 $user = $cert->{value};
 485                         } elsif ($cert->{name} eq "date") {
 486                                 $when = $cert->{value};
 487                         } elsif ($cert->{name} eq "changelog") {
 488                                 $message = $cert->{value};
 489                         }
 490                 }
 491         }
 492
 493         my @changed_pages = get_changed_files($automator, $rev);
 494
 495         $automator->close();
 496
 497         require IkiWiki::UserInfo;
 498         send_commit_mails(
 499                 sub {
 500                         return $message;
 501                 },
 502                 sub {
 503                         `mtn --root=$config{mtnrootdir} au content_diff -r $rev`;
 504                 },
 505                 $user, @changed_pages);
 506 } #}}}
 507
 508 sub rcs_getctime ($) { #{{{
 509         my $file=shift;
 510
 511         check_config();
 512
 513         my $child = open(MTNLOG, "-|");
 514         if (! $child) {
 515                 exec("mtn", "log", "--root=$config{mtnrootdir}", "--no-graph",
 516                      "--brief", $file) || error("mtn log $file failed to run");
 517         }
 518
 519         my $firstRev;
 520         while (<MTNLOG>) {
 521                 if (/^($sha1_pattern)/) {
 522                         $firstRev=$1;
 523                 }
 524         }
 525         close MTNLOG || debug("mtn log $file exited $?");
 526
 527         if (! defined $firstRev) {
 528                 debug "failed to parse mtn log for $file";
 529                 return 0;
 530         }
 531
 532         my $automator = Monotone->new();
 533         $automator->open(undef, $config{mtnrootdir});
 534
 535         my $certs = [read_certs($automator, $firstRev)];
 536
 537         $automator->close();
 538
 539         my $date;
 540
 541         foreach my $cert (@$certs) {
 542                 if ($cert->{signature} eq "ok" && $cert->{trust} eq "trusted") {
 543                         if ($cert->{name} eq "date") {
 544                                 $date = $cert->{value};
 545                         }
 546                 }
 547         }
 548
 549         if (! defined $date) {
 550                 debug "failed to find date cert for revision $firstRev when looking for creation time of $file";
 551                 return 0;
 552         }
 553
 554         $date=str2time($date, 'UTC');
 555         debug("found ctime ".localtime($date)." for $file");
 556         return $date;
 557 } #}}}
 558
 559 1
 560
 561 # default mergerc content
 562 __DATA__
 563         function local_execute_redirected(stdin, stdout, stderr, path, ...)
 564            local pid
 565            local ret = -1
 566            io.flush();
 567            pid = spawn_redirected(stdin, stdout, stderr, path, unpack(arg))
 568            if (pid ~= -1) then ret, pid = wait(pid) end
 569            return ret
 570         end
 571         if (not execute_redirected) then -- use standard function if available
 572            execute_redirected = local_execute_redirected
 573         end
 574         if (not mergers.fail) then -- use standard merger if available
 575            mergers.fail = {
 576               cmd = function (tbl) return false end,
 577               available = function () return true end,
 578               wanted = function () return true end
 579            }
 580         end
 581         mergers.diffutils_force = {
 582            cmd = function (tbl)
 583               local ret = execute_redirected(
 584                   "",
 585                   tbl.outfile,
 586                   "",
 587                   "diff3",
 588                   "--merge",
 589                   "--show-overlap",
 590                   "--label", string.format("[Yours]",     tbl.left_path ),
 591                   "--label", string.format("[Original]",  tbl.anc_path  ),
 592                   "--label", string.format("[Theirs]",    tbl.right_path),
 593                   tbl.lfile,
 594                   tbl.afile,
 595                   tbl.rfile
 596               )
 597               if (ret > 1) then
 598                  io.write(gettext("Error running GNU diffutils 3-way difference tool 'diff3'"))
 599                  return false
 600               end
 601               return tbl.outfile
 602            end,
 603            available =
 604               function ()
 605                   return program_exists_in_path("diff3");
 606               end,
 607            wanted =
 608               function ()
 609                    return true
 610               end
 611         }
 612 EOF