]> git.vanrenterghem.biz Git - git.ikiwiki.info.git/blob - IkiWiki/Rcs/monotone.pm
Do not allow the about: URI scheme
[git.ikiwiki.info.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);
9 package IkiWiki;
11 my $sha1_pattern = qr/[0-9a-fA-F]{40}/; # pattern to validate sha1sums
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 } #}}}
29 sub get_rev () { #{{{
30         my $sha1 = `mtn --root=$config{mtnrootdir} automate get_base_revision_id`;
32         ($sha1) = $sha1 =~ m/($sha1_pattern)/; # sha1 is untainted now
33         if (! $sha1) {
34                 debug("Unable to get base revision for '$config{srcdir}'.")
35         }
37         return $sha1;
38 } #}}}
40 sub get_rev_auto ($) { #{{{
41         my $automator=shift;
43         my @results = $automator->call("get_base_revision_id");
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         }
51         return $sha1;
52 } #}}}
54 sub mtn_merge ($$$$) { #{{{
55         my $leftRev=shift;
56         my $rightRev=shift;
57         my $branch=shift;
58         my $author=shift;
59     
60         my $mergeRev;
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         }
73         while (<MTNMERGE>) {
74                 if (/^mtn.\s.merged.\s($sha1_pattern)$/) {
75                         $mergeRev=$1;
76                 }
77         }
78         
79         close MTNMERGE || return undef;
81         debug("merged $leftRev, $rightRev to make $mergeRev");
83         return $mergeRev;
84 } #}}}
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);
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");
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 } #}}}
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 } #}}}
143 sub read_certs ($$) { #{{{
144         my $automator=shift;
145         my $rev=shift;
146         my @results = $automator->call("certs", $rev);
147         my @ret;
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         }
160         return @ret;
161 } #}}}
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];
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 } #}}}
185 sub rcs_update () { #{{{
186         check_config();
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         }
196         if (system("mtn", "--root=$config{mtnrootdir}", "update", "--quiet") != 0) {
197                 debug("monotone update failed");
198         }
199 } #}}}
201 sub rcs_prepedit ($) { #{{{
202         my $file=shift;
204         check_config();
206         # For monotone, return the revision of the file when
207         # editing begins.
208         return get_rev();
209 } #}}}
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;
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         }
232         check_config();
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});
240                 # Something has been committed, has this file changed?
241                 my ($out, $err);
242                 $automator->setOpts("r", $oldrev, "r", $rev);
243                 ($out, $err) = $automator->call("content_diff", $file);
244                 debug("Problem committing $file") if ($err ne "");
245                 my $diff = $out;
246                 
247                 if ($diff) {
248                         # Commit a revision with just this file changed off
249                         # the old revision.
250                         #
251                         # first get the contents
252                         debug("File changed: forming branch");
253                         my $newfile=readfile("$config{srcdir}/$file");
254                         
255                         # then get the old content ID from the diff
256                         if ($diff !~ m/^---\s$file\s+($sha1_pattern)$/m) {
257                                 error("Unable to find previous file ID for $file");
258                         }
259                         my $oldFileID = $1;
261                         # get the branch we're working in
262                         ($out, $err) = $automator->call("get_option", "branch");
263                         chomp $out;
264                         error("Illegal branch name in monotone workspace") if ($out !~ m/^([-\@\w\.]+)$/);
265                         my $branch = $1;
267                         # then put the new content into the DB (and record the new content ID)
268                         my $newRevID = commit_file_to_new_rev($automator, $file, $oldFileID, $newfile, $oldrev, $branch, $author, $message);
270                         $automator->close();
272                         # if we made it to here then the file has been committed... revert the local copy
273                         if (system("mtn", "--root=$config{mtnrootdir}", "revert", $file) != 0) {
274                                 debug("Unable to revert $file after merge on conflicted commit!");
275                         }
276                         debug("Divergence created! Attempting auto-merge.");
278                         check_mergerc();
280                         # see if it will merge cleanly
281                         $ENV{MTN_MERGE}="fail";
282                         my $mergeResult = mtn_merge($newRevID, $rev, $branch, $author);
283                         $ENV{MTN_MERGE}="";
285                         # push any changes so far
286                         if (defined($config{mtnsync}) && $config{mtnsync}) {
287                                 if (system("mtn", "--root=$config{mtnrootdir}", "push", "--quiet", "--ticker=none", "--key", $config{mtnkey}) != 0) {
288                                         debug("monotone push failed");
289                                 }
290                         }
291                         
292                         if (defined($mergeResult)) {
293                                 # everything is merged - bring outselves up to date
294                                 if (system("mtn", "--root=$config{mtnrootdir}",
295                                            "update", "-r", $mergeResult) != 0) {
296                                         debug("Unable to update to rev $mergeResult after merge on conflicted commit!");
297                                 }
298                         }
299                         else {
300                                 debug("Auto-merge failed.  Using diff-merge to add conflict markers.");
301                                 
302                                 $ENV{MTN_MERGE}="diffutils_force";
303                                 $mergeResult = mtn_merge($newRevID, $rev, $branch, $author);
304                                 $ENV{MTN_MERGE}="";
305                                 
306                                 if (!defined($mergeResult)) {
307                                         debug("Unable to insert conflict markers!");
308                                         error("Your commit succeeded. Unfortunately, someone else committed something to the same ".
309                                                 "part of the wiki at the same time. Both versions are stored in the monotone repository, ".
310                                                 "but at present the different versions cannot be reconciled through the web interface. ".
311                                                 "Please use the non-web interface to resolve the conflicts.");
312                                 }
313                                 
314                                 if (system("mtn", "--root=$config{mtnrootdir}",
315                                            "update", "-r", $mergeResult) != 0) {
316                                         debug("Unable to update to rev $mergeResult after conflict-enhanced merge on conflicted commit!");
317                                 }
318                                 
319                                 # return "conflict enhanced" file to the user
320                                 # for cleanup note, this relies on the fact
321                                 # that ikiwiki seems to call rcs_prepedit()
322                                 # again after we return
323                                 return readfile("$config{srcdir}/$file");
324                         }
325                         return undef;
326                 }
327                 $automator->close();
328         }
330         # If we reached here then the file we're looking at hasn't changed
331         # since $oldrev. Commit it.
333         if (system("mtn", "--root=$config{mtnrootdir}", "commit", "--quiet",
334                    "--author", $author, "--key", $config{mtnkey}, "-m",
335                    possibly_foolish_untaint($message), $file) != 0) {
336                 debug("Traditional commit failed! Returning data as conflict.");
337                 my $conflict=readfile("$config{srcdir}/$file");
338                 if (system("mtn", "--root=$config{mtnrootdir}", "revert",
339                            "--quiet", $file) != 0) {
340                         debug("monotone revert failed");
341                 }
342                 return $conflict;
343         }
344         if (defined($config{mtnsync}) && $config{mtnsync}) {
345                 if (system("mtn", "--root=$config{mtnrootdir}", "push",
346                            "--quiet", "--ticker=none", "--key",
347                            $config{mtnkey}) != 0) {
348                         debug("monotone push failed");
349                 }
350         }
352         return undef # success
353 } #}}}
355 sub rcs_add ($) { #{{{
356         my $file=shift;
358         check_config();
360         if (system("mtn", "--root=$config{mtnrootdir}", "add", "--quiet",
361                    $file) != 0) {
362                 error("Monotone add failed");
363         }
364 } #}}}
366 sub rcs_recentchanges ($) { #{{{
367         my $num=shift;
368         my @ret;
370         check_config();
372         # use log --brief to get a list of revs, as this
373         # gives the results in a nice order
374         # (otherwise we'd have to do our own date sorting)
376         my @revs;
378         my $child = open(MTNLOG, "-|");
379         if (! $child) {
380                 exec("mtn", "log", "--root=$config{mtnrootdir}", "--no-graph",
381                      "--brief") || error("mtn log failed to run");
382         }
384         while (($num >= 0) and (my $line = <MTNLOG>)) {
385                 if ($line =~ m/^($sha1_pattern)/) {
386                         push @revs, $1;
387                         $num -= 1;
388                 }
389         }
390         close MTNLOG || debug("mtn log exited $?");
392         my $automator = Monotone->new();
393         $automator->open(undef, $config{mtnrootdir});
395         while (@revs != 0) {
396                 my $rev = shift @revs;
397                 # first go through and figure out the messages, etc
399                 my $certs = [read_certs($automator, $rev)];
400                 
401                 my $user;
402                 my $when;
403                 my $committype;
404                 my (@pages, @message);
405                 
406                 foreach my $cert (@$certs) {
407                         if ($cert->{signature} eq "ok" &&
408                             $cert->{trust} eq "trusted") {
409                                 if ($cert->{name} eq "author") {
410                                         $user = $cert->{value};
411                                         # detect the source of the commit
412                                         # from the changelog
413                                         if ($cert->{key} eq $config{mtnkey}) {
414                                                 $committype = "web";
415                                         } else {
416                                                 $committype = "monotone";
417                                         }
418                                 } elsif ($cert->{name} eq "date") {
419                                         $when = str2time($cert->{value}, 'UTC');
420                                 } elsif ($cert->{name} eq "changelog") {
421                                         my $messageText = $cert->{value};
422                                         # split the changelog into multiple
423                                         # lines
424                                         foreach my $msgline (split(/\n/, $messageText)) {
425                                                 push @message, { line => $msgline };
426                                         }
427                                 }
428                         }
429                 }
430                 
431                 my @changed_files = get_changed_files($automator, $rev);
432                 my $file;
433                 
434                 my ($out, $err) = $automator->call("parents", $rev);
435                 my @parents = ($out =~ m/^($sha1_pattern)$/);
436                 my $parent = $parents[0];
438                 foreach $file (@changed_files) {
439                         next unless length $file;
440                         
441                         if (defined $config{diffurl} and (@parents == 1)) {
442                                 my $diffurl=$config{diffurl};
443                                 $diffurl=~s/\[\[r1\]\]/$parent/g;
444                                 $diffurl=~s/\[\[r2\]\]/$rev/g;
445                                 $diffurl=~s/\[\[file\]\]/$file/g;
446                                 push @pages, {
447                                         page => pagename($file),
448                                         diffurl => $diffurl,
449                                 };
450                         }
451                         else {
452                                 push @pages, {
453                                         page => pagename($file),
454                                 }
455                         }
456                 }
457                 
458                 push @ret, {
459                         rev => $rev,
460                         user => $user,
461                         committype => $committype,
462                         when => $when,
463                         message => [@message],
464                         pages => [@pages],
465                 } if @pages;
466         }
468         $automator->close();
470         return @ret;
471 } #}}}
473 sub rcs_getctime ($) { #{{{
474         my $file=shift;
476         check_config();
478         my $child = open(MTNLOG, "-|");
479         if (! $child) {
480                 exec("mtn", "log", "--root=$config{mtnrootdir}", "--no-graph",
481                      "--brief", $file) || error("mtn log $file failed to run");
482         }
484         my $firstRev;
485         while (<MTNLOG>) {
486                 if (/^($sha1_pattern)/) {
487                         $firstRev=$1;
488                 }
489         }
490         close MTNLOG || debug("mtn log $file exited $?");
492         if (! defined $firstRev) {
493                 debug "failed to parse mtn log for $file";
494                 return 0;
495         }
497         my $automator = Monotone->new();
498         $automator->open(undef, $config{mtnrootdir});
500         my $certs = [read_certs($automator, $firstRev)];
502         $automator->close();
504         my $date;
506         foreach my $cert (@$certs) {
507                 if ($cert->{signature} eq "ok" && $cert->{trust} eq "trusted") {
508                         if ($cert->{name} eq "date") {
509                                 $date = $cert->{value};
510                         }
511                 }
512         }
514         if (! defined $date) {
515                 debug "failed to find date cert for revision $firstRev when looking for creation time of $file";
516                 return 0;
517         }
519         $date=str2time($date, 'UTC');
520         debug("found ctime ".localtime($date)." for $file");
521         return $date;
522 } #}}}
526 # default mergerc content
527 __DATA__
528         function local_execute_redirected(stdin, stdout, stderr, path, ...)
529            local pid
530            local ret = -1
531            io.flush();
532            pid = spawn_redirected(stdin, stdout, stderr, path, unpack(arg))
533            if (pid ~= -1) then ret, pid = wait(pid) end
534            return ret
535         end
536         if (not execute_redirected) then -- use standard function if available
537            execute_redirected = local_execute_redirected
538         end
539         if (not mergers.fail) then -- use standard merger if available
540            mergers.fail = {
541               cmd = function (tbl) return false end,
542               available = function () return true end,
543               wanted = function () return true end
544            }
545         end
546         mergers.diffutils_force = {
547            cmd = function (tbl)
548               local ret = execute_redirected(
549                   "",
550                   tbl.outfile,
551                   "",
552                   "diff3",
553                   "--merge",
554                   "--show-overlap",
555                   "--label", string.format("[Yours]",     tbl.left_path ),
556                   "--label", string.format("[Original]",  tbl.anc_path  ),
557                   "--label", string.format("[Theirs]",    tbl.right_path),
558                   tbl.lfile,
559                   tbl.afile,
560                   tbl.rfile
561               )
562               if (ret > 1) then
563                  io.write(gettext("Error running GNU diffutils 3-way difference tool 'diff3'"))
564                  return false
565               end
566               return tbl.outfile
567            end,
568            available =
569               function ()
570                   return program_exists_in_path("diff3");
571               end,
572            wanted =
573               function ()
574                    return true
575               end
576         }