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