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