lib/Ssoma/MDA.pm

   1 # Copyright (C) 2013, Eric Wong <normalperson@yhbt.net> and all contributors
   2 # License: AGPLv3 or later (https://www.gnu.org/licenses/agpl-3.0.txt)
   3 #
   4 # Mail Delivery Agent module, delivers mail into a ssoma git repo
   5 package Ssoma::MDA;
   6 use strict;
   7 use warnings;
   8 use Ssoma::GitIndexInfo;
   9
  10 sub new {
  11         my ($class, $git) = @_;
  12         bless { git => $git, ref => "refs/heads/master" }, $class;
  13 }
  14
  15 # may convert existing blob to a tree
  16 # returns false if message already exists
  17 # returns true on successful delivery
  18 sub blob_upgrade {
  19         my ($self, $gii, $new, $path) = @_;
  20
  21         my $git = $self->{git};
  22         my $obj = "$self->{ref}^0:$path";
  23         my $cur = $git->blob_to_simple($obj);
  24
  25         # do nothing if the messages match:
  26         return 0 if $git->simple_eq($cur, $new);
  27
  28         # kill the old blob
  29         $gii->remove($path);
  30
  31         # implicitly create a new tree via index with two messages
  32         foreach my $simple ($cur, $new) {
  33                 my $id = $git->simple_to_blob($simple);
  34                 my $path2 = $git->hash_simple2($simple);
  35                 $gii->update("100644", $id, "$path/$path2");
  36         }
  37         1;
  38 }
  39
  40 # used to update existing trees, which only happen when we have Message-ID
  41 # conflicts
  42 sub tree_update {
  43         my ($self, $gii, $new, $path) = @_;
  44         my $git = $self->{git};
  45         my $obj = "$self->{ref}^0:$path";
  46         my $cmd = "git ls-tree $obj";
  47         my @tree = `$cmd`;
  48         $? == 0 or die "$cmd failed: $!\n";
  49         chomp @tree;
  50
  51         my $id = $git->simple_to_blob($new);
  52         my $path2 = $git->hash_simple2($new);
  53
  54         # go through the existing tree and look for duplicates
  55         foreach my $line (@tree) {
  56                 $line =~ m!\A100644 blob ([a-f0-9]{40})\t(([a-f0-9]{40}))\z! or
  57                         die "corrupt repo: bad line from $cmd: $line\n";
  58                 my ($xid, $xpath2) = ($1, $2);
  59
  60                 # do nothing if most of the message matches
  61                 return 0 if $path2 eq $xpath2 || $id eq $xid;
  62         }
  63
  64         # no duplicates found, add to the index
  65         $gii->update("100644", $id, "$path/$path2");
  66 }
  67
  68 # this appends the given message-id to the git repo, requires locking
  69 # (Ssoma::Git::sync_do)
  70 sub append {
  71         my ($self, $path, $simple, $once) = @_;
  72
  73         my $git = $self->{git};
  74         my $ref = $self->{ref};
  75
  76         # $path is a path name we generated, so it's sanitized
  77         my $gii = Ssoma::GitIndexInfo->new;
  78
  79         my $obj = "$ref^0:$path";
  80         my $cmd = "git cat-file -t $obj";
  81         my $type = `$cmd 2>/dev/null`;
  82
  83         if ($? == 0) { # rare, object already exists
  84                 chomp $type;
  85                 if ($once) {
  86                         my $mid = $simple->header("Message-ID");
  87                         die "CONFLICT: Message-ID: $mid exists ($path)\n";
  88                 }
  89
  90                 # we return undef here if the message already exists
  91                 if ($type eq "blob") {
  92                         # this may upgrade the existing blob to a tree
  93                         $self->blob_upgrade($gii, $simple, $path) or return;
  94                 } elsif ($type eq "tree") {
  95                         # possibly add object to an existing tree
  96                         $self->tree_update($gii, $simple, $path) or return;
  97                 } else {
  98                         # we're screwed if a commit/tag has the same SHA-1
  99                         die "CONFLICT: `$cmd' returned: $type\n";
 100                 }
 101         } else { # new message, just create a blob, common
 102                 my $id = $git->simple_to_blob($simple);
 103                 $gii->update('100644', $id, $path);
 104         }
 105         my $subject = $simple->header("Subject");
 106         $git->commit_index($gii, 0, $ref, $subject);
 107 }
 108
 109 # the main entry point takes an Email::Simple object
 110 sub deliver {
 111         my ($self, $simple, $once) = @_;
 112         my $git = $self->{git};
 113
 114         # convert the Message-ID into a path
 115         my $mid = $simple->header("Message-ID");
 116
 117         # if there's no Message-ID, generate one to avoid too many conflicts
 118         # leading to trees
 119         if (!defined $mid || $mid =~ /\A\s*\z/) {
 120                 $mid = '<' . $git->hash_simple2($simple) . '@localhost>';
 121                 $simple->header_set("Message-ID", $mid);
 122         }
 123         my $path = $git->mid2path($mid);
 124
 125         # kill potentially confusing/misleading headers
 126         foreach my $d (qw(lines content-length)) {
 127                 $simple->header_set($d);
 128         }
 129
 130         my $sub = sub {
 131                 $git->tmp_index_do(sub {
 132                         $self->append($path, $simple, $once);
 133                 });
 134         };
 135         $git->sync_do(sub { $git->tmp_git_do($sub) });
 136 }
 137
 138 1;