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