ssoma

   1 #!/usr/bin/perl -w
   2 # Copyright (C) 2013, Eric Wong <normalperson@yhbt.net> and all contributors
   3 # License: AGPLv3 or later (https://www.gnu.org/licenses/agpl-3.0.txt)
   4 # This is the normal command-line client for users
   5 use strict;
   6 use warnings;
   7 use Getopt::Long;
   8 use Ssoma::Git;
   9 use Ssoma::Extractor;
  10 use File::Path::Expand qw/expand_filename/;
  11 use File::Path qw/make_path/;
  12 use File::Temp qw/tempfile/;
  13 use File::Spec qw//;
  14 use Email::LocalDelivery;
  15 Getopt::Long::Configure("require_order", "pass_through");
  16 our %opts;
  17 GetOptions(
  18         "help|h"  => \$opts{help},
  19         "quiet|q" => \$opts{quiet},
  20         "force|f" => \$opts{force},
  21 ) or usage(1);
  22
  23 $ENV{SSOMA_HOME} ||= expand_filename("~/.ssoma/");
  24
  25 # these expand automatically to the associated cmd_$name, so "add"
  26 # calls cmd_add, "sync" calls cmd_sync, and so forth
  27 our %cmd = (
  28         "add" => {
  29                 doc => "start watching a new list",
  30                 arg => "LISTNAME URL TYPE:/path/to/destination [TARGET]",
  31                 long => "TYPE must be one of 'maildir', 'mbox', 'imap' ".
  32                         "or 'command'",
  33         },
  34         "sync" => {
  35                 doc => "sync target(s) for existing LISTNAME",
  36                 arg => "[LISTNAME] [TARGET]",
  37         },
  38         "cat" => {
  39                 doc => "show a message by Message-ID",
  40                 arg => "MESSAGE-ID [LISTNAME|GIT_DIR]",
  41         },
  42 );
  43
  44 my $cmd = shift @ARGV;
  45 usage("", 1) unless defined $cmd;
  46 $cmd eq "help" and usage("", 0);
  47 $cmd{$cmd} or usage("", 1);
  48
  49 my $cmd_sub = eval {
  50         no strict 'refs';
  51         *{"cmd_$cmd"};
  52 } or die "BUG: $cmd not implemented\n";
  53
  54 $cmd_sub->(@ARGV);
  55 exit 0;
  56
  57 sub usage {
  58         my ($cmd, $exit) = @_;
  59         my $fd = $exit ? \*STDERR : \*STDOUT;
  60         print $fd "Usage: ssoma <command> [options] [arguments]\n";
  61
  62         print $fd "Available commands:\n" unless $cmd;
  63
  64         foreach my $c (sort keys %cmd) {
  65                 next if $cmd && $cmd ne $c;
  66                 my $pad = 'A10';
  67                 print $fd '  ', pack($pad, $c), $cmd{$c}->{doc}, "\n";
  68                 print $fd '  ', pack($pad, ''), $cmd{$c}->{arg}, "\n";
  69
  70                 my $long = $cmd{$c}->{long};
  71                 if ($long) {
  72                         print $fd '  ', pack($pad, ''), $long, "\n";
  73                 }
  74
  75                 my $opt = $cmd{$c}->{opt} or next;
  76                 foreach (sort keys %$opt) {
  77                         # prints out arguments as they should be passed:
  78                         my $x = s#[:=]s$## ? '<arg>' :
  79                                 (s#[:=]i$## ? '<num>' : '');
  80                         print $fd ' ' x 21, join(', ', map { length $_ > 1 ?
  81                                                         "--$_" : "-$_" }
  82                                                 split /\|/, $_)," $x\n";
  83                 }
  84         }
  85         exit $exit;
  86 }
  87
  88 sub check_listname {
  89         my ($name) = @_;
  90
  91         $name =~ /\A[a-zA-Z0-9]/ or die
  92                 "LISTNAME must start with an alphanumeric char\n";
  93         $name =~ /[a-zA-Z0-9]\z/ or die
  94                 "LISTNAME must end with an alphanumeric char\n";
  95         $name =~ /\A[\w\.\-]+\z/ or die
  96  "LISTNAME must only contain alphanumerics, dashes, periods and underscores\n";
  97 }
  98
  99 sub cmd_add {
 100         my ($listname, $url, $dest, $target) = @_;
 101         (defined($url) && defined($listname) && defined($dest)) or
 102                 usage("add", 1);
 103
 104         check_listname($listname);
 105
 106         $dest =~ /\A(mbox|maildir|command|imaps?):(.+)\z/ or
 107                 die usage("add", 1);
 108
 109         my ($type, $path) = ($1, $2);
 110         my $imap;
 111
 112         if ($type =~ /\Aimaps?\z/) {
 113                 $imap = 1;
 114         } else {
 115                 $path = File::Spec->rel2abs($path);
 116         }
 117
 118         # Email::LocalDelivery relies on this trailing slash for
 119         # maildir distinction
 120         if (($type eq "maildir") && ($path !~ m!/\z!)) {
 121                 $path .= "/";
 122         } elsif (($type eq "mbox") && ($path =~ m!/\z!)) {
 123                 die "mbox `$path' must not end with a trailing slash\n";
 124         }
 125
 126         $target = "local" unless defined $target;
 127
 128         my $dir = "$ENV{SSOMA_HOME}/$listname.git";
 129         make_path($ENV{SSOMA_HOME});
 130         my $git = Ssoma::Git->new($dir);
 131         my @init_args;
 132         push @init_args, '-q' if $opts{quiet};
 133         $git->init_db(@init_args);
 134         my $state = "$git->{git_dir}/ssoma.state";
 135
 136         if ($imap) {
 137                 local $ENV{GIT_CONFIG} = "$git->{git_dir}/config";
 138                 require URI;
 139
 140                 # no imap:// support in URI, yet, but URI has ftp://
 141                 # for passwords
 142                 my $uri = $dest;
 143                 $uri =~ s{\A(imaps?):}{ftp:};
 144                 my $scheme = $1;
 145                 my $u = URI->new($uri);
 146
 147                 $u->scheme or die "no scheme from $dest\n";
 148                 defined(my $host = $u->host) or die "no host from $dest\n";
 149                 my $port = $u->_port;
 150                 x(qw/git config imap.port/, $port) if (defined $port);
 151                 x(qw/git config imap.host/, "$scheme://$host");
 152
 153                 defined(my $user = $u->user) or die "no user in $dest\n";;
 154                 x(qw/git config imap.user/, $user);
 155                 my $p = $u->password;
 156                 warn_imap_pass($ENV{GIT_CONFIG}) if (defined $p);
 157
 158                 my $path = $u->path;
 159                 defined $path or $path = "INBOX";
 160                 $path =~ s!\A/!!; # no leading slash
 161                 x(qw/git config imap.folder/, $path);
 162
 163                 # this only needs to be set for Extractor to follow
 164                 local $ENV{GIT_CONFIG} = $state;
 165                 x(qw/git config/, "target.$target.imap", "true");
 166         } else {
 167                 local $ENV{GIT_CONFIG} = $state;
 168                 my $cfg = $type eq "command" ? "command" : "path";
 169                 x(qw/git config/, "target.$target.$cfg", $path);
 170         }
 171
 172         $git->tmp_git_do(sub {
 173                 x(qw/git remote add --mirror=fetch origin/, $url);
 174         });
 175 }
 176
 177 sub foreach_list {
 178         my ($sub) = @_;
 179         foreach my $dir (glob("$ENV{SSOMA_HOME}/*.git")) {
 180                 -d $dir or next;
 181                 $sub->($dir);
 182         }
 183 }
 184
 185 sub cmd_sync {
 186         my ($listname, @targets) = @_;
 187         if (defined $listname) {
 188                 check_listname($listname);
 189                 do_sync("$ENV{SSOMA_HOME}/$listname.git", \@targets);
 190         } else {
 191                 foreach_list(sub { do_sync($_[0], []) });
 192         }
 193 }
 194
 195 sub cmd_cat {
 196         my ($message_id, $listname) = @_;
 197
 198         # write to a temporary mbox because Email::LocalDelivery works
 199         # that way.
 200         my ($fh, $mbox) = tempfile(TMPDIR => 1, SUFFIX => '.mbox');
 201
 202         if (defined $listname) {
 203                 my $path = -d $listname ? $listname
 204                                         : "$ENV{SSOMA_HOME}/$listname.git";
 205                 do_cat($path, $message_id, $mbox);
 206         } else {
 207                 foreach_list(sub { do_cat($_[0], $message_id, $mbox, 1) });
 208         }
 209         unlink $mbox or warn "error unlinking $mbox: $!\n";
 210
 211         foreach (<$fh>) {
 212                 print $_ or warn "failed printing to stdout: $!\n";
 213         }
 214         close $fh or die "error closing $mbox: $!\n";
 215 }
 216
 217 sub do_sync {
 218         my ($dir, $targets) = @_;
 219         my $git = Ssoma::Git->new($dir);
 220         my $ex = Ssoma::Extractor->new($git);
 221
 222         # no targets? sync all of them
 223         if (scalar(@$targets) == 0) {
 224                 my $cfg = $git->config_list("$git->{git_dir}/ssoma.state");
 225                 my %t;
 226                 foreach my $k (keys %$cfg) {
 227                         $k =~ /\Atarget\.(\w+)\.(?:path|imap|command)\z/
 228                                                                 or next;
 229                         $t{$1} = 1;
 230                 }
 231                 @$targets = keys %t;
 232         }
 233
 234         $git->tmp_git_do(sub {
 235                 my @cmd = qw/git fetch/;
 236                 push @cmd, '-q' if $opts{quiet};
 237                 push @cmd, '-f' if $opts{force};
 238                 x(@cmd);
 239         });
 240
 241         foreach my $target (@$targets) {
 242                 $ex->extract($target);
 243         }
 244 }
 245
 246 sub x {
 247         system(@_) and die join(' ', @_). " failed: $?\n";
 248 }
 249
 250 sub warn_imap_pass {
 251         my ($file) = @_;
 252         print STDERR <<EOF
 253 ignoring IMAP password given on command-line
 254 ensure $file is not world-readable before editing
 255 $file to set imap.pass
 256 EOF
 257 }
 258
 259 sub do_cat {
 260         my ($dir, $message_id, $mbox, $missing_ok) = @_;
 261         my $git = Ssoma::Git->new($dir);
 262         my $ex = Ssoma::Extractor->new($git);
 263         $ex->midextract($message_id, $mbox, $missing_ok);
 264 }