From: W. Trevor King Date: Sat, 18 Oct 2014 22:05:55 +0000 (-0700) Subject: Remove everything not needed for ssoma-mda X-Git-Url: http://git.tremily.us/?a=commitdiff_plain;h=1f4c2fc225a836eace950d146d1c2298fd5c9929;p=ssoma-mda.git Remove everything not needed for ssoma-mda In preparation for the Python translation. --- diff --git a/Documentation/include.mk b/Documentation/include.mk deleted file mode 100644 index f9191ae..0000000 --- a/Documentation/include.mk +++ /dev/null @@ -1,70 +0,0 @@ -# Copyright (C) 2013, Eric Wong and all contributors -# License: AGPLv3 or later (https://www.gnu.org/licenses/agpl-3.0.txt) -all:: - -RSYNC = rsync -RSYNC_DEST = ssoma.public-inbox.org:/srv/ssoma/ -docs := README COPYING INSTALL $(shell git ls-files 'Documentation/*.txt') -INSTALL = install -PANDOC = pandoc -PANDOC_OPTS = -f markdown --email-obfuscation=none -pandoc = $(PANDOC) $(PANDOC_OPTS) - -m1 = -m1 += ssoma -m1 += ssoma-mda -m1 += ssoma-rm - -m5 = -m5 += ssoma_repository - -m7 = - -man1 := $(addsuffix .1, $(m1)) -man5 := $(addsuffix .5, $(m5)) -man7 := $(addsuffix .7, $(m7)) - -all:: man html - -man: $(man1) $(man5) $(man7) - -prefix ?= $(HOME) -mandir ?= $(prefix)/share/man -man1dir = $(mandir)/man1 -man5dir = $(mandir)/man5 -man7dir = $(mandir)/man7 - -install-man: man - test -z "$(man1)" || $(INSTALL) -d -m 755 $(DESTDIR)$(man1dir) - test -z "$(man5)" || $(INSTALL) -d -m 755 $(DESTDIR)$(man5dir) - test -z "$(man7)" || $(INSTALL) -d -m 755 $(DESTDIR)$(man7dir) - test -z "$(man1)" || $(INSTALL) -m 644 $(man1) $(DESTDIR)$(man1dir) - test -z "$(man5)" || $(INSTALL) -m 644 $(man5) $(DESTDIR)$(man5dir) - test -z "$(man7)" || $(INSTALL) -m 644 $(man7) $(DESTDIR)$(man7dir) -%.1 %.5 %.7 : Documentation/%.txt - $(pandoc) -s -t man < $< > $@+ && mv $@+ $@ - -txt2pre = ./Documentation/txt2pre < $< > $@+ && touch -r $< $@+ && mv $@+ $@ -txt = INSTALL README COPYING - -INSTALL.html: INSTALL - $(txt2pre) -index.html: README - $(txt2pre) - -docs_html := INSTALL.html -html: $(docs_html) -gz_docs := $(addsuffix .gz, $(docs) $(docs_html)) -rsync_docs := $(gz_docs) $(docs) $(txt) $(docs_html) -%.gz: % - gzip -9 --rsyncable < $< > $@+ - touch -r $< $@+ - mv $@+ $@ - -gz-doc: $(gz_docs) -rsync-doc: - git set-file-times $(docs) $(txt) - $(MAKE) gz-doc - $(RSYNC) --chmod=Fugo=r -av $(rsync_docs) $(RSYNC_DEST) -clean-doc: - $(RM) $(man1) $(man5) $(man7) $(gz_docs) $(docs_html) diff --git a/Documentation/ssoma-rm.txt b/Documentation/ssoma-rm.txt deleted file mode 100644 index 0e3aa2b..0000000 --- a/Documentation/ssoma-rm.txt +++ /dev/null @@ -1,33 +0,0 @@ -% ssoma-rm(1) ssoma user manual - -# NAME - -ssoma-rm - remove messages from a ssoma repository - -# SYNOPSIS - -ssoma-rm /path/to/ssoma/repository.git < message - -# DESCRIPTION - -ssoma-rm removes messages from a ssoma repository. It only deletes -messages which match the Message-ID, Subject, and body of the email. -Thus the output of "ssoma cat" is ideal for ssoma-rm. ssoma-rm only -works on the latest HEAD (refs/heads/master) of the ssoma repository. -It does not remove the message from history, but prevents future users -of "ssoma sync" from seeing the message in their mailbox. - -# CONTACT - -All feedback welcome via plain-text mail to \ -The mail archives are hosted at git://public-inbox.org/meta -See ssoma(1) for instructions on how to subscribe. - -# COPYRIGHT - -Copyright 2013, Eric Wong and all contributors.\ -License: AGPLv3 or later - -# SEE ALSO - -git(1), ssoma(1), ssoma_repository(5) diff --git a/Documentation/ssoma.txt b/Documentation/ssoma.txt deleted file mode 100644 index f05e230..0000000 --- a/Documentation/ssoma.txt +++ /dev/null @@ -1,98 +0,0 @@ -% ssoma(1) ssoma user manual - -# NAME - -ssoma - mail archive synchronization and extraction client - -# SYNOPSIS - -ssoma add LISTNAME URL maildir:/path/to/maildir/ [TARGET] - -ssoma add LISTNAME URL mbox:/path/to/mbox - -ssoma add LISTNAME URL imap://USER@HOST/INBOX - -ssoma sync [--since=DATE] [LISTNAME] - -ssoma cat MESSAGE-ID [LISTNAME|GIT_DIR] - -# DESCRIPTION - -ssoma may be used to sync and export mail to Maildir, IMAP or mbox(5) -from any published ssoma git repository. - -* add LISTNAME URL DESTINATION [TARGET] - -This starts a subscription to a mailing list by configuring a git -repository. LISTNAME is a name of your choosing. It must only consist -of alphanumeric characters, underscores, periods and dashes, and must start -and end with an alphanumeric character. URL is the URL to a git repository, -this supports all URLs git(7) supports. DESTINATION is the local -destination to extract mail to. This may be a maildir:, mbox: path, -or an imap:// or imaps:// URL. -. -The repository is stored in ~/.ssoma/$LISTNAME.git If at any time -a user wishes to stop following the list, just remove the git repository -from your file system. -. -IMAP users may configure the imap.pass and imap.tunnel variables in -~/.ssoma/$LISTNAME.git/config in the same way as git-imap-send(1). -Remember to restrict permissions to ~/.ssoma/$LISTNAME.git/config -if you are storing a password in it. -. -TARGET may optionally be specified if you wish to extract a list -to multiple destinations (e.g. an mbox for certain tools, but also -to your IMAP account). The default TARGET name is "local". - -* sync [--since=DATE] [LISTNAME] [TARGET] - -This clones/fetches from the remote git repository into the local -repository and extracts messages into destinations configured with the -"add" sub-command. If LISTNAME is not given, all list subscriptions are -synchronized. If LISTNAME is given, only subscriptions for a given LISTNAME -is synchronized. If TARGET is also given, the only the specified TARGET -is synchronized. -. -If you are following a list with a long history, you may only want to -extract recent messages by specifying --since=DATE and passing any DATE -format understood by git-log(1). - -* cat MESSAGE-ID [LISTNAME|GIT_DIR] - -This outputs the message matching MESSAGE-ID to stdout (in mbox format). -If LISTNAME is given, this limits the Message-ID search to that list. -. -Specifying a GIT_DIR in place of LISTNAME is also possible, this is -intended for administrators using ssoma-rm(1). - -# FILES - -All client-side git repositories are stored in ~/.ssoma/$LISTNAME.git/ -See ssoma_repository(5) for details. - -# ENVIRONMENT VARIABLES - -SSOMA_HOME may be used to override the default ~/.ssoma/ directory. -This is useful for testing, but not recommended otherwise. - -# CONTACT - -All feedback welcome via plain-text mail to \ -The mail archives are hosted at git://public-inbox.org/meta -You may subscribe using ssoma: - - ssoma add pi git://public-inbox.org/meta mbox:/path/to/mbox - ssoma sync pi - -# SOURCE CODE - - git clone git://80x24.org/ssoma - -# COPYRIGHT - -Copyright 2013, Eric Wong and all contributors.\ -License: AGPLv3 or later - -# SEE ALSO - -git(1), ssoma_repository(5), ssoma-rm(1) diff --git a/Documentation/txt2pre b/Documentation/txt2pre deleted file mode 100755 index f84f9c0..0000000 --- a/Documentation/txt2pre +++ /dev/null @@ -1,26 +0,0 @@ -#!/usr/bin/env perl -# Copyright (C) 2014, Eric Wong and all contributors -# License: AGPLv3 or later (https://www.gnu.org/licenses/agpl-3.0.txt) -# -# Stupid script to make HTML from preformatted, utf-8 text versions, -# only generating links for http(s). Markdown does too much -# and requires indentation to output preformatted text. -use strict; -use warnings; -use CGI qw/escapeHTML/; -use Encode qw/encode/; -my $str = eval { local $/; <> }; -$str = escapeHTML($str); -$str = encode('us-ascii', $str, Encode::HTMLCREF); -my ($title) = ($str =~ /\A([^\n]+)/); - -# temporarily swap > for escape so our s!! to add href works. -# there's probably a way to do this with only a single s!! ... -$str =~ s!>!\e!g; -$str =~ s!\b(https?://[\w+\+\&\?\.\%\;/-]+)!$1!g; -$str =~ s!\e!>!g; # swap escapes back to > - -print '', - '', - "$title", - "\n
",  $str , '
'; diff --git a/Makefile.PL b/Makefile.PL deleted file mode 100644 index 1055eb3..0000000 --- a/Makefile.PL +++ /dev/null @@ -1,33 +0,0 @@ -#!/usr/bin/perl -# Copyright (C) 2013, Eric Wong and all contributors -# License: AGPLv3 or later (https://www.gnu.org/licenses/agpl-3.0.txt) -# -# Note: this may be rewritten in another language in the future, -# so don't depend on any public Perl API -use strict; -use ExtUtils::MakeMaker; -WriteMakefile( - NAME => 'ssoma', - VERSION => '0.1.0', - AUTHOR => 'Eric Wong ', - ABSTRACT => 'some sort of mail archiver', - EXE_FILES => [qw/ssoma-mda ssoma ssoma-rm/], - PREREQ_PM => { - # Keep this sorted and synced to the INSTALL document - 'Digest::SHA' => 0, - 'Email::LocalDelivery' => 0, - 'Email::Simple' => 0, - 'File::Path::Expand' => 0, - 'Net::IMAP::Simple' => 0, - }, -); - -sub MY::postamble { - <<'EOF'; --include Documentation/include.mk -N = $(shell echo $$(( $$(nproc 2>/dev/null || echo 2) + 1))) -check:: pure_all - prove -lv -j$(N) - -EOF -} diff --git a/lib/Ssoma/Extractor.pm b/lib/Ssoma/Extractor.pm deleted file mode 100644 index 9d7bcce..0000000 --- a/lib/Ssoma/Extractor.pm +++ /dev/null @@ -1,191 +0,0 @@ -# Copyright (C) 2013, Eric Wong and all contributors -# License: AGPLv3 or later (https://www.gnu.org/licenses/agpl-3.0.txt) -# -# Extracts mail to an Mbox or Maildir -package Ssoma::Extractor; -use strict; -use warnings; -use Ssoma::Git; -use Email::LocalDelivery; - -sub new { - my ($class, $git) = @_; - bless { git => $git, ref => "refs/heads/master" }, $class; -} - -# runs a command which returns a list of files belonging to emails -# This won't prevent invalid/corrupt messages from attempts at -# being imported, though. This allows administrators to add things -# like a top-level README file to avoid confusing folks who may -# accidentally check out the ssoma repository as a working copy. -sub _flist { - my ($cmd) = @_; - my @rv = `$cmd`; - $? == 0 or die "$cmd failed: $?\n"; - chomp @rv; - @rv = grep(m!\A[a-f0-9]{2}/[a-f0-9]{38}(?:/[a-f0-9]{40})?\z!, @rv); - \@rv -} - -sub _extract { - my ($self, $target, $since) = @_; - my $git = $self->{git}; - - # read all of the state file - my $state = "$git->{git_dir}/ssoma.state"; - my $cfg = $git->config_list($state); - - my $pkey = "target.$target.path"; - my $path = $cfg->{$pkey}; - - my $ckey = "target.$target.command"; - my $command = $cfg->{$ckey}; - - my $ikey = "target.$target.imap"; - my $imap = $cfg->{$ikey}; - - my $lkey = "target.$target.last-imported"; - my $last = $cfg->{$lkey}; - - my $ref = $self->{ref}; - my $tip = $git->qx_sha1("git rev-parse $ref^0"); - - my $new; # arrayref of new file pathnames in a git tree - - if (defined $since) { - my @cmd = (qw(git rev-list), "--since=$since", $tip); - my $tmp; - - # get the commit last in the list, unfortunately --reverse - # is not usable with --since - open my $rl, '-|', @cmd or die "failed to open rev-list: $!\n"; - foreach my $cmt (<$rl>) { - chomp $cmt; - - # do not re-import even if --since is specified - if (defined $last && ($last eq $cmt)) { - $tmp = undef; - last - } - $tmp = $cmt; - } - close $rl; # we may break the pipe here - $last = $tmp if defined $tmp; - } - if (defined $last) { - # only inject newly-added - $last =~ /\A[a-f0-9]{40}\z/ or die "$lkey invalid in $state\n"; - - # we don't want blob->tree conflict resolution in MDA - # tricking us into extracting the same message twice; - # MDA will keep the original in sufficiently-identical messages - my $cmd = "git diff-tree -r --name-only -M100% --diff-filter=A"; - $new = _flist("$cmd $last $tip"); - } else { - # new maildir or mbox (to us), import everything in the - # current tree - $new = _flist("git ls-tree -r --name-only $tip"); - } - - my $i = 0; - $i++ if defined $command; - $i++ if defined $path; - $i++ if defined $imap; - ($i > 1) and die - "only one of $pkey, $ckey, or $ikey may be defined in $state\n"; - - if (defined $command) { - $self->_run_for_each_msg($command, $tip, $new) - } elsif (defined $path) { - $self->_deliver_each_msg($path, $tip, $new); - } elsif (defined $imap) { - $self->_imap_deliver_each_msg($tip, $new); - } else { - die "neither $pkey, $ckey, nor $ikey are defined in $state\n"; - } - - # update the last-imported var - { - local $ENV{GIT_CONFIG} = $state; - my $rv = system(qw/git config/, $lkey, $tip); - $rv == 0 or die "git config $lkey $tip failed: $? ($rv)\n"; - } -} - -# deliver to mbox or maildir, Email::LocalDelivery determines the type of -# folder (via Email::FolderType) via trailing trailing slash for maildir -# (and lack of trailing slash for mbox). Ezmlm and MH formats are not -# currently supported by Email::LocalDelivery. -sub _deliver_each_msg { - my ($self, $dest, $tip, $new) = @_; - my $git = $self->{git}; - my $git_pm = $git->try_git_pm; - foreach my $path (@$new) { - _deliver_die($git->cat_blob("$tip:$path", $git_pm), $dest); - } -} - -# just pipe the blob message to $command, bypassing Perl, -# so there's no validation at all -sub _run_for_each_msg { - my ($self, $command, $tip, $new) = @_; - my $git = $self->{git}; - foreach my $path (@$new) { - my $cmd = "git cat-file blob $tip:$path | $command"; - my $rv = system($cmd); - $rv == 0 or die "delivery command: $cmd failed: $? ($rv)\n"; - } -} - -sub _imap_deliver_each_msg { - my ($self, $tip, $new) = @_; - my $git = $self->{git}; - require Ssoma::IMAP; - my $imap = Ssoma::IMAP->new($git); - my $git_pm = $git->try_git_pm; - foreach my $path (@$new) { - $imap->imap_deliver($git->cat_blob("$tip:$path", $git_pm)); - } - $imap->quit; -} - -sub extract { - my ($self, $target, $since) = @_; - $self->{git}->tmp_git_do(sub { $self->_extract($target, $since) }); -} - -sub _deliver_die { - my @rv = Email::LocalDelivery->deliver(@_); - (scalar @rv == 1 && -f $rv[0]) or - die "delivery to $_[1] failed: $!\n"; -} - -# implements "ssoma cat MESSAGE-ID" -sub midextract { - my ($self, $message_id, $mbox) = @_; - $self->{git}->tmp_git_do(sub { - $self->_midextract($message_id, $mbox); - }); -} - -sub _midextract { - my ($self, $message_id, $mbox) = @_; - my $git = $self->{git}; - my $path = $git->mid2path($message_id); - my $ref = $self->{ref}; - my $tip = $git->qx_sha1("git rev-parse $ref^0"); - my $obj = "$tip:$path"; - my $type = $git->type($obj); - if ($type eq "tree") { # unlikely - $git->each_in_tree($obj, sub { - my ($blob_id, $xpath) = ($1, $2); - _deliver_die($git->cat_blob($blob_id), $mbox); - }); - } elsif ($type eq "blob") { - _deliver_die($git->cat_blob($obj), $mbox); - } else { - die "unhandled type: $type (obj=$obj)\n"; - } -} - -1; diff --git a/lib/Ssoma/IMAP.pm b/lib/Ssoma/IMAP.pm deleted file mode 100644 index a32a288..0000000 --- a/lib/Ssoma/IMAP.pm +++ /dev/null @@ -1,112 +0,0 @@ -# Copyright (C) 2013, Eric Wong and all contributors -# License: AGPLv3 or later (https://www.gnu.org/licenses/agpl-3.0.txt) -# -# IMAP delivery module, used by Ssoma::Extractor if Email::LocalDelivery -# is not available. Since we are dependent on git, we use the same config -# settings as those used by git-imap-send(1) -package Ssoma::IMAP; -use strict; -use warnings; -use Ssoma::Git; -use Net::IMAP::Simple; - -sub new { - my ($class, $git) = @_; - my $file = "$git->{git_dir}/config"; - my $cfg = $git->config_list($file); - my %opts = (); - my $self = bless { opts => \%opts }, $class; - foreach my $k (qw/folder host user pass port tunnel/) { - $self->{$k} = $cfg->{"imap.$k"}; - } - - check_unsupported($git, $cfg); - - my $imap; - if ((my $host = $self->{host})) { - $host =~ s!imap://!!; - $host =~ s!imaps://!! and $opts{use_ssl} = 1; - my $port = $self->{port}; - $host .= ":$port" if defined $port; - $self->get_pass($host); - $imap = Net::IMAP::Simple->new($host, %opts) or conn_fail(); - $imap->login($self->{user}, $self->{pass}) or - die "Login failed: " . $imap->errstr . "\n"; - } elsif ((my $tunnel = $self->{tunnel})) { - # XXX not tested - $host = "cmd:$tunnel"; - $imap = Net::IMAP::Simple->new($host, %opts) or conn_fail(); - } else { - die "neither imap.host nor imap.tunnel set in $file\n"; - } - $self->{imap} = $imap; - $self; -} - -sub imap_deliver { - my ($self, $msg) = @_; - $self->{imap}->put($self->{folder}, $msg); -} - -sub check_unsupported { - my ($git, $cfg) = @_; - - if ((my $sslverify = $cfg->{"imap.sslverify"})) { - local $ENV{GIT_CONFIG} = "$git->{git_dir}/config"; - $sslverify = `git config --bool imap.sslverify`; - chomp $sslverify; - if ($sslverify eq "false") { - die "imap.sslverify=false not supported\n"; - } - } - - if (defined $cfg->{"imap.authmethod"}) { - die "imap.authMethod not supported by Net::IMAP::Simple\n"; - } -} - -sub get_pass { - my ($self, $host) = @_; - - return if defined $self->{pass}; - my $pass = ""; - - print STDERR "$self->{user}\@$host password:"; - STDERR->flush; - my $readkey; - eval { - require Term::ReadKey; - Term::ReadKey::ReadMode('noecho'); - }; - if ($@) { - my $cmd = 'stty -echo'; - print STDERR "Term::ReadKey not available, using `$cmd'\n"; - system($cmd) and die "$cmd failed: $?\n"; - $pass = ; - $cmd = 'stty echo'; - system($cmd) and die "$cmd failed: $?\n"; - chomp $pass; - } else { - # read the password - while (defined(my $key = Term::ReadKey::ReadKey(0))) { - last if $key =~ /[\012\015]/; # [\r\n] - $pass .= $key; - } - Term::ReadKey::ReadMode('restore'); - } - print STDERR "\n"; - STDERR->flush; - - $self->{pass} = $pass; -} - -sub conn_fail { - die "Unable to connect to IMAP: $Net::IMAP::Simple::errstr\n"; -} - -sub quit { - my ($self) = @_; - $self->{imap}->quit; -} - -1; diff --git a/lib/Ssoma/Remover.pm b/lib/Ssoma/Remover.pm deleted file mode 100644 index 5e5872c..0000000 --- a/lib/Ssoma/Remover.pm +++ /dev/null @@ -1,70 +0,0 @@ -# Copyright (C) 2013, Eric Wong and all contributors -# License: AGPLv3 or later (https://www.gnu.org/licenses/agpl-3.0.txt) -package Ssoma::Remover; -use strict; -use warnings; -use Ssoma::Git; -use Ssoma::GitIndexInfo; - -sub new { - my ($class, $git) = @_; - bless { git => $git, ref => "refs/heads/master" }, $class; -} - -sub remove_simple { - my ($self, $simple) = @_; - my $git = $self->{git}; - my $sub = sub { - $git->tmp_index_do(sub { - $self->_remove($simple); - }); - }; - $git->sync_do(sub { $git->tmp_git_do($sub) }); -} - -# remove an Email::Simple object from the current index -sub _remove { - my ($self, $simple) = @_; - my $git = $self->{git}; - my $path = $git->mid2path($simple->header("Message-ID")); - my $ref = $self->{ref}; - my $tip = $git->qx_sha1("git rev-parse $ref^0"); - my $obj = "$tip:$path"; - my $type = $git->type($obj); - my (@keep, @remove); - if ($type eq "tree") { # unlikely - $git->each_in_tree($obj, sub { - my ($blob_id, $xpath) = ($1, $2); - my $tmp = $git->blob_to_simple($blob_id); - if ($git->simple_eq($simple, $tmp)) { - push @remove, "$path/$xpath"; - } else { - push @keep, $blob_id; - } - }); - } elsif ($type eq "blob") { # likely - my $tmp = $git->blob_to_simple($obj); - if ($git->simple_eq($simple, $tmp)) { - push @remove, $path; - } - } else { - die "unhandled type=$type for obj=$obj\n"; - } - - my $gii = Ssoma::GitIndexInfo->new; - foreach my $rm (@remove) { $gii->remove($rm) } - - if (scalar(@keep) == 1) { # convert tree back to blob - my $blob_id = $keep[0]; - $gii->remove($path); - $gii->update('100644', $blob_id, $path); - } elsif ((scalar(@keep) == 0) && ($type eq "tree")) { - # this is not possible unless simple_eq changes over time - $gii->remove($path); - } # else: do nothing if (@keep > 1) - - # commit changes - $git->commit_index($gii, 1, $ref, 'rm'); -} - -1; diff --git a/ssoma b/ssoma deleted file mode 100755 index a3b0374..0000000 --- a/ssoma +++ /dev/null @@ -1,287 +0,0 @@ -#!/usr/bin/perl -w -# Copyright (C) 2013, Eric Wong and all contributors -# License: AGPLv3 or later (https://www.gnu.org/licenses/agpl-3.0.txt) -# This is the normal command-line client for users -use strict; -use warnings; -use Getopt::Long; -use Ssoma::Git; -use Ssoma::Extractor; -use File::Path::Expand qw/expand_filename/; -use File::Path qw/make_path/; -use File::Temp qw/tempfile/; -use File::Spec qw//; -use Email::LocalDelivery; -use constant CRON_RAND_DELAY => 60; # adjust as necessary -Getopt::Long::Configure("require_order", "pass_through"); -our %opts; -GetOptions( - "help|h" => \$opts{help}, - "quiet|q" => \$opts{quiet}, - "force|f" => \$opts{force}, -) or usage(1); - -$ENV{SSOMA_HOME} ||= expand_filename("~/.ssoma"); - -# these expand automatically to the associated cmd_$name, so "add" -# calls cmd_add, "sync" calls cmd_sync, and so forth -our %cmd = ( - "add" => { - doc => "start watching a new list", - arg => "LISTNAME URL TYPE:/path/to/destination [TARGET]", - long => "TYPE must be one of 'maildir', 'mbox', 'imap' ". - "or 'command'", - }, - "sync" => { - doc => "sync target(s) for existing LISTNAME", - arg => "[LISTNAME] [TARGET]", - opt => { - cron => \$opts{cron}, - 'since=s' => \$opts{since}, - 'after=s' => \$opts{since}, - } - }, - "cat" => { - doc => "show a message by Message-ID", - arg => "MESSAGE-ID [LISTNAME|GIT_DIR]", - }, -); - -my $cmd = shift @ARGV; -usage("", 1) unless defined $cmd; -$cmd eq "help" and usage("", 0); -$cmd{$cmd} or usage("", 1); - -my $cmd_sub = eval { - no strict 'refs'; - *{"cmd_$cmd"}; -} or die "BUG: $cmd not implemented\n"; -if (my $opt = $cmd{$cmd}->{opt}) { - GetOptions(%$opt) or usage(1); -} - -$cmd_sub->(@ARGV); -exit 0; - -sub usage { - my ($cmd, $exit) = @_; - my $fd = $exit ? \*STDERR : \*STDOUT; - print $fd "Usage: ssoma [opts] [command-opts] [args]\n"; - - print $fd "Available commands:\n" unless $cmd; - - foreach my $c (sort keys %cmd) { - next if $cmd && $cmd ne $c; - my $pad = 'A10'; - print $fd ' ', pack($pad, $c), $cmd{$c}->{doc}, "\n"; - print $fd ' ', pack($pad, ''), $cmd{$c}->{arg}, "\n"; - - my $long = $cmd{$c}->{long}; - if ($long) { - print $fd ' ', pack($pad, ''), $long, "\n"; - } - - my $opt = $cmd{$c}->{opt} or next; - foreach (sort keys %$opt) { - # prints out arguments as they should be passed: - my $x = s#[:=]s$## ? '' : - (s#[:=]i$## ? '' : ''); - print $fd ' ' x 14, join(', ', map { length $_ > 1 ? - "--$_" : "-$_" } - split /\|/, $_)," $x\n"; - } - } - exit $exit; -} - -sub check_listname { - my ($name) = @_; - - $name =~ /\A[a-zA-Z0-9]/ or die - "LISTNAME must start with an alphanumeric char\n"; - $name =~ /[a-zA-Z0-9]\z/ or die - "LISTNAME must end with an alphanumeric char\n"; - $name =~ /\A[\w\.\-]+\z/ or die - "LISTNAME must only contain alphanumerics, dashes, periods and underscores\n"; -} - -sub cmd_add { - my ($listname, $url, $dest, $target) = @_; - (defined($url) && defined($listname) && defined($dest)) or - usage("add", 1); - - check_listname($listname); - - $dest =~ /\A(mbox|maildir|command|imaps?):(.+)\z/ or - die usage("add", 1); - - my ($type, $path) = ($1, $2); - my $imap; - - if ($type =~ /\Aimaps?\z/) { - $imap = 1; - } else { - $path = File::Spec->rel2abs($path); - } - - # Email::LocalDelivery relies on this trailing slash for - # maildir distinction - if (($type eq "maildir") && ($path !~ m!/\z!)) { - $path .= "/"; - } elsif (($type eq "mbox") && ($path =~ m!/\z!)) { - die "mbox `$path' must not end with a trailing slash\n"; - } - - $target = "local" unless defined $target; - - my $dir = "$ENV{SSOMA_HOME}/$listname.git"; - make_path($ENV{SSOMA_HOME}); - my $git = Ssoma::Git->new($dir); - my @init_args; - push @init_args, '-q' if $opts{quiet}; - $git->init_db(@init_args); - my $state = "$git->{git_dir}/ssoma.state"; - - if ($imap) { - local $ENV{GIT_CONFIG} = "$git->{git_dir}/config"; - require URI; - - # no imap:// support in URI, yet, but URI has ftp:// - # for passwords - my $uri = $dest; - $uri =~ s{\A(imaps?):}{ftp:}; - my $scheme = $1; - my $u = URI->new($uri); - - $u->scheme or die "no scheme from $dest\n"; - defined(my $host = $u->host) or die "no host from $dest\n"; - my $port = $u->_port; - x(qw/git config imap.port/, $port) if (defined $port); - x(qw/git config imap.host/, "$scheme://$host"); - - defined(my $user = $u->user) or die "no user in $dest\n";; - x(qw/git config imap.user/, $user); - - my $path = $u->path; - defined $path or $path = "INBOX"; - $path =~ s!\A/!!; # no leading slash - x(qw/git config imap.folder/, $path); - - warn_imap_pass($u->password, $ENV{GIT_CONFIG}); - - # this only needs to be set for Extractor to follow - local $ENV{GIT_CONFIG} = $state; - x(qw/git config/, "target.$target.imap", "true"); - } else { - local $ENV{GIT_CONFIG} = $state; - my $cfg = $type eq "command" ? "command" : "path"; - x(qw/git config/, "target.$target.$cfg", $path); - } - - $git->sync_do(sub { - $git->tmp_git_do(sub { - x(qw/git remote add --mirror=fetch origin/, $url); - }); - }); -} - -sub foreach_list { - my ($sub) = @_; - foreach my $dir (glob("$ENV{SSOMA_HOME}/*.git")) { - -d $dir or next; - $sub->($dir); - } -} - -sub cmd_sync { - my ($listname, @targets) = @_; - if ($opts{cron}) { - $opts{quiet} = 1; - sleep(rand(CRON_RAND_DELAY)); - } - if (defined $listname) { - check_listname($listname); - do_sync("$ENV{SSOMA_HOME}/$listname.git", \@targets); - } else { - foreach_list(sub { do_sync($_[0], []) }); - } -} - -sub cmd_cat { - my ($message_id, $listname) = @_; - - # write to a temporary mbox because Email::LocalDelivery works - # that way. - my ($fh, $mbox) = tempfile(TMPDIR => 1, SUFFIX => '.mbox'); - - if (defined $listname) { - my $path = -d $listname ? $listname - : "$ENV{SSOMA_HOME}/$listname.git"; - do_cat($path, $message_id, $mbox); - } else { - foreach_list(sub { do_cat($_[0], $message_id, $mbox, 1) }); - } - unlink $mbox or warn "error unlinking $mbox: $!\n"; - - foreach (<$fh>) { - print $_ or warn "failed printing to stdout: $!\n"; - } - close $fh or die "error closing $mbox: $!\n"; -} - -sub do_sync { - my ($dir, $targets) = @_; - my $git = Ssoma::Git->new($dir); - my $ex = Ssoma::Extractor->new($git); - my $since = $opts{since}; - - # no targets? sync all of them - if (scalar(@$targets) == 0) { - my $cfg = $git->config_list("$git->{git_dir}/ssoma.state"); - my %t; - foreach my $k (keys %$cfg) { - $k =~ /\Atarget\.(\w+)\.(?:path|imap|command)\z/ - or next; - $t{$1} = 1; - } - @$targets = keys %t; - } - - $git->sync_do(sub { - $git->tmp_git_do(sub { - my @cmd = qw/git fetch/; - push @cmd, '-q' if $opts{quiet}; - push @cmd, '-f' if $opts{force}; - x(@cmd); - }); - }); - - foreach my $target (@$targets) { - $ex->extract($target, $since); - } -} - -sub x { - system(@_) and die join(' ', @_). " failed: $?\n"; -} - -sub warn_imap_pass { - my ($pass, $file) = @_; - - if (defined $pass && length $pass) { - print STDERR <new($dir); - my $ex = Ssoma::Extractor->new($git); - $ex->midextract($message_id, $mbox, $missing_ok); -} diff --git a/ssoma-rm b/ssoma-rm deleted file mode 100755 index 05f2d66..0000000 --- a/ssoma-rm +++ /dev/null @@ -1,19 +0,0 @@ -#!/usr/bin/perl -w -# Copyright (C) 2013, Eric Wong and all contributors -# License: AGPLv3 or later (https://www.gnu.org/licenses/agpl-3.0.txt) -# this is intended for server administrators, so it takes an absolute -# path (however this may be run by clients, too). -my $usage = "ssoma-rm /path/to/git/repo < /path/to/rfc2822_message"; -use strict; -use warnings; -use Ssoma::Git; -use Ssoma::Remover; -my $dir = shift or die "usage: $usage\n"; -my $git = Ssoma::Git->new($dir); -my $rm = Ssoma::Remover->new($git); -my $simple; -{ - local $/; # slurp message from stdin - $simple = Email::Simple->new(<>); -}; -$rm->remove_simple($simple); diff --git a/t/all.t b/t/all.t deleted file mode 100644 index d58e1db..0000000 --- a/t/all.t +++ /dev/null @@ -1,221 +0,0 @@ -#!/usr/bin/perl -w -# Copyright (C) 2013, Eric Wong and all contributors -# License: AGPLv3 or later (https://www.gnu.org/licenses/agpl-3.0.txt) -use strict; -use warnings; -use Test::More; -# test all command-line interfaces at once -my $mda = "blib/script/ssoma-mda"; -my $cli = "blib/script/ssoma"; -my $rm = "blib/script/ssoma-rm"; -my $tmp = tempdir(CLEANUP => 1); -use File::Temp qw/tempdir/; -use Email::Simple; -my $have_ipc_run = eval { - require IPC::Run; - import IPC::Run qw/run/; - 1; -}; - -ok(-x $mda, "$mda is executable"); -ok(-x $cli, "$cli is executable"); - -{ - # instantiate new git repo - my $git_dir = "$tmp/input.git"; - system(qw/git init -q --bare/, $git_dir) == 0 or - die "git init -q --bare $git_dir failed: $?\n"; - ok(-d $git_dir && -f "$git_dir/config", "$git_dir exists and is bare"); - - # deliver the message - my $simple = Email::Simple->new(<<'EOF'); -From: me@example.com -To: u@example.com -Message-ID: <666@example.com> -Subject: zzz - -OMFG -EOF - my $pid = open my $pipe, '|-'; - defined $pid or die "failed to pipe + fork: $!\n"; - if ($pid == 0) { - exec($mda, $git_dir); - die "exec failed: $!\n"; - } - print $pipe $simple->as_string or die "print failed: $!\n"; - close $pipe or die "close pipe failed: $!\n"; - is($?, 0, "$mda exited successfully"); -} - -{ - my $mbox = "$tmp/mbox"; - local $ENV{SSOMA_HOME} = "$tmp/ssoma-home"; - my $name = "test"; - my @cmd = ($cli, '-q', "add", $name, "$tmp/input.git", "mbox:$mbox"); - is(system(@cmd), 0, "add list with ssoma(1)"); - - { - use Ssoma::Git; - my $git_dir = "$ENV{SSOMA_HOME}/$name.git"; - my $git = Ssoma::Git->new($git_dir); - my $cfg = $git->config_list("$git_dir/ssoma.state"); - is(scalar keys %$cfg, 1, "only one key"); - like($cfg->{"target.local.path"}, qr{\A/}, - "target.local.path is absolute"); - like($cfg->{"target.local.path"}, qr{\Q$mbox\E\z}, - "target.local.path points to mbox"); - - $cfg = $git->config_list("$git_dir/config"); - is($cfg->{"core.bare"}, "true", "repo is bare"); - } - - @cmd = ($cli, '-q', "sync"); - is(system(@cmd), 0, "sync list with ssoma(1)"); - - open(my $fh, '<', $mbox) or die "open $mbox: $!\n"; - my @lines = <$fh>; - is(scalar grep(/^Subject: zzz/, @lines), 1, "email delivered"); - close $fh or die "close $mbox: $!\n"; -} - -{ - # deliver an additional message - my $simple = Email::Simple->new(<<'EOF'); -From: moi@example.com -To: you@example.com -Message-ID: <666666@example.com> -Subject: xxx - -OMFG -EOF - my $pid = open my $pipe, '|-'; - defined $pid or die "failed to pipe + fork: $!\n"; - if ($pid == 0) { - exec($mda, "$tmp/input.git"); - die "exec failed: $!\n"; - } - print $pipe $simple->as_string or die "print failed: $!\n"; - close $pipe or die "close pipe failed: $!\n"; - is($?, 0, "$mda exited successfully"); -} - -# ensure new message is delivered -{ - my $mbox = "$tmp/mbox"; - local $ENV{SSOMA_HOME} = "$tmp/ssoma-home"; - my $name = "test"; - - my @cmd = ($cli, '-q', "sync", $name); - is(system(@cmd), 0, "sync $name list with ssoma(1)"); - - open(my $fh, '<', $mbox) or die "open $mbox: $!\n"; - my @lines = <$fh>; - is(scalar grep(/^Subject: xxx/, @lines), 1, "email delivered"); - is(scalar grep(/^Subject: zzz/, @lines), 1, "email delivered"); - close $fh or die "close $mbox: $!\n"; -} - -# ssoma cat functionality -{ - local $ENV{SSOMA_HOME} = "$tmp/ssoma-home"; - my @full = `$cli cat \\<666\@example.com\\>`; - my $from = shift @full; - like($from, qr/^From /, "ssoma cat mbox has From_ line"); - is(scalar grep(/^Message-ID: <666\@example\.com>/, @full), 1, - "correct message returned from ssoma cat"); - my @lazy = `$cli cat 666\@example.com`; - $from = shift @lazy; - like($from, qr/^From /, "ssoma cat (lazy) mbox has From_ line"); - is(join('', @lazy), join('', @full), - "lazy ssoma cat invocation w/o <> works"); -} - -# ssoma cat with a repo path -{ - my @full = `$cli cat \\<666\@example.com\\> $tmp/input.git`; - my $from = shift @full; - like($from, qr/^From /, "ssoma cat mbox has From_ line"); - is(scalar grep(/^Message-ID: <666\@example\.com>/, @full), 1, - "correct message returned from ssoma cat"); -} - -# duplicate message delivered to MDA (for "ssoma cat" dup handling) -{ - # deliver the message - my $dup = Email::Simple->new(<<'EOF'); -From: me@example.com -To: u@example.com -Message-ID: <666@example.com> -Subject: duplicate - -EOF - use Ssoma::MDA; - use Ssoma::Git; - Ssoma::MDA->new(Ssoma::Git->new("$tmp/input.git"))->deliver($dup); -} - -# test ssoma cat on a duplicate -{ - my $mbox = "$tmp/mbox"; - local $ENV{SSOMA_HOME} = "$tmp/ssoma-home"; - my $name = "test"; - my @cmd = ($cli, "-q", "sync", $name); - is(system(@cmd), 0, "sync $name with ssoma(1)"); - - my @both = `$cli cat \\<666\@example.com\\>`; - is(scalar grep(/^Message-ID: <666\@example\.com>/, @both), 2, - "correct messages returned from ssoma cat"); - is(scalar grep(/^From /, @both), 2, - "From_ line from both messages returned from ssoma cat"); - my @s = sort grep(/^Subject: /, @both); - my @x = ("Subject: duplicate\n", "Subject: zzz\n"); - is_deeply(\@s, \@x, "subjects are correct in mbox"); -} - -# test ssoma-rm functionality -{ - my $git_dir = "$tmp/input.git"; - my @tree = `GIT_DIR=$git_dir git ls-tree -r HEAD`; - is(scalar @tree, 3, "three messages sitting in a tree"); - - # deliver the message to ssoma-rm - my $simple = Email::Simple->new(<<'EOF'); -From: me@example.com -To: u@example.com -Message-ID: <666@example.com> -Subject: zzz - -OMFG -EOF - my $pid = open my $pipe, '|-'; - defined $pid or die "failed to pipe + fork: $!\n"; - if ($pid == 0) { - exec($rm, $git_dir); - die "exec failed: $!\n"; - } - print $pipe $simple->as_string or die "print failed: $!\n"; - close $pipe or die "close pipe failed: $!\n"; - is($?, 0, "$rm exited successfully"); - @tree = `GIT_DIR=$git_dir git ls-tree -r HEAD`; - is(scalar @tree, 2, "two messages sitting in a tree"); -} - -# duplicate detection -SKIP: { - skip "IPC::Run not available", 2 unless $have_ipc_run; - my $simple = Email::Simple->new(<<'EOF'); -From: moi@example.com -To: you@example.com -Message-ID: <666666@example.com> -Subject: xxx - -OMFG -EOF - $simple = $simple->as_string; - my ($out, $err) = ("", ""); - run([$mda, "-1", "$tmp/input.git"], \$simple, \$out, \$err); - isnt($?, 0, "$mda exited with failure"); - like($err, qr/CONFLICT/, "conflict message detected"); -} - -done_testing(); diff --git a/t/extractor.t b/t/extractor.t deleted file mode 100644 index abad5b8..0000000 --- a/t/extractor.t +++ /dev/null @@ -1,192 +0,0 @@ -#!/usr/bin/perl -w -# Copyright (C) 2013, Eric Wong and all contributors -# License: AGPLv3 or later (https://www.gnu.org/licenses/agpl-3.0.txt) -use strict; -use warnings; -use Test::More; -use Ssoma::Extractor; -use Ssoma::Git; -use Ssoma::MDA; -use File::Temp qw/tempdir/; - -my $mdadir = tempdir(CLEANUP => 1); -my $outdir = tempdir(CLEANUP => 1); - -my $outgit = Ssoma::Git->new("$outdir/git"); -my $ex = Ssoma::Extractor->new($outgit); -my $maildir = "$outdir/maildir/"; -my $mailbox = "$outdir/mbox"; - -my $mdagit = Ssoma::Git->new("$mdadir/gittest"); -$mdagit->init_db; -my $mda = Ssoma::MDA->new($mdagit); -my $email = Email::Simple->new(<<'EOF'); -From: U -To: Me -Message-ID: <666@example.com> -Subject: :o - -HIHI -EOF - -$mda->deliver($email); - -{ - my @cmd = (qw/git clone -q --mirror/, - $mdagit->{git_dir}, $outgit->{git_dir}); - is(system(@cmd), 0, "extractor repository cloned"); -} - -{ - local $ENV{GIT_CONFIG} = "$outgit->{git_dir}/ssoma.state"; - is(system(qw/git config target.mydir.path/, $maildir), 0, - "setup maildir"); -} - - -my $check_last = sub { - my ($key) = @_; - local $ENV{GIT_CONFIG} = "$outgit->{git_dir}/ssoma.state"; - my $last = `git config $key`; - is($?, 0, "git config succeeds"); - like($last, qr/^[a-f0-9]{40}$/, "last-imported is a SHA1"); -}; - -{ - $ex->extract("mydir"); - my @new = glob("$outdir/maildir/new/*"); - is(scalar @new, 1, "one file now exists in maildir"); - my $f = $new[0]; - open my $fh, '<', $f or die "opening $f failed: $!\n"; - local $/; - my $s = <$fh>; - my $simple = Email::Simple->new($s); - is($simple->header('message-id'), '<666@example.com>', - "delivered message-id matches"); - $check_last->("target.mydir.last-imported"); - unlink $f or die "failed to unlink $f: $!\n"; -} - -{ - local $ENV{GIT_CONFIG} = "$outgit->{git_dir}/ssoma.state"; - is(system(qw/git config target.mybox.path/, $mailbox), 0, - "setup mailbox"); -} - -{ - $ex->extract("mybox"); - open my $fh, '<', $mailbox or die "opening $mailbox failed: $!\n"; - local $/; - my $s = <$fh>; - my $simple = Email::Simple->new($s); - is($simple->header('message-id'), '<666@example.com>', - "delivered message-id matches"); - $check_last->("target.mybox.last-imported"); -} - -my $another = Email::Simple->new(<<'EOF'); -From: U -To: Me -Message-ID: <666666@example.com> -Subject: byebye - -*yawn* -EOF -$mda->deliver($another); - -{ - local $ENV{GIT_DIR} = $outgit->{git_dir}; - is(system("git fetch -q"), 0, "fetching updates succeeds"); -} - -# ensure we can update maildir without adding old messages -{ - - $ex->extract("mydir"); - my @new = glob("$outdir/maildir/new/*"); - is(scalar @new, 1, "one new file now exists in maildir"); - my $f = $new[0]; - open my $fh, '<', $f or die "opening $f failed: $!\n"; - local $/; - my $s = <$fh>; - my $simple = Email::Simple->new($s); - is($simple->header('message-id'), '<666666@example.com>', - "delivered message-id matches"); - is($simple->body, "*yawn*\n", "body matches"); - $check_last->("target.mydir.last-imported"); - unlink $f or die "failed to unlink $f: $!\n"; # for next test -} - -# ensure we can update mmbox without adding old messages -{ - - $ex->extract("mybox"); - open my $fh, '<', $mailbox or die "opening $mailbox failed: $!\n"; - my @lines = <$fh>; - my @subjects = grep /^Subject:/, @lines; - my @from_ = grep /^From /, @lines; - is(scalar @subjects, 2, "2 subjects in mbox"); - is(scalar @from_, 2, "2 From_ lines in mbox"); - - $check_last->("target.mydir.last-imported"); -} - -# ensure we can handle conflicts w/o reimporting when the MDA -# upgrades a blob to a tree. -my $conflict = Email::Simple->new(<<'EOF'); -From: U -To: Me -Message-ID: <666666@example.com> -Subject: BYE - -*YAWN* -EOF -$mda->deliver($conflict); - -{ - local $ENV{GIT_DIR} = $outgit->{git_dir}; - is(system("git fetch -q"), 0, "fetching updates succeeds"); -} - -# ensure we can update maildir without adding old messages even on a -# message-id conflict -{ - - $ex->extract("mydir"); - my @new = glob("$outdir/maildir/new/*"); - is(scalar @new, 1, "one new file now exists in maildir"); - my $f = $new[0]; - open my $fh, '<', $f or die "opening $f failed: $!\n"; - local $/; - my $s = <$fh>; - my $simple = Email::Simple->new($s); - is($simple->header('message-id'), '<666666@example.com>', - "delivered conflicting message-id matches"); - is($simple->body, "*YAWN*\n", "body matches on conflict"); - $check_last->("target.mydir.last-imported"); -} - -# ensure we can pipe to commands -{ - { - my $cat = "cat >> $outdir/cat.out"; - local $ENV{GIT_CONFIG} = "$outgit->{git_dir}/ssoma.state"; - is(system(qw/git config target.cat.command/, $cat), 0, - "setup delivery command"); - } - - $ex->extract("cat"); - my $f = "$outdir/cat.out"; - open my $fh, '<', $f or die "open $f failed: $!\n"; - my @lines = <$fh>; - my @subjects = grep /^Subject:/, @lines; - my @from = grep /^From:/, @lines; - my @mid = grep /^Message-ID:/i, @lines; - is(scalar @subjects, 3, "3 subjects in dump"); - is(scalar @mid, 3, "3 message-ids in dump"); - is(scalar @from, 3, "3 From: lines in dump"); - - $check_last->("target.cat.last-imported"); -} - -done_testing(); diff --git a/t/git.t b/t/git.t deleted file mode 100644 index c19093d..0000000 --- a/t/git.t +++ /dev/null @@ -1,61 +0,0 @@ -#!/usr/bin/perl -w -# Copyright (C) 2013, Eric Wong and all contributors -# License: AGPLv3 or later (https://www.gnu.org/licenses/agpl-3.0.txt) -use strict; -use warnings; -use Test::More; -use Ssoma::Git; -use Ssoma::GitIndexInfo; -use File::Temp qw/tempdir/; -my $tmpdir = tempdir(CLEANUP => 1); -my $git = Ssoma::Git->new("$tmpdir/gittest"); - -$git->init_db; -ok(-d "$tmpdir/gittest", "git repo created"); - -{ - my $v = `GIT_DIR=$tmpdir/gittest git config ssoma.repoversion`; - is(0, $?, "git config succeeded"); - chomp($v); - is(1, $v, "ssoma.repoversion is set to 1"); -} - -is(0, $git->tmp_git_do(sub { system(qw(git config ssoma.test foo)) }), - "setting config works"); - -is("foo\n", $git->tmp_git_do(sub { `git config ssoma.test` }), - "reading config works"); - -$git->tmp_git_do(sub { - my $commit; - $git->tmp_index_do(sub { - my $gii = Ssoma::GitIndexInfo->new; - - my $sha1 = `echo hello world | git hash-object -w --stdin`; - is(0, $?, "hashed one object"); - chomp $sha1; - - is(1, $gii->update(100644, $sha1, 'hello/world'), - "add hashed object to index"); - $gii = undef; - - my $tree = `git write-tree`; - is(0, $?, "wrote tree out"); - chomp $tree; - - $commit = `git commit-tree -m 'hi' $tree`; - is(0, $?, "committed tree"); - chomp $commit; - - is(0, system(qw(git update-ref refs/heads/master), $commit), - "updated ref"); - }); -}); - -{ - is($git->mid2path(""), - $git->mid2path("\t\t"), - "mid2path ignores leading/trailing whitespace"); -} - -done_testing(); diff --git a/t/imap.t b/t/imap.t deleted file mode 100644 index 14fc0b3..0000000 --- a/t/imap.t +++ /dev/null @@ -1,8 +0,0 @@ -#!/usr/bin/perl -w -# Copyright (C) 2013, Eric Wong and all contributors -# License: AGPLv3 or later (https://www.gnu.org/licenses/agpl-3.0.txt) -use strict; -use warnings; -use Test::More; -require_ok("Ssoma::IMAP"); -done_testing(); diff --git a/t/remover.t b/t/remover.t deleted file mode 100644 index 1d74c02..0000000 --- a/t/remover.t +++ /dev/null @@ -1,87 +0,0 @@ -#!/usr/bin/perl -w -# Copyright (C) 2013, Eric Wong and all contributors -# License: AGPLv3 or later (https://www.gnu.org/licenses/agpl-3.0.txt) -use strict; -use warnings; -use Test::More; -use Ssoma::MDA; -use Ssoma::Git; -use Ssoma::Remover; -use Email::Simple; -use Digest::SHA qw/sha1_hex/; -use File::Temp qw/tempdir/; - -my $tmpdir = tempdir(CLEANUP => 1); -my $git_dir = "$tmpdir/gittest"; -my $git = Ssoma::Git->new($git_dir); -$git->init_db; -my $mda = Ssoma::MDA->new($git); -my $rm = Ssoma::Remover->new($git); -my @tree; - -{ - my $email = Email::Simple->new(<<'EOF'); -From: me@example.com -To: u@example.com -Message-ID: <666@example.com> -Subject: zzz - -OMFG -EOF - - $mda->deliver($email); - @tree = `GIT_DIR=$git_dir git ls-tree -r HEAD`; - is($?, 0, "no error from git ls-tree"); - is(scalar @tree, 1, "message delivered"); - - # simple removal - $rm->remove_simple($email); - @tree = `GIT_DIR=$git_dir git ls-tree -r HEAD`; - is($?, 0, "no error from git ls-tree"); - is(scalar @tree, 0, "tree is now empty after removal"); - - $mda->deliver($email); - $email->body_set("conflict"); - $mda->deliver($email); - - @tree = `GIT_DIR=$git_dir git ls-tree -r HEAD`; - is($?, 0, "no error from git ls-tree"); - is(scalar @tree, 2, "both messages stored"); - - # remove only one (the concflicting one) - $rm->remove_simple($email); - @tree = `GIT_DIR=$git_dir git ls-tree -r HEAD`; - is($?, 0, "no error from git ls-tree"); - is(scalar @tree, 1, "one removed, one exists"); - - my @line = split(/\s+/, $tree[0]); - is($line[1], "blob", "back to one blob"); - my $cur = `GIT_DIR=$git_dir git cat-file blob $line[2]`; - like($cur, qr/OMFG/, "kept original"); - $email->body_set("OMFG\n"); - $rm->remove_simple($email); - @tree = `GIT_DIR=$git_dir git ls-tree -r HEAD`; - is($?, 0, "no error from git ls-tree"); - is(scalar @tree, 0, "last removed"); - - my @seq = qw(1 2 3); - foreach my $i (@seq) { - $email->body_set("$i\n"); - $mda->deliver($email); - } - @tree = `GIT_DIR=$git_dir git ls-tree -r HEAD`; - is($?, 0, "no error from git ls-tree"); - is(scalar @tree, scalar @seq, "several messages exist"); - - my $expect = 3; - foreach my $i (@seq) { - $email->body_set("$i\n"); - $rm->remove_simple($email); - @tree = `GIT_DIR=$git_dir git ls-tree -r HEAD`; - is($?, 0, "no error from git ls-tree"); - $expect--; - is(scalar @tree, $expect, "$expect messages left"); - } -} - -done_testing();