diff options
Diffstat (limited to 'lib/JWebmail/Model/ReadMails/QMailAuthuser.pm')
| -rw-r--r-- | lib/JWebmail/Model/ReadMails/QMailAuthuser.pm | 267 |
1 files changed, 267 insertions, 0 deletions
diff --git a/lib/JWebmail/Model/ReadMails/QMailAuthuser.pm b/lib/JWebmail/Model/ReadMails/QMailAuthuser.pm new file mode 100644 index 0000000..8387217 --- /dev/null +++ b/lib/JWebmail/Model/ReadMails/QMailAuthuser.pm @@ -0,0 +1,267 @@ +package JWebmail::Model::ReadMails::QMailAuthuser; + +use v5.22; +use warnings; +use utf8; + +use IPC::Open2; +use File::Basename 'fileparse'; +use JSON::PP 'decode_json'; +use Params::Check 'check'; +use Scalar::Util 'blessed'; +use Role::Tiny::With; +use namespace::clean; + +with 'JWebmail::Model::ReadMails::Role'; + + +my $QMailAuthuserCheck = { + user => {defined => 1, required => 1}, + maildir => {defined => 1, required => 1}, + prefix => {defined => 1, default => ''}, + qmail_dir => {defined => 1, default => '/var/qmail/'}, + logfile => {defined => 1, default => '/dev/null'}, + prog => {defined => 1, default => ([fileparse(__FILE__)]->[1] . '/QMailAuthuser/Extract.pm')}, +}; + +sub new { + my $cls = shift; + my $self = @_ == 1 ? $_[0] : {@_}; + + if (my $pkg = blessed $cls) { + $self = {%$cls, %$self}; + $cls = $pkg; + } + $self = check($QMailAuthuserCheck, $self, 1) || die; + return bless $self, $cls; +} + +sub verify_user { + my $self = shift; + my $auth = shift; + + return !scalar $self->communicate( + user => $auth->{user}, + password => $auth->{password}, + challenge => $auth->{challenge}, + mode => 'auth', + ) +} + +sub read_headers_for { + my $self = shift; + my $auth = shift; + + my %h = @_; + my ($folder, $start, $end, $sort) = @h{qw(folder start end sort)}; + + my ($resp, $rc) = $self->communicate( + user => $auth->{user}, + password => $auth->{password}, + challenge => $auth->{challenge}, + mode => 'list', + args => [$start // 0, $end // 0, $sort // 'date', $folder // ''], + ); + die "connection error: $resp->{error}" if $rc; + return $resp; +} + +sub count { + my $self = shift; + + my ($auth, $folder) = @_; + + my ($resp, $rc) = $self->communicate( + user => $auth->{user}, + password => $auth->{password}, + challenge => $auth->{challenge}, + mode => 'count', + args => [$folder], + ); + die "connection error: $resp->{error}" if $rc; + return ($resp->{size}, $resp->{count}, $resp->{new}); +} + +sub show { + my $self = shift; + + my ($auth, $mid) = @_; + + my ($resp, $rc) = $self->communicate( + user => $auth->{user}, + password => $auth->{password}, + challenge => $auth->{challenge}, + mode => 'read-mail', + args => [$mid], + ); + die "connection error: $resp->{error}, $resp->{mid}" if $rc; + return $resp; +} + +sub search { + my $self = shift; + + my ($auth, $pattern, $folder) = @_; + + my ($resp, $rc) = $self->communicate( + user => $auth->{user}, + password => $auth->{password}, + challenge => $auth->{challenge}, + mode => 'search', + args => [$pattern, $folder], + ); + die "connection error: $resp->{error}" if $rc; + return $resp; +} + +sub folders { + my $self = shift; + + my ($auth) = @_; + + my ($resp, $rc) = $self->communicate( + user => $auth->{user}, + password => $auth->{password}, + challenge => $auth->{challenge}, + mode => 'folders', + ); + die "connection error: $resp->{error}" if $rc; + return $resp; +} + +sub move { + my $self = shift; + + my ($auth, $mid, $folder) = @_; + + my ($resp, $rc) = $self->communicate( + user => $auth->{user}, + password => $auth->{password}, + challenge => $auth->{challenge}, + mode => 'move', + args => [$mid, $folder], + ); + die "connection error: $resp->{error}" if $rc; + return 1; +} + +sub communicate { + my $self = shift; + my %args = @_; + + $args{challenge} //= ''; + $args{args} //= []; + + my $exec = do { + if ($args{mode} eq 'auth') { + $self->{qmail_dir} . "/bin/qmail-authuser true 3<&0"; + } + else { + my ($user_name) = $args{user} =~ /(\w*)@/; + + $self->{qmail_dir}.'/bin/qmail-authuser' + . $self->{prefix} . ' ' + . join(' ', map { s/(['\\])/\\$1/g; "'$_'" } ($self->{prog}, $self->{maildir}, $self->{user}, $user_name, $args{mode}, @{$args{args}})) + . ' 3<&0' + . ' 2>>'.$self->{logfile}; + } + }; + + my $pid = open2(my $reader, my $writer, $exec) + or die 'failed to create subprocess'; + + $writer->print("$args{user}\0$args{password}\0$args{challenge}\0") + or die 'pipe wite failed'; + close $writer + or die 'closing write pipe failed'; + + binmode $reader, ':utf8'; + my $input = <$reader>; + close $reader + or die 'closing read pipe failed'; + + waitpid($pid, 0); + my $rc = $? >> 8; + + my $resp; + if ($rc == 3 || $rc == 0) { + eval { $resp = decode_json $input; }; + if ($@) { $resp = {error => 'decoding error'} }; + } + elsif ($rc) { + $resp = {error => "qmail-authuser returned code: $rc"}; + } + + return ($resp, $rc); +} + +1 + +__END__ + +=encoding utf-8 + +=head1 NAME + +QMailAuthuser + +=head1 SYNOPSIS + + ... + +=head1 DESCRIPTION + +This ReadMails driver starts and communicates with L<JWebmail::Model::Driver::QMailAuthuser::Extract> over qmail-authuser. +The Extract programm runs with elevated priviliges to be able to read and modify mailboxes. + +=head1 ATTRIBUTES + +=head2 qmail_dir + +The parent directory of the bin directory where all qmail executables live. +Default C</var/qmail/>. + +=head2 prog + +The path to the extractor programm. +Default is the location of L<JWebmail::Model::Driver::QMailAuthuser::Extract> package. + +=head2 logfile + +A path to a log file that the extractor logs to. +Default '/dev/null' but highly recommended to set a real one. +Keep in mind that a different user need to be able to write to it. + +=head1 METHODS + +=head2 communicate + +Arguments: + +=over 6 + +=item mode + +=item args + +Depends on the mode + +=item user + +E-Mail address of the user + +=item password + +Corresponding e-mail user password + +=item challenge + +Challenge when using cram + +=back + +=head1 SEE ALSO + +L<JWebmail::Model::ReadMails>, L<JWebmail::Model::Driver::QMailAuthuser::Extract> + +=cut |