git.notmuchmail.org Git - notmuch/blob - devel/nmbug/nmbug

   1 #!/usr/bin/env perl
   2 # Copyright (c) 2011 David Bremner
   3 # License: same as notmuch
   4
   5 use strict;
   6 use warnings;
   7 use File::Temp qw(tempdir);
   8 use Pod::Usage;
   9
  10 no encoding;
  11
  12 my $NMBGIT = $ENV{NMBGIT} || $ENV{HOME}.'/.nmbug';
  13
  14 $NMBGIT .= '/.git' if (-d $NMBGIT.'/.git');
  15
  16 my $TAGPREFIX = defined($ENV{NMBPREFIX}) ? $ENV{NMBPREFIX} : 'notmuch::';
  17
  18 # for encoding
  19
  20 my $ESCAPE_CHAR =       '%';
  21 my $NO_ESCAPE =         'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz'.
  22                         '0123456789+-_@=.:,';
  23 my $MUST_ENCODE =       qr{[^\Q$NO_ESCAPE\E]};
  24 my $ESCAPED_RX =        qr{$ESCAPE_CHAR([A-Fa-f0-9]{2})};
  25
  26 my %command = (
  27              archive    => \&do_archive,
  28              checkout   => \&do_checkout,
  29              commit     => \&do_commit,
  30              fetch      => \&do_fetch,
  31              help       => \&do_help,
  32              log        => \&do_log,
  33              merge      => \&do_merge,
  34              pull       => \&do_pull,
  35              push       => \&do_push,
  36              status     => \&do_status,
  37              );
  38
  39 # Convert prefix into form suitable for literal matching against
  40 # notmuch dump --format=batch-tag output.
  41 my $ENCPREFIX = encode_for_fs ($TAGPREFIX);
  42 $ENCPREFIX =~ s/:/%3a/g;
  43
  44 my $subcommand = shift || usage ();
  45
  46 if (!exists $command{$subcommand}) {
  47   usage ();
  48 }
  49
  50 # magic hash for git
  51 my $EMPTYBLOB = git (qw{hash-object -t blob /dev/null});
  52
  53 &{$command{$subcommand}}(@ARGV);
  54
  55 sub git_pipe {
  56   my $envref = (ref $_[0] eq 'HASH') ? shift : {};
  57   my $ioref  = (ref $_[0] eq 'ARRAY') ? shift : undef;
  58   my $dir = ($_[0] eq '-|' or $_[0] eq '|-') ? shift : undef;
  59
  60   unshift @_, 'git';
  61   $envref->{GIT_DIR} ||= $NMBGIT;
  62   spawn ($envref, defined $ioref ? $ioref : (), defined $dir ? $dir : (), @_);
  63 }
  64
  65 sub git {
  66   my $fh = git_pipe (@_);
  67   my $str = join ('', <$fh>);
  68   unless (close $fh) {
  69     die "'git @_' exited with nonzero value\n";
  70   }
  71   chomp($str);
  72   return $str;
  73 }
  74
  75 sub spawn {
  76   my $envref = (ref $_[0] eq 'HASH') ? shift : {};
  77   my $ioref  = (ref $_[0] eq 'ARRAY') ? shift : undef;
  78   my $dir = ($_[0] eq '-|' or $_[0] eq '|-') ? shift : '-|';
  79
  80   die unless @_;
  81
  82   if (open my $child, $dir) {
  83     return $child;
  84   }
  85   # child
  86   while (my ($key, $value) = each %{$envref}) {
  87     $ENV{$key} = $value;
  88   }
  89
  90   if (defined $ioref && $dir eq '-|') {
  91       open my $fh, '|-', @_ or die "open |- @_: $!";
  92       foreach my $line (@{$ioref}) {
  93         print $fh $line, "\n";
  94       }
  95       exit ! close $fh;
  96     } else {
  97       if ($dir ne '|-') {
  98         open STDIN, '<', '/dev/null' or die "reopening stdin: $!"
  99       }
 100       exec @_;
 101       die "exec @_: $!";
 102     }
 103 }
 104
 105
 106 sub get_tags {
 107   my $prefix = shift;
 108   my @tags;
 109
 110   my $fh = spawn ('-|', qw/notmuch search --output=tags/, "*")
 111     or die 'error dumping tags';
 112
 113   while (<$fh>) {
 114     chomp ();
 115     push @tags, $_ if (m/^$prefix/);
 116   }
 117   unless (close $fh) {
 118     die "'notmuch search --output=tags *' exited with nonzero value\n";
 119   }
 120   return @tags;
 121 }
 122
 123
 124 sub do_archive {
 125   system ('git', "--git-dir=$NMBGIT", 'archive', 'HEAD');
 126 }
 127
 128
 129 sub is_committed {
 130   my $status = shift;
 131   return scalar (@{$status->{added}} ) + scalar (@{$status->{deleted}} ) == 0;
 132 }
 133
 134
 135 sub do_commit {
 136   my @args = @_;
 137
 138   my $status = compute_status ();
 139
 140   if ( is_committed ($status) ) {
 141     print "Nothing to commit\n";
 142     return;
 143   }
 144
 145   my $index = read_tree ('HEAD');
 146
 147   update_index ($index, $status);
 148
 149   my $tree = git ( { GIT_INDEX_FILE => $index }, 'write-tree')
 150     or die 'no output from write-tree';
 151
 152   my $parent = git ( 'rev-parse', 'HEAD'  )
 153     or die 'no output from rev-parse';
 154
 155   my $commit = git ([ @args ], 'commit-tree', $tree, '-p', $parent)
 156     or die 'commit-tree';
 157
 158   git ('update-ref', 'HEAD', $commit);
 159
 160   unlink $index || die "unlink: $!";
 161
 162 }
 163
 164 sub read_tree {
 165   my $treeish = shift;
 166   my $index = $NMBGIT.'/nmbug.index';
 167   git ({ GIT_INDEX_FILE => $index }, 'read-tree', '--empty');
 168   git ({ GIT_INDEX_FILE => $index }, 'read-tree', $treeish);
 169   return $index;
 170 }
 171
 172 sub update_index {
 173   my $index = shift;
 174   my $status = shift;
 175
 176   my $git = spawn ({ GIT_DIR => $NMBGIT, GIT_INDEX_FILE => $index },
 177                      '|-', qw/git update-index --index-info/)
 178     or die 'git update-index';
 179
 180   foreach my $pair (@{$status->{deleted}}) {
 181     index_tags_for_msg ($git, $pair->{id}, 'D', $pair->{tag});
 182   }
 183
 184   foreach my $pair (@{$status->{added}}) {
 185     index_tags_for_msg ($git, $pair->{id}, 'A', $pair->{tag});
 186   }
 187   unless (close $git) {
 188     die "'git update-index --index-info' exited with nonzero value\n";
 189   }
 190
 191 }
 192
 193
 194 sub do_fetch {
 195   my $remote = shift || 'origin';
 196
 197   git ('fetch', $remote);
 198 }
 199
 200
 201 sub notmuch {
 202   my @args = @_;
 203   system ('notmuch', @args) == 0 or die  "notmuch @args failed: $?";
 204 }
 205
 206
 207 sub index_tags {
 208
 209   my $index = $NMBGIT.'/nmbug.index';
 210
 211   my $query = join ' ', map ("tag:\"$_\"", get_tags ($TAGPREFIX));
 212
 213   my $fh = spawn ('-|', qw/notmuch dump --format=batch-tag --/, $query)
 214     or die "notmuch dump: $!";
 215
 216   git ('read-tree', '--empty');
 217   my $git = spawn ({ GIT_DIR => $NMBGIT, GIT_INDEX_FILE => $index },
 218                      '|-', qw/git update-index --index-info/)
 219     or die 'git update-index';
 220
 221   while (<$fh>) {
 222
 223     chomp();
 224     my ($rest,$id) = split(/ -- id:/);
 225
 226     if ($id =~ s/^"(.*)"\s*$/$1/) {
 227       # xapian quoted string, dequote.
 228       $id =~ s/""/"/g;
 229     }
 230
 231     #strip prefixes from tags before writing
 232     my @tags = grep { s/^[+]$ENCPREFIX//; } split (' ', $rest);
 233     index_tags_for_msg ($git,$id, 'A', @tags);
 234   }
 235   unless (close $git) {
 236     die "'git update-index --index-info' exited with nonzero value\n";
 237   }
 238   unless (close $fh) {
 239     die "'notmuch dump --format=batch-tag -- $query' exited with nonzero value\n";
 240   }
 241   return $index;
 242 }
 243
 244 # update the git index to either create or delete an empty file.
 245 # Neither argument should be encoded/escaped.
 246 sub index_tags_for_msg {
 247   my $fh = shift;
 248   my $msgid = shift;
 249   my $mode = shift;
 250
 251   my $hash = $EMPTYBLOB;
 252   my $blobmode = '100644';
 253
 254   if ($mode eq 'D') {
 255     $blobmode = '0';
 256     $hash = '0000000000000000000000000000000000000000';
 257   }
 258
 259   foreach my $tag (@_) {
 260     my $tagpath = 'tags/' . encode_for_fs ($msgid) . '/' . encode_for_fs ($tag);
 261     print $fh "$blobmode $hash\t$tagpath\n";
 262   }
 263 }
 264
 265
 266 sub do_checkout {
 267   do_sync (action => 'checkout');
 268 }
 269
 270 sub quote_for_xapian {
 271   my $str = shift;
 272   $str =~ s/"/""/g;
 273   return '"' . $str . '"';
 274 }
 275
 276 sub pair_to_batch_line {
 277   my ($action, $pair) = @_;
 278
 279   # the tag should already be suitably encoded
 280
 281   return $action . $ENCPREFIX . $pair->{tag} .
 282     ' -- id:' . quote_for_xapian ($pair->{id})."\n";
 283 }
 284
 285 sub do_sync {
 286
 287   my %args = @_;
 288
 289   my $status = compute_status ();
 290   my ($A_action, $D_action);
 291
 292   if ($args{action} eq 'checkout') {
 293     $A_action = '-';
 294     $D_action = '+';
 295   } else {
 296     $A_action = '+';
 297     $D_action = '-';
 298   }
 299
 300   my $notmuch = spawn ({}, '|-', qw/notmuch tag --batch/)
 301     or die 'notmuch tag --batch';
 302
 303   foreach my $pair (@{$status->{added}}) {
 304     print $notmuch pair_to_batch_line ($A_action, $pair);
 305   }
 306
 307   foreach my $pair (@{$status->{deleted}}) {
 308     print $notmuch pair_to_batch_line ($D_action, $pair);
 309   }
 310
 311   unless (close $notmuch) {
 312     die "'notmuch tag --batch' exited with nonzero value\n";
 313   }
 314 }
 315
 316
 317 sub insist_committed {
 318
 319   my $status=compute_status();
 320   if ( !is_committed ($status) ) {
 321     print "Uncommitted changes to $TAGPREFIX* tags in notmuch
 322
 323 For a summary of changes, run 'nmbug status'
 324 To save your changes,     run 'nmbug commit' before merging/pull
 325 To discard your changes,  run 'nmbug checkout'
 326 ";
 327     exit (1);
 328   }
 329
 330 }
 331
 332
 333 sub do_pull {
 334   my $remote = shift || 'origin';
 335
 336   git ( 'fetch', $remote);
 337
 338   do_merge ();
 339 }
 340
 341
 342 sub do_merge {
 343   insist_committed ();
 344
 345   my $tempwork = tempdir ('/tmp/nmbug-merge.XXXXXX', CLEANUP => 1);
 346
 347   git ( { GIT_WORK_TREE => $tempwork }, 'checkout', '-f', 'HEAD');
 348
 349   git ( { GIT_WORK_TREE => $tempwork }, 'merge', 'FETCH_HEAD');
 350
 351   do_checkout ();
 352 }
 353
 354
 355 sub do_log {
 356   # we don't want output trapping here, because we want the pager.
 357   system ( 'git', "--git-dir=$NMBGIT", 'log', '--name-status', @_);
 358 }
 359
 360
 361 sub do_push {
 362   my $remote = shift || 'origin';
 363
 364   git ('push', $remote, 'master');
 365 }
 366
 367
 368 sub do_status {
 369   my $status = compute_status ();
 370
 371   my %output = ();
 372   foreach my $pair (@{$status->{added}}) {
 373     $output{$pair->{id}} ||= {};
 374     $output{$pair->{id}}{$pair->{tag}} = 'A'
 375   }
 376
 377   foreach my $pair (@{$status->{deleted}}) {
 378     $output{$pair->{id}} ||= {};
 379     $output{$pair->{id}}{$pair->{tag}} = 'D'
 380   }
 381
 382   foreach my $pair (@{$status->{missing}}) {
 383     $output{$pair->{id}} ||= {};
 384     $output{$pair->{id}}{$pair->{tag}} = 'U'
 385   }
 386
 387   if (is_unmerged ()) {
 388     foreach my $pair (diff_refs ('A')) {
 389       $output{$pair->{id}} ||= {};
 390       $output{$pair->{id}}{$pair->{tag}} ||= ' ';
 391       $output{$pair->{id}}{$pair->{tag}} .= 'a';
 392     }
 393
 394     foreach my $pair (diff_refs ('D')) {
 395       $output{$pair->{id}} ||= {};
 396       $output{$pair->{id}}{$pair->{tag}} ||= ' ';
 397       $output{$pair->{id}}{$pair->{tag}} .= 'd';
 398     }
 399   }
 400
 401   foreach my $id (sort keys %output) {
 402     foreach my $tag (sort keys %{$output{$id}}) {
 403       printf "%s\t%s\t%s\n", $output{$id}{$tag}, $id, $tag;
 404     }
 405   }
 406 }
 407
 408
 409 sub is_unmerged {
 410
 411   return 0 if (! -f $NMBGIT.'/FETCH_HEAD');
 412
 413   my $fetch_head = git ('rev-parse', 'FETCH_HEAD');
 414   my $base = git ( 'merge-base', 'HEAD', 'FETCH_HEAD');
 415
 416   return ($base ne $fetch_head);
 417
 418 }
 419
 420 sub compute_status {
 421   my %args = @_;
 422
 423   my @added;
 424   my @deleted;
 425   my @missing;
 426
 427   my $index = index_tags ();
 428
 429   my @maybe_deleted = diff_index ($index, 'D');
 430
 431   foreach my $pair (@maybe_deleted) {
 432
 433     my $id = $pair->{id};
 434
 435     my $fh = spawn ('-|', qw/notmuch search --output=files/,"id:$id")
 436       or die "searching for $id";
 437     if (!<$fh>) {
 438       push @missing, $pair;
 439     } else {
 440       push @deleted, $pair;
 441     }
 442     unless (close $fh) {
 443       die "'notmuch search --output=files id:$id' exited with nonzero value\n";
 444     }
 445   }
 446
 447
 448   @added = diff_index ($index, 'A');
 449
 450   unlink $index || die "unlink $index: $!";
 451
 452   return { added => [@added], deleted => [@deleted], missing => [@missing] };
 453 }
 454
 455
 456 sub diff_index {
 457   my $index = shift;
 458   my $filter = shift;
 459
 460   my $fh = git_pipe ({ GIT_INDEX_FILE => $index },
 461                   qw/diff-index --cached/,
 462                  "--diff-filter=$filter", qw/--name-only HEAD/ );
 463
 464   my @lines = unpack_diff_lines ($fh);
 465   unless (close $fh) {
 466     die "'git diff-index --cached --diff-filter=$filter --name-only HEAD' ",
 467         "exited with nonzero value\n";
 468   }
 469   return @lines;
 470 }
 471
 472
 473 sub diff_refs {
 474   my $filter = shift;
 475   my $ref1 = shift || 'HEAD';
 476   my $ref2 = shift || 'FETCH_HEAD';
 477
 478   my $fh= git_pipe ( 'diff', "--diff-filter=$filter", '--name-only',
 479                  $ref1, $ref2);
 480
 481   my @lines = unpack_diff_lines ($fh);
 482   unless (close $fh) {
 483     die "'git diff --diff-filter=$filter --name-only $ref1 $ref2' ",
 484         "exited with nonzero value\n";
 485   }
 486   return @lines;
 487 }
 488
 489
 490 sub unpack_diff_lines {
 491   my $fh = shift;
 492
 493   my @found;
 494   while(<$fh>) {
 495     chomp ();
 496     my ($id,$tag) = m|tags/ ([^/]+) / ([^/]+) |x;
 497
 498     $id = decode_from_fs ($id);
 499     $tag = decode_from_fs ($tag);
 500
 501     push @found, { id => $id, tag => $tag };
 502   }
 503
 504   return @found;
 505 }
 506
 507
 508 sub encode_for_fs {
 509   my $str = shift;
 510
 511   $str =~ s/($MUST_ENCODE)/"$ESCAPE_CHAR".sprintf ("%02x",ord ($1))/ge;
 512   return $str;
 513 }
 514
 515
 516 sub decode_from_fs {
 517   my $str = shift;
 518
 519   $str =~ s/$ESCAPED_RX/ chr (hex ($1))/eg;
 520
 521   return $str;
 522
 523 }
 524
 525
 526 sub usage {
 527   pod2usage ();
 528   exit (1);
 529 }
 530
 531
 532 sub do_help {
 533   pod2usage ( -verbose => 2 );
 534   exit (0);
 535 }
 536
 537 __END__
 538
 539 =head1 NAME
 540
 541 nmbug - manage notmuch tags about notmuch
 542
 543 =head1 SYNOPSIS
 544
 545 nmbug subcommand [options]
 546
 547 B<nmbug help> for more help
 548
 549 =head1 OPTIONS
 550
 551 =head2 Most common commands
 552
 553 =over 8
 554
 555 =item B<commit> [message]
 556
 557 Commit appropriately prefixed tags from the notmuch database to
 558 git. Any extra arguments are used (one per line) as a commit message.
 559
 560 =item  B<push> [remote]
 561
 562 push local nmbug git state to remote repo
 563
 564 =item  B<pull> [remote]
 565
 566 pull (merge) remote repo changes to notmuch. B<pull> is equivalent to
 567 B<fetch> followed by B<merge>.
 568
 569 =back
 570
 571 =head2 Other Useful Commands
 572
 573 =over 8
 574
 575 =item B<checkout>
 576
 577 Update the notmuch database from git. This is mainly useful to discard
 578 your changes in notmuch relative to git.
 579
 580 =item B<fetch> [remote]
 581
 582 Fetch changes from the remote repo (see merge to bring those changes
 583 into notmuch).
 584
 585 =item B<help> [subcommand]
 586
 587 print help [for subcommand]
 588
 589 =item B<log> [parameters]
 590
 591 A simple wrapper for git log. After running C<nmbug fetch>, you can
 592 inspect the changes with C<nmbug log HEAD..FETCH_HEAD>
 593
 594 =item B<merge>
 595
 596 Merge changes from FETCH_HEAD into HEAD, and load the result into
 597 notmuch.
 598
 599 =item  B<status>
 600
 601 Show pending updates in notmuch or git repo. See below for more
 602 information about the output format.
 603
 604 =back
 605
 606 =head2 Less common commands
 607
 608 =over 8
 609
 610 =item B<archive>
 611
 612 Dump a tar archive (using git archive) of the current nmbug tag set.
 613
 614 =back
 615
 616 =head1 STATUS FORMAT
 617
 618 B<nmbug status> prints lines of the form
 619
 620    ng Message-Id tag
 621
 622 where n is a single character representing notmuch database status
 623
 624 =over 8
 625
 626 =item B<A>
 627
 628 Tag is present in notmuch database, but not committed to nmbug
 629 (equivalently, tag has been deleted in nmbug repo, e.g. by a pull, but
 630 not restored to notmuch database).
 631
 632 =item B<D>
 633
 634 Tag is present in nmbug repo, but not restored to notmuch database
 635 (equivalently, tag has been deleted in notmuch)
 636
 637 =item B<U>
 638
 639 Message is unknown (missing from local notmuch database)
 640
 641 =back
 642
 643 The second character (if present) represents a difference between remote
 644 git and local. Typically C<nmbug fetch> needs to be run to update this.
 645
 646 =over 8
 647
 648
 649 =item B<a>
 650
 651 Tag is present in remote, but not in local git.
 652
 653
 654 =item B<d>
 655
 656 Tag is present in local git, but not in remote git.
 657
 658
 659 =back
 660
 661 =head1 DUMP FORMAT
 662
 663 Each tag $tag for message with Message-Id $id is written to
 664 an empty file
 665
 666         tags/encode($id)/encode($tag)
 667
 668 The encoding preserves alphanumerics, and the characters "+-_@=.:,"
 669 (not the quotes).  All other octets are replaced with '%' followed by
 670 a two digit hex number.
 671
 672 =head1 ENVIRONMENT
 673
 674 B<NMBGIT> specifies the location of the git repository used by nmbug.
 675 If not specified $HOME/.nmbug is used.
 676
 677 B<NMBPREFIX> specifies the prefix in the notmuch database for tags of
 678 interest to nmbug. If not specified 'notmuch::' is used.