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