283 lines
7.5 KiB
Perl
283 lines
7.5 KiB
Perl
package GT::Maildir;
|
|
|
|
use vars qw/$error $ERRORS @EXPORT @EXPORT_OK %EXPORT_TAGS/;
|
|
use strict;
|
|
use warnings;
|
|
use base 'GT::Base';
|
|
|
|
sub ST_DEV() { 0 }
|
|
sub ST_INO() { 1 }
|
|
sub ST_MODE() { 2 }
|
|
sub ST_NLINK() { 3 }
|
|
sub ST_UID() { 4 }
|
|
sub ST_GID() { 5 }
|
|
sub ST_RDEV() { 6 }
|
|
sub ST_SIZE() { 7 }
|
|
sub ST_ATIME() { 8 }
|
|
sub ST_MTIME() { 9 }
|
|
sub ST_CTIME() { 10 }
|
|
sub ST_BLKSIZE() { 11 }
|
|
sub ST_BLOCKS() { 12 }
|
|
|
|
sub ST_NEW () { 1 }
|
|
sub ST_CUR () { 2 }
|
|
|
|
eval {
|
|
require Time::HiRes;
|
|
Time::HiRes->import;
|
|
};
|
|
use Cwd;
|
|
use Sys::Hostname;
|
|
use Carp qw/croak/;
|
|
use Exporter();
|
|
|
|
sub MAILDIR_DELIVERY_TIMEOUT() { 60 * 30 } # 30 minutes
|
|
|
|
$ERRORS = {
|
|
CHDIR => 'Could not chdir to %s: %s',
|
|
MKTMPFILE => 'Race condition creating tmp file for delivery to %s',
|
|
FILE_MISSING => "Wrote maildir tmp file but now it's gone; Possible file system troubles",
|
|
LINK => "Failed to link %s to %s: %s",
|
|
OVERQUOTA => "User is over thier maildir quota",
|
|
TIMEOUT => "Timed out on maildir delivery"
|
|
};
|
|
|
|
*import = \&Exporter::import;
|
|
$error = '';
|
|
|
|
@EXPORT = ();
|
|
@EXPORT_OK = qw(
|
|
ST_NEW
|
|
ST_CUR
|
|
st_to_string
|
|
|
|
ST_DEV
|
|
ST_INO
|
|
ST_MODE
|
|
ST_NLINK
|
|
ST_UID
|
|
ST_GID
|
|
ST_RDEV
|
|
ST_SIZE
|
|
ST_ATIME
|
|
ST_MTIME
|
|
ST_CTIME
|
|
ST_BLKSIZE
|
|
ST_BLOCKS
|
|
);
|
|
%EXPORT_TAGS = (
|
|
all => [@EXPORT_OK, @EXPORT],
|
|
stat => [qw/
|
|
ST_DEV
|
|
ST_INO
|
|
ST_MODE
|
|
ST_NLINK
|
|
ST_UID
|
|
ST_GID
|
|
ST_RDEV
|
|
ST_SIZE
|
|
ST_ATIME
|
|
ST_MTIME
|
|
ST_CTIME
|
|
ST_BLKSIZE
|
|
ST_BLOCKS
|
|
/],
|
|
status => [qw(ST_NEW ST_CUR st_to_string)]
|
|
);
|
|
|
|
sub init {
|
|
my $self = shift;
|
|
my $class = ref $self;
|
|
|
|
croak "Invalid arguments to $class->new. Arguments must be key/value pairs" if @_ & 1;
|
|
my %opts = @_;
|
|
$opts{ lc $_ } = delete $opts{$_} for keys %opts;
|
|
|
|
croak "No Path specified to $class->new" unless exists $opts{path};
|
|
my $path = delete $opts{path};
|
|
croak "Invalid maildir path specified to $class->new" unless defined $path and length $path;
|
|
my $locker = delete $opts{locker};
|
|
unless ($locker) {
|
|
require GT::Maildir::Lock::NFSLock;
|
|
$locker = GT::Maildir::Lock::NFSLock->new;
|
|
}
|
|
my $subdir = delete $opts{subdir};
|
|
my $maildir_subdir = delete $opts{maildirsubdir};
|
|
|
|
$self->{_debug} = exists $opts{debug} ? delete $opts{debug} : $GT::Maildir::DEBUG;
|
|
|
|
croak "Unknown arguments to $class->new: ", join(", ", keys %opts) if keys %opts;
|
|
|
|
$self->{path} = $path;
|
|
$self->{maildir_subdir} = $maildir_subdir || 'Maildir';
|
|
$self->{subdir} = $subdir || 'gt';
|
|
$self->{locker} = $locker;
|
|
}
|
|
|
|
sub st_to_string {
|
|
my $st = shift;
|
|
return $st == ST_NEW ? "new" : "cur";
|
|
}
|
|
|
|
sub make_maildir_root {
|
|
my $self = shift;
|
|
croak "Unknown arguments to $self->make_maildir: ", join(", ", @_) if @_;
|
|
my $path = $self->get_maildir_path;
|
|
my $config_path = $self->get_config_path;
|
|
$self->get_locker->ex_lock($path, 60*5, 60*20);
|
|
unless (-d $path) {
|
|
unlink $path;
|
|
mkdir $path, 0700 or return $self->error("MKDIR", "WARN", $path, "$!");
|
|
}
|
|
for (qw(cur new tmp)) {
|
|
unless (-d "$path/$_") {
|
|
unlink "$path/$_";
|
|
mkdir "$path/$_", 0700 or return $self->error("MKDIR", "WARN", "$path/$_", "$!");
|
|
}
|
|
}
|
|
unless (-d $config_path) {
|
|
unlink $config_path;
|
|
mkdir $config_path, 0700 or return $self->error("MKDIR", "WARN", $path, "$!");
|
|
}
|
|
$self->get_locker->unlock($path);
|
|
return 1;
|
|
}
|
|
|
|
my $Maildir_Message_Number = 0;
|
|
sub deliver_message {
|
|
my $self = shift;
|
|
my $folder = shift;
|
|
my $folder_name = UNIVERSAL::isa($folder, "GT::Maildir::Folder")
|
|
? $folder->get_name
|
|
: $folder;
|
|
croak "Invalid folder $folder_name"
|
|
unless !ref($folder_name)
|
|
and defined $folder_name
|
|
and length $folder_name;
|
|
my $mail_thingy = shift;
|
|
my $mail_writer = UNIVERSAL::isa($mail_thingy, "GT::Mail")
|
|
? sub { $mail_thingy->write(shift) or die "$GT::Mail::error" }
|
|
: (!ref($mail_thingy) and -e $mail_thingy)
|
|
? sub { require GT::File::Tools; GT::File::Tools::copy($mail_thingy, shift) or die "$GT::File::Tools::error" }
|
|
: undef;
|
|
croak "Unknown email input $mail_thingy" unless defined $mail_writer;
|
|
my $quotastr = shift;
|
|
|
|
my $flags = join '', map { uc substr($_, 0, 1) } grep { defined and /^[DFRST]/i } @_;
|
|
|
|
my $path = $self->get_maildir_path;
|
|
my $folder_path = "$path/$folder_name";
|
|
my $cwd = getcwd || cwd || die "Could not get cwd";
|
|
unless (ref $mail_thingy) {
|
|
if ($mail_thingy !~ m{^/}) {
|
|
$mail_thingy = "$cwd/$mail_thingy";
|
|
}
|
|
}
|
|
chdir $folder_path or return $self->error("CHDIR", "WARN", $folder_path, "$!");
|
|
local $@;
|
|
eval {
|
|
local $SIG{__DIE__};
|
|
alarm 0;
|
|
};
|
|
my $can_alarm = $@ ? 0 : 1;
|
|
local $SIG{ALRM} = sub { die "TIMEOUT\n" };
|
|
my $pid = $$;
|
|
my $host = hostname;
|
|
$Maildir_Message_Number++;
|
|
|
|
my $tmpfile;
|
|
for (my $i = 0; ; $i++) {
|
|
my $t = time;
|
|
$tmpfile = "tmp/$t.$pid.$Maildir_Message_Number.$host";
|
|
if (!stat($tmpfile) and $! == 2) { # ENOENT
|
|
last;
|
|
}
|
|
if ($i == 2) {
|
|
return $self->error("MKTMPFILE", "WARN", "$folder_path/$tmpfile");
|
|
}
|
|
sleep 2;
|
|
}
|
|
if ($can_alarm) {
|
|
alarm(MAILDIR_DELIVERY_TIMEOUT);
|
|
}
|
|
my $newfile;
|
|
eval {
|
|
$mail_writer->($tmpfile);
|
|
undef $mail_thingy;
|
|
undef $mail_writer;
|
|
my @st = stat $tmpfile;
|
|
die "FILE_MISSING\n" unless @st;
|
|
if ($st[ST_SIZE] != 0 and $quotastr and $quotastr ne "NOQUOTA") {
|
|
require GT::Maildir::Quota;
|
|
my $q = GT::Maildir::Quota->open(".", $quotastr) or die "$GT::Maildir::Quota::error\n";
|
|
if (!$q->test($st[ST_SIZE], 1)) {
|
|
die "$GT::Maildir::Quota::error\n" if $GT::Maildir::Quota::error;
|
|
die "OVERQUOTA\n";
|
|
}
|
|
$q->add($st[ST_SIZE], 1);
|
|
$q->close();
|
|
}
|
|
my $new_tmp = "$tmpfile,S=$st[ST_SIZE]:2,$flags";
|
|
if (!rename($tmpfile, $new_tmp)) {
|
|
$self->error("RENAME", "FATAL", $tmpfile, $new_tmp, "$!");
|
|
}
|
|
$newfile = $new_tmp;
|
|
$newfile =~ s/tmp/new/;
|
|
|
|
if (!link($new_tmp, $newfile)) {
|
|
$self->error("LINK", "FATAL", $new_tmp, $newfile, "$!");
|
|
}
|
|
unlink $new_tmp;
|
|
};
|
|
if ($can_alarm) {
|
|
alarm 0;
|
|
}
|
|
if ($@) {
|
|
my $err = $@;
|
|
$err =~ s/\n//g;
|
|
chdir $cwd;
|
|
return $self->error($err, "WARN");
|
|
}
|
|
chdir $cwd;
|
|
return $newfile;
|
|
}
|
|
|
|
sub get_locker {
|
|
my $self = shift;
|
|
croak "Unknown arguments to $self->get_locker: ", join(", ", @_) if @_;
|
|
return $self->{locker};
|
|
}
|
|
|
|
sub get_path {
|
|
my $self = shift;
|
|
croak "Unknown arguments to $self->get_path: ", join(", ", @_) if @_;
|
|
return $self->{path};
|
|
}
|
|
|
|
sub get_subdir {
|
|
my $self = shift;
|
|
croak "Unknown arguments to $self->get_subdir: ", join(", ", @_) if @_;
|
|
return $self->{subdir};
|
|
}
|
|
|
|
sub get_maildir_subdir {
|
|
my $self = shift;
|
|
croak "Unknown arguments to $self->get_maildir_subdir: ", join(", ", @_) if @_;
|
|
return $self->{maildir_subdir};
|
|
}
|
|
|
|
sub get_maildir_path {
|
|
my $self = shift;
|
|
croak "Unknown arguments to $self->get_subdir: ", join(", ", @_) if @_;
|
|
return $self->{path} . "/" . $self->{maildir_subdir};
|
|
}
|
|
|
|
sub get_config_path {
|
|
my $self = shift;
|
|
croak "Unknown arguments to $self->get_subdir: ", join(", ", @_) if @_;
|
|
return $self->{path} . "/" . $self->{subdir};
|
|
}
|
|
|
|
1;
|
|
|