From mboxrd@z Thu Jan 1 00:00:00 1970 Return-Path: X-Spam-Checker-Version: SpamAssassin 3.3.2 (2011-06-06) on dcvr.yhbt.net X-Spam-Level: X-Spam-ASN: X-Spam-Status: No, score=-2.9 required=3.0 tests=ALL_TRUSTED,AWL,BAYES_00, RP_MATCHES_RCVD,URIBL_BLOCKED shortcircuit=no autolearn=unavailable version=3.3.2 X-Original-To: meta@public-inbox.org Received: from localhost (dcvr.yhbt.net [127.0.0.1]) by dcvr.yhbt.net (Postfix) with ESMTP id 376E82057D for ; Thu, 3 Mar 2016 03:23:45 +0000 (UTC) From: Eric Wong To: meta@public-inbox.org Subject: [PATCH] use Email::MIME::Header::header_raw to read Message-ID Date: Thu, 3 Mar 2016 03:23:45 +0000 Message-Id: <20160303032345.9126-1-e@80x24.org> List-Id: Somebody could set a Message-ID using MIME header encoding and trigger mismatches. Favor the non-encoded value for storage instead. This removes the explicit dependency on Email::Simple entirely to reduce a step in the installation process (however Email::MIME still pulls it in). --- INSTALL | 1 - Makefile.PL | 1 - lib/Ssoma/Git.pm | 26 +++++++++++++------------- lib/Ssoma/MDA.pm | 23 +++++++++++------------ lib/Ssoma/Remover.pm | 22 +++++++++++----------- ssoma-mda | 6 +++--- ssoma-rm | 6 +++--- t/all.t | 22 +++++++++++----------- t/extractor.t | 26 +++++++++++++------------- t/mda-badheaders.t | 6 +++--- t/mda-conflict.t | 10 +++++----- t/mda-missing-mid.t | 6 +++--- t/remover.t | 18 +++++++++--------- 13 files changed, 85 insertions(+), 88 deletions(-) diff --git a/INSTALL b/INSTALL index 3f8702e..d907ea3 100644 --- a/INSTALL +++ b/INSTALL @@ -39,7 +39,6 @@ convenience. - Email::Address libemail-address-perl - Email::LocalDelivery libemail-localdelivery-perl - Email::MIME libemail-mime-perl - - Email::Simple libemail-simple-perl - File::Path::Expand libfile-path-expand-perl - IPC::Run libipc-run-perl - Net::IMAP::Simple libnet-imap-simple-perl diff --git a/Makefile.PL b/Makefile.PL index 00326fc..6316423 100644 --- a/Makefile.PL +++ b/Makefile.PL @@ -17,7 +17,6 @@ WriteMakefile( 'Digest::SHA' => 0, 'Email::Address' => 0, 'Email::LocalDelivery' => 0, - 'Email::Simple' => 0, 'Email::MIME' => 0, 'IPC::Run' => 0, 'File::Path::Expand' => 0, diff --git a/lib/Ssoma/Git.pm b/lib/Ssoma/Git.pm index 70548fd..bc31cdc 100644 --- a/lib/Ssoma/Git.pm +++ b/lib/Ssoma/Git.pm @@ -12,7 +12,7 @@ use warnings; use File::Path qw/mkpath/; use Fcntl qw/:DEFAULT :flock SEEK_END/; use IO::Handle; -use Email::Simple; +use Email::MIME; use Digest::SHA qw/sha1_hex/; use IPC::Run qw/run/; @@ -138,18 +138,18 @@ sub qx_sha1 { } # returns a blob identifier the new message -sub simple_to_blob { - my ($self, $simple) = @_; +sub mime_to_blob { + my ($self, $mime) = @_; $self->bidi_sha1(qw/git hash-object -w --stdin/, sub { my ($io) = @_; - print $io $simple->as_string or die "print failed: $!\n"; + print $io $mime->as_string or die "print failed: $!\n"; }); } -# converts the given object name to an Email::Simple object -sub blob_to_simple { +# converts the given object name to an Email::MIME object +sub blob_to_mime { my ($self, $obj) = @_; - Email::Simple->new($self->cat_blob($obj)); + Email::MIME->new($self->cat_blob($obj)); } # returns key-value pairs of config directives in a hash @@ -166,18 +166,18 @@ sub config_list { } # used to hash the relevant portions of a message when there are conflicts -sub hash_simple2 { - my ($self, $simple) = @_; +sub hash_mime2 { + my ($self, $mime) = @_; my $dig = Digest::SHA->new("SHA-1"); - $dig->add($simple->header("Subject")); - $dig->add($simple->body); + $dig->add($mime->header("Subject")); + $dig->add($mime->body); $dig->hexdigest; } # we currently only compare messages for equality based on # Message-ID, Subject: header and body, nothing else. -# both args are Email::Simple objects -sub simple_eq { +# both args are Email::MIME objects +sub mime_eq { my ($self, $cur, $new) = @_; (($cur->header("Subject") eq $new->header("Subject")) && diff --git a/lib/Ssoma/MDA.pm b/lib/Ssoma/MDA.pm index 68c9520..0a6d27d 100644 --- a/lib/Ssoma/MDA.pm +++ b/lib/Ssoma/MDA.pm @@ -21,18 +21,18 @@ sub blob_upgrade { my $git = $self->{git}; my $obj = "$self->{ref}^0:$path"; - my $cur = $git->blob_to_simple($obj); + my $cur = $git->blob_to_mime($obj); # do nothing if the messages match: - return 0 if $git->simple_eq($cur, $new); + return 0 if $git->mime_eq($cur, $new); # kill the old blob $gii->remove($path); # implicitly create a new tree via index with two messages foreach my $mime ($cur, $new) { - my $id = $git->simple_to_blob($mime); - my $path2 = $git->hash_simple2($mime); + my $id = $git->mime_to_blob($mime); + my $path2 = $git->hash_mime2($mime); $gii->update("100644", $id, "$path/$path2"); } 1; @@ -49,8 +49,8 @@ sub tree_update { $? == 0 or die "$cmd failed: $!\n"; chomp @tree; - my $id = $git->simple_to_blob($new); - my $path2 = $git->hash_simple2($new); + my $id = $git->mime_to_blob($new); + my $path2 = $git->hash_mime2($new); # go through the existing tree and look for duplicates foreach my $line (@tree) { @@ -84,7 +84,7 @@ sub append { if ($? == 0) { # rare, object already exists chomp $type; if ($once) { - my $mid = $mime->header("Message-ID"); + my $mid = $mime->header_obj->header_raw("Message-ID"); die "CONFLICT: Message-ID: $mid exists ($path)\n"; } @@ -100,7 +100,7 @@ sub append { die "CONFLICT: `$cmd' returned: $type\n"; } } else { # new message, just create a blob, common - my $id = $git->simple_to_blob($mime); + my $id = $git->mime_to_blob($mime); $gii->update('100644', $id, $path); } @@ -119,18 +119,17 @@ sub append { } } -# the main entry point takes an Email::Simple object +# the main entry point takes an Email::MIME object sub deliver { my ($self, $mime, $once) = @_; my $git = $self->{git}; - # convert the Message-ID into a path - my $mid = $mime->header("Message-ID"); + my $mid = $mime->header_obj->header_raw("Message-ID"); # if there's no Message-ID, generate one to avoid too many conflicts # leading to trees if (!defined $mid || $mid =~ /\A\s*\z/) { - $mid = '<' . $git->hash_simple2($mime) . '@localhost>'; + $mid = '<' . $git->hash_mime2($mime) . '@localhost>'; $mime->header_set("Message-ID", $mid); } my $path = $git->mid2path($mid); diff --git a/lib/Ssoma/Remover.pm b/lib/Ssoma/Remover.pm index f1582ac..54724e8 100644 --- a/lib/Ssoma/Remover.pm +++ b/lib/Ssoma/Remover.pm @@ -11,22 +11,22 @@ sub new { bless { git => $git, ref => "refs/heads/master" }, $class; } -sub remove_simple { - my ($self, $simple) = @_; +sub remove_mime { + my ($self, $mime) = @_; my $git = $self->{git}; my $sub = sub { $git->tmp_index_do(sub { - $self->_remove($simple); + $self->_remove($mime); }); }; $git->sync_do(sub { $git->tmp_git_do($sub) }); } -# remove an Email::Simple object from the current index +# remove an Email::MIME object from the current index sub _remove { - my ($self, $simple) = @_; + my ($self, $mime) = @_; my $git = $self->{git}; - my $path = $git->mid2path($simple->header("Message-ID")); + my $path = $git->mid2path($mime->header_obj->header_raw("Message-ID")); my $ref = $self->{ref}; my $tip = $git->qx_sha1("git rev-parse $ref^0"); my $obj = "$tip:$path"; @@ -36,16 +36,16 @@ sub _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)) { + my $tmp = $git->blob_to_mime($blob_id); + if ($git->mime_eq($mime, $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)) { + my $tmp = $git->blob_to_mime($obj); + if ($git->mime_eq($mime, $tmp)) { push @remove, $path; } } else { @@ -61,7 +61,7 @@ sub _remove { $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 + # this is not possible unless mime_eq changes over time $gii->remove($path); } # else: do nothing if (@keep > 1) diff --git a/ssoma-mda b/ssoma-mda index 5eacf75..8d16627 100755 --- a/ssoma-mda +++ b/ssoma-mda @@ -14,9 +14,9 @@ my $once = $ARGV[0] eq "-1"; my $repo = pop @ARGV or die "Usage: $usage\n"; my $git = Ssoma::Git->new($repo); my $mda = Ssoma::MDA->new($git); -my $simple; +my $mime; { local $/; - $simple = Email::MIME->new(); + $mime = Email::MIME->new(); } -$mda->deliver($simple, $once); +$mda->deliver($mime, $once); diff --git a/ssoma-rm b/ssoma-rm index 06f61a1..f0e377c 100755 --- a/ssoma-rm +++ b/ssoma-rm @@ -11,9 +11,9 @@ 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; +my $mime; { local $/; # slurp message from stdin - $simple = Email::Simple->new(<>); + $mime = Email::MIME->new(<>); }; -$rm->remove_simple($simple); +$rm->remove_mime($mime); diff --git a/t/all.t b/t/all.t index b0232d8..4eef8b1 100644 --- a/t/all.t +++ b/t/all.t @@ -5,7 +5,7 @@ use strict; use warnings; use Test::More; use File::Temp qw/tempdir/; -use Email::Simple; +use Email::MIME; # test all command-line interfaces at once my $mda = "blib/script/ssoma-mda"; my $cli = "blib/script/ssoma"; @@ -28,7 +28,7 @@ ok(-x $cli, "$cli is executable"); ok(-d $git_dir && -f "$git_dir/config", '$GIT_DIR exists and is bare'); # deliver the message - my $simple = Email::Simple->new(<<'EOF'); + my $mime = Email::MIME->new(<<'EOF'); From: me@example.com To: u@example.com Message-ID: <666@example.com> @@ -42,7 +42,7 @@ EOF exec($mda, $git_dir); die "exec failed: $!\n"; } - print $pipe $simple->as_string or die "print failed: $!\n"; + print $pipe $mime->as_string or die "print failed: $!\n"; close $pipe or die "close pipe failed: $!\n"; is($?, 0, "$mda exited successfully"); @@ -90,7 +90,7 @@ EOF { # deliver an additional message - my $simple = Email::Simple->new(<<'EOF'); + my $mime = Email::MIME->new(<<'EOF'); From: moi@example.com To: you@example.com Message-ID: <666666@example.com> @@ -104,7 +104,7 @@ EOF exec($mda, "$tmp/input.git"); die "exec failed: $!\n"; } - print $pipe $simple->as_string or die "print failed: $!\n"; + print $pipe $mime->as_string or die "print failed: $!\n"; close $pipe or die "close pipe failed: $!\n"; is($?, 0, "$mda exited successfully"); } @@ -152,7 +152,7 @@ EOF # duplicate message delivered to MDA (for "ssoma cat" dup handling) { # deliver the message - my $dup = Email::Simple->new(<<'EOF'); + my $dup = Email::MIME->new(<<'EOF'); From: me@example.com To: u@example.com Message-ID: <666@example.com> @@ -189,7 +189,7 @@ EOF is(scalar @tree, 3, "three messages sitting in a tree"); # deliver the message to ssoma-rm - my $simple = Email::Simple->new(<<'EOF'); + my $mime = Email::MIME->new(<<'EOF'); From: me@example.com To: u@example.com Message-ID: <666@example.com> @@ -203,7 +203,7 @@ EOF exec($rm, $git_dir); die "exec failed: $!\n"; } - print $pipe $simple->as_string or die "print failed: $!\n"; + print $pipe $mime->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`; @@ -213,7 +213,7 @@ EOF # duplicate detection SKIP: { skip "IPC::Run not available", 2 unless $have_ipc_run; - my $simple = Email::Simple->new(<<'EOF'); + my $mime = Email::MIME->new(<<'EOF'); From: moi@example.com To: you@example.com Message-ID: <666666@example.com> @@ -221,9 +221,9 @@ Subject: xxx OMFG EOF - $simple = $simple->as_string; + $mime = $mime->as_string; my ($out, $err) = ("", ""); - run([$mda, "-1", "$tmp/input.git"], \$simple, \$out, \$err); + run([$mda, "-1", "$tmp/input.git"], \$mime, \$out, \$err); isnt($?, 0, "$mda exited with failure"); like($err, qr/CONFLICT/, "conflict message detected"); } diff --git a/t/extractor.t b/t/extractor.t index 6a5c8f5..de8fe30 100644 --- a/t/extractor.t +++ b/t/extractor.t @@ -20,7 +20,7 @@ my $mailbox = "$outdir/mbox"; my $mdagit = Ssoma::Git->new("$mdadir/gittest"); $mdagit->init_db('-q'); my $mda = Ssoma::MDA->new($mdagit); -my $email = Email::Simple->new(<<'EOF'); +my $email = Email::MIME->new(<<'EOF'); From: U To: Me Message-ID: <666@example.com> @@ -60,8 +60,8 @@ my $check_last = sub { 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>', + my $mime = Email::MIME->new($s); + is($mime->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"; @@ -78,13 +78,13 @@ my $check_last = sub { 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>', + my $mime = Email::MIME->new($s); + is($mime->header('message-id'), '<666@example.com>', "delivered message-id matches"); $check_last->("target.mybox.last-imported"); } -my $another = Email::Simple->new(<<'EOF'); +my $another = Email::MIME->new(<<'EOF'); From: U To: Me Message-ID: <666666@example.com> @@ -109,10 +109,10 @@ $mda->deliver($another); 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>', + my $mime = Email::MIME->new($s); + is($mime->header('message-id'), '<666666@example.com>', "delivered message-id matches"); - is($simple->body, "*yawn*\n", "body matches"); + is($mime->body, "*yawn*\n", "body matches"); $check_last->("target.mydir.last-imported"); unlink $f or die "failed to unlink $f: $!\n"; # for next test } @@ -133,7 +133,7 @@ $mda->deliver($another); # ensure we can handle conflicts w/o reimporting when the MDA # upgrades a blob to a tree. -my $conflict = Email::Simple->new(<<'EOF'); +my $conflict = Email::MIME->new(<<'EOF'); From: U To: Me Message-ID: <666666@example.com> @@ -159,10 +159,10 @@ $mda->deliver($conflict); 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>', + my $mime = Email::MIME->new($s); + is($mime->header('message-id'), '<666666@example.com>', "delivered conflicting message-id matches"); - is($simple->body, "*YAWN*\n", "body matches on conflict"); + is($mime->body, "*YAWN*\n", "body matches on conflict"); $check_last->("target.mydir.last-imported"); } diff --git a/t/mda-badheaders.t b/t/mda-badheaders.t index 0ce0762..01033aa 100644 --- a/t/mda-badheaders.t +++ b/t/mda-badheaders.t @@ -6,7 +6,7 @@ use warnings; use Test::More; use Ssoma::MDA; use Ssoma::Git; -use Email::Simple; +use Email::MIME; use Digest::SHA qw/sha1_hex/; use File::Temp qw/tempdir/; @@ -15,7 +15,7 @@ my $git = Ssoma::Git->new("$tmpdir/gittest"); $git->init_db('-q'); my $mda = Ssoma::MDA->new($git); -my $email = Email::Simple->new("From: U \n\nHIHI\n"); +my $email = Email::MIME->new("From: U \n\nHIHI\n"); my %headers = ( "To" => "Me ", "From" => "You ", @@ -42,7 +42,7 @@ ok(defined $dir && defined $base, "bad sha1: $blob_id"); my $raw = `git cat-file blob HEAD:$dir/$base`; is(0, $?, "git cat-file returned: $?"); -my $delivered = Email::Simple->new($raw); +my $delivered = Email::MIME->new($raw); is("HIHI\n", $delivered->body, "body matches"); foreach my $key (sort keys %headers) { diff --git a/t/mda-conflict.t b/t/mda-conflict.t index 84be907..47bf403 100644 --- a/t/mda-conflict.t +++ b/t/mda-conflict.t @@ -6,7 +6,7 @@ use warnings; use Test::More; use Ssoma::MDA; use Ssoma::Git; -use Email::Simple; +use Email::MIME; use Digest::SHA qw/sha1_hex/; use File::Temp qw/tempdir/; @@ -15,7 +15,7 @@ my $git = Ssoma::Git->new("$tmpdir/gittest"); $git->init_db('-q'); my $mda = Ssoma::MDA->new($git); -my $email = Email::Simple->new("From: U \n\nHIHI\n"); +my $email = Email::MIME->new("From: U \n\nHIHI\n"); $email->header_set("To", "Me "); $email->header_set("Subject", ":o"); $email->header_set("Message-ID", "<12345\@example.com>"); @@ -46,8 +46,8 @@ is(2, scalar @tree, "two entries in tree"); foreach my $line (@tree) { my ($mode, $type, $blob, $path) = split(/\s+/, $line);; my $raw = `git cat-file blob $blob`; - my $simple = Email::Simple->new($raw); - my $mid = $simple->header("message-id"); + my $mime = Email::MIME->new($raw); + my $mid = $mime->header("message-id"); my $path_sha1 = $path; $path_sha1 =~ tr!/!!d; $mid =~ tr/<>//d; @@ -100,7 +100,7 @@ my @want = grep(m!/\Q$want\E!, @curr); is(1, scalar @want, "wanted message is unique"); my $blob = (split(/\s+/, $want[0]))[2]; my $s = `git cat-file blob $blob`; -$s = Email::Simple->new($s); +$s = Email::MIME->new($s); is("<666\@example.com>", $s->header("message-id"), "MID matches"); is($body_3, $s->body, "body matches"); diff --git a/t/mda-missing-mid.t b/t/mda-missing-mid.t index 815616f..5d25d79 100644 --- a/t/mda-missing-mid.t +++ b/t/mda-missing-mid.t @@ -6,20 +6,20 @@ use warnings; use Test::More; use Ssoma::MDA; use Ssoma::Git; -use Email::Simple; +use Email::MIME; use File::Temp qw/tempdir/; my $tmpdir = tempdir('ssoma-mda-missing-mid-XXXXXX', CLEANUP => 1); my $git = Ssoma::Git->new("$tmpdir/gittest"); $git->init_db('-q'); my $mda = Ssoma::MDA->new($git); -my $email = Email::Simple->new("From: U \n\nHIHI\n"); +my $email = Email::MIME->new("From: U \n\nHIHI\n"); $mda->deliver($email); local $ENV{GIT_DIR} = "$tmpdir/gittest"; my @tree = `git ls-tree -r HEAD`; is(scalar @tree, 1, "one item in tree"); my @line = split(/\s+/, $tree[0]); -my $msg = Email::Simple->new($git->cat_blob($line[2])); +my $msg = Email::MIME->new($git->cat_blob($line[2])); like($msg->header("message-id"), qr/\A<[a-f0-9]{40}\@localhost>\z/, "message-id generated for message missing it"); diff --git a/t/remover.t b/t/remover.t index 4291013..d47081a 100644 --- a/t/remover.t +++ b/t/remover.t @@ -7,7 +7,7 @@ use Test::More; use Ssoma::MDA; use Ssoma::Git; use Ssoma::Remover; -use Email::Simple; +use Email::MIME; use Digest::SHA qw/sha1_hex/; use File::Temp qw/tempdir/; @@ -20,7 +20,7 @@ my $rm = Ssoma::Remover->new($git); my @tree; { - my $email = Email::Simple->new(<<'EOF'); + my $email = Email::MIME->new(<<'EOF'); From: me@example.com To: u@example.com Message-ID: <666@example.com> @@ -34,8 +34,8 @@ EOF is($?, 0, "no error from git ls-tree"); is(scalar @tree, 1, "message delivered"); - # simple removal - $rm->remove_simple($email); + # mime removal + $rm->remove_mime($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"); @@ -49,7 +49,7 @@ EOF is(scalar @tree, 2, "both messages stored"); # remove only one (the concflicting one) - $rm->remove_simple($email); + $rm->remove_mime($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"); @@ -59,7 +59,7 @@ EOF 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); + $rm->remove_mime($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"); @@ -76,7 +76,7 @@ EOF my $expect = 3; foreach my $i (@seq) { $email->body_set("$i\n"); - $rm->remove_simple($email); + $rm->remove_mime($email); @tree = `GIT_DIR=$git_dir git ls-tree -r HEAD`; is($?, 0, "no error from git ls-tree"); $expect--; @@ -86,7 +86,7 @@ EOF { local $ENV{GIT_DIR} = $git_dir; my $before = `git rev-parse HEAD^0`; - $rm->remove_simple($email); + $rm->remove_mime($email); my $after = `git rev-parse HEAD^0`; is($before, $after, 'no commit on no-op removal'); } @@ -96,7 +96,7 @@ EOF $mda->deliver($email); my $before = `git rev-parse HEAD^0`; $email->body_set('changed'); - $rm->remove_simple($email); + $rm->remove_mime($email); my $after = `git rev-parse HEAD^0`; is($before, $after, 'no commit on no-op removal miss'); } -- EW