In preparation for the Python translation.
+++ /dev/null
-# Copyright (C) 2013, Eric Wong <normalperson@yhbt.net> 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)
+++ /dev/null
-% 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 <meta@public-inbox.org>\
-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 <normalperson@yhbt.net> and all contributors.\
-License: AGPLv3 or later <http://www.gnu.org/licenses/agpl-3.0.txt>
-
-# SEE ALSO
-
-git(1), ssoma(1), ssoma_repository(5)
+++ /dev/null
-% 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 <meta@public-inbox.org>\
-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 <normalperson@yhbt.net> and all contributors.\
-License: AGPLv3 or later <http://www.gnu.org/licenses/agpl-3.0.txt>
-
-# SEE ALSO
-
-git(1), ssoma_repository(5), ssoma-rm(1)
+++ /dev/null
-#!/usr/bin/env perl
-# Copyright (C) 2014, Eric Wong <normalperson@yhbt.net> 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+\+\&\?\.\%\;/-]+)!<a\nhref="$1"\n>$1</a>!g;
-$str =~ s!\e!>!g; # swap escapes back to >
-
-print '<html><head>',
- '<meta http-equiv="Content-Type" content="text/html; charset=utf-8" />',
- "<title>$title</title>",
- "</head><body>\n<pre>", $str , '</pre></body></html>';
+++ /dev/null
-#!/usr/bin/perl
-# Copyright (C) 2013, Eric Wong <normalperson@yhbt.net> 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 <normalperson@yhbt.net>',
- 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
-}
+++ /dev/null
-# Copyright (C) 2013, Eric Wong <normalperson@yhbt.net> 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;
+++ /dev/null
-# Copyright (C) 2013, Eric Wong <normalperson@yhbt.net> 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 = <STDIN>;
- $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;
+++ /dev/null
-# Copyright (C) 2013, Eric Wong <normalperson@yhbt.net> 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;
+++ /dev/null
-#!/usr/bin/perl -w
-# Copyright (C) 2013, Eric Wong <normalperson@yhbt.net> 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> [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$## ? '<arg>' :
- (s#[:=]i$## ? '<num>' : '');
- 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 <<EOF
-ignoring IMAP password given on command-line
-EOF
- }
- print STDERR <<EOF
-ensure $file is not world-readable if editing
-$file to set imap.pass
-EOF
-}
-
-sub do_cat {
- my ($dir, $message_id, $mbox, $missing_ok) = @_;
- my $git = Ssoma::Git->new($dir);
- my $ex = Ssoma::Extractor->new($git);
- $ex->midextract($message_id, $mbox, $missing_ok);
-}
+++ /dev/null
-#!/usr/bin/perl -w
-# Copyright (C) 2013, Eric Wong <normalperson@yhbt.net> 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);
+++ /dev/null
-#!/usr/bin/perl -w
-# Copyright (C) 2013, Eric Wong <normalperson@yhbt.net> 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();
+++ /dev/null
-#!/usr/bin/perl -w
-# Copyright (C) 2013, Eric Wong <normalperson@yhbt.net> 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 <u@example.com>
-To: Me <me@example.com>
-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 <u@example.com>
-To: Me <me@example.com>
-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 <u@example.com>
-To: Me <me@example.com>
-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();
+++ /dev/null
-#!/usr/bin/perl -w
-# Copyright (C) 2013, Eric Wong <normalperson@yhbt.net> 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("<hello world>"),
- $git->mid2path("\t<hello world>\t"),
- "mid2path ignores leading/trailing whitespace");
-}
-
-done_testing();
+++ /dev/null
-#!/usr/bin/perl -w
-# Copyright (C) 2013, Eric Wong <normalperson@yhbt.net> 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();
+++ /dev/null
-#!/usr/bin/perl -w
-# Copyright (C) 2013, Eric Wong <normalperson@yhbt.net> 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();
projects / ssoma-mda.git / commitdiff