diff options
author | Jannis M. Hoffmann <jannis.hoffmann@rwth-aachen.de> | 2020-10-29 12:13:04 +0100 |
---|---|---|
committer | Jannis M. Hoffmann <jannis.hoffmann@rwth-aachen.de> | 2020-10-29 12:13:04 +0100 |
commit | ee43823179ee627ac16ea9da8168e5f1bf9619c0 (patch) | |
tree | 5e6c36d5629d2ce79f3cb1310998dc715a6f19c7 /lib |
Initial commit; Stable version
Diffstat (limited to 'lib')
-rw-r--r-- | lib/JWebmail.pm | 108 | ||||
-rw-r--r-- | lib/JWebmail/Controller/Webmail.pm | 386 | ||||
-rw-r--r-- | lib/JWebmail/Model/Driver/Mock.pm | 102 | ||||
-rw-r--r-- | lib/JWebmail/Model/Driver/QMailAuthuser.pm | 142 | ||||
-rwxr-xr-x | lib/JWebmail/Model/Driver/QMailAuthuser/Extract.pm | 293 | ||||
-rw-r--r-- | lib/JWebmail/Model/ReadMails.pm | 227 | ||||
-rw-r--r-- | lib/JWebmail/Model/WriteMails.pm | 143 | ||||
-rw-r--r-- | lib/JWebmail/Plugin/Helper.pm | 448 | ||||
-rw-r--r-- | lib/JWebmail/Plugin/I18N.pm | 212 | ||||
-rw-r--r-- | lib/JWebmail/Plugin/I18N2.pm | 185 | ||||
-rw-r--r-- | lib/JWebmail/Plugin/INIConfig.pm | 136 | ||||
-rw-r--r-- | lib/JWebmail/Plugin/ServerSideSessionData.pm | 147 |
12 files changed, 2529 insertions, 0 deletions
diff --git a/lib/JWebmail.pm b/lib/JWebmail.pm new file mode 100644 index 0000000..7275891 --- /dev/null +++ b/lib/JWebmail.pm @@ -0,0 +1,108 @@ +package JWebmail v1.0.0; + +use Mojo::Base 'Mojolicious'; + +use JWebmail::Controller::Webmail; +use JWebmail::Model::ReadMails; +use JWebmail::Model::Driver::QMailAuthuser; +use JWebmail::Model::Driver::Mock; +use JWebmail::Model::WriteMails; + + +sub startup { + my $self = shift; + + $self->moniker('jwebmail'); + + # load plugins + push @{$self->plugins->namespaces}, 'JWebmail::Plugin'; + + $self->plugin('INIConfig'); + $self->plugin('ServerSideSessionData'); + $self->plugin('Helper'); + $self->plugin('I18N', $self->config('i18n') // {}); + + $self->secrets( [$self->config('secret')] ) if $self->config('secret'); + delete $self->config->{secret}; + + # initialize models + $self->helper(users => sub { + state $x = JWebmail::Model::ReadMails->new( + driver => $self->config->{development}{use_read_mock} + ? JWebmail::Model::Driver::Mock->new() + : JWebmail::Model::Driver::QMailAuthuser->new( + logfile => $self->home->child('log', 'extract.log'), + %{ $self->config->{model}{read}{driver} // {} }, + ) + ); + }); + $self->helper(send_mail => sub { my ($c, $mail) = @_; JWebmail::Model::WriteMails::sendmail($mail) }); + $JWebmail::Model::WriteMails::Block_Writes = 1 if $self->config->{development}{block_writes}; + + # add helper and stash values + $self->defaults(version => __PACKAGE__->VERSION); + + $self->route(); +} + + +sub route { + my $self = shift; + + my $r = shift || $self->routes; + + $r->get('/' => 'noaction')->to('Webmail#noaction'); + $r->get('/about')->to('Webmail#about'); + $r->post('/login')->to('Webmail#login'); + $r->get('/logout')->to('Webmail#logout'); + + my $a = $r->under('/')->to('Webmail#auth'); + $a->get('/home/:folder')->to('Webmail#displayheaders', folder => '')->name('displayheaders'); + $a->get('/read/#id' => 'read')->to('Webmail#readmail'); + $a->get('/write')->to('Webmail#writemail'); + $a->post('/write' => 'send')-> to('Webmail#sendmail'); + $a->post('/move')->to('Webmail#move'); + $a->get('/raw/#id')->to('Webmail#raw'); +} + + +1 + +__END__ + +=encoding utf-8 + +=head1 NAME + +JWebmail - Provides a web based e-mail client meant to be used with s/qmail. + +=head1 SYNOPSIS + + hypnotoad script/jwebmail + +And use a server in reverse proxy configuration. + +=head1 DESCRIPTION + +=head1 CONFIGURATION + +Use the jwebmail.conf file. + +=head1 AUTHORS + +Copyright (C) 2020 Jannis M. Hoffmann L<jannis@fehcom.de> + +=head1 BASED ON + +Copyright (C) 2001 Olivier Müller L<om@omnis.ch> (GPLv2+ project: oMail Webmail) + +Copyright (C) 2000 Ernie Miller (GPL project: Neomail) + +See the CREDITS file for project contributors. + +=head1 LICENSE + +This module is licensed under the terms of the GPLv3 or any later version at your option. +Please take a look at the provided LICENSE file shipped with this module. + +=cut
\ No newline at end of file diff --git a/lib/JWebmail/Controller/Webmail.pm b/lib/JWebmail/Controller/Webmail.pm new file mode 100644 index 0000000..3ec93f1 --- /dev/null +++ b/lib/JWebmail/Controller/Webmail.pm @@ -0,0 +1,386 @@ +package JWebmail::Controller::Webmail; + +use Mojo::Base 'Mojolicious::Controller'; + +use File::Type; + +use constant { + S_USER => 'user', # Key for user name in active session +}; + + +# no action has been taken, display login page +sub noaction { + my $self = shift; + + my $user = $self->session(S_USER); + if ($user) { + $self->res->code(307); + $self->redirect_to('home'); + } +} + + +# middleware +sub auth { + my $self = shift; + + my $user = $self->session(S_USER); + my $pw = $self->session_passwd; + + unless ($user && $pw) { + $self->flash(message => $self->l('no_session')); + $self->res->code(401); + $self->redirect_to('logout'); + return 0; + } + + return 1; +} + + +sub _time :prototype(&$$) { + my $code = shift; + my $self = shift; + my $name = shift; + + $self->timing->begin($name); + + my @res = $code->(); + + my $elapsed = $self->timing->elapsed($name); + $self->app->log->debug("$name took $elapsed seconds"); + + return wantarray ? @res : $res[-1]; +} + + +sub login { + my $self = shift; + + my $v = $self->validation; + + my $user = $v->required('userid')->size(4, 50)->param; + my $passwd = $v->required('password')->size(4, 50)->like(qr/^.+$/)->param; # no new-lines + + if ($v->has_error) { + $self->res->code(400); + return $self->render(action => 'noaction'); + } + + my $valid = _time { $self->users->verify_user($user, $passwd) } $self, 'verify user'; + + if ($valid) { + $self->session(S_USER() => $user); + $self->session_passwd($passwd); + + $self->res->code(303); + $self->redirect_to('displayheaders'); + } + else { + $self->res->code(401); + $self->render(action => 'noaction', + warning => $self->l('login') . ' ' . $self->l('failed') . '!', + ); + } +} + + +sub logout { + my $self = shift; + + delete $self->session->{S_USER()}; + $self->session_passwd(''); + + # $self->session(expires => 1); + + $self->res->code(303); + $self->redirect_to('noaction'); +} + + +sub about { + my $self = shift; + + $self->stash( + scriptadmin => $self->config->{defaults}{scriptadmin}, + http_host => $self->tx->req->url->to_abs->host, + request_uri => $self->tx->req->url, + remote_addr => $self->tx->original_remote_address, + ); +} + + +sub displayheaders { + no warnings 'experimental::smartmatch'; + my $self = shift; + + my $auth = AuthReadMails->new( + user => $self->session(S_USER), + password => $self->session_passwd, + challenge => $self->app->secrets->[0], + ); + + my $folders = _time { $self->users->folders($auth) } $self, 'user folders'; + push @$folders, ''; + + unless ( $self->stash('folder') ~~ $folders ) { + $self->res->code(404); + $self->render(template => 'error', + error => $self->l('no_folder'), + links => [map { $self->url_for(folder => $_) } @$folders], + ); + return; + } + + my $v = $self->validation; + my $sort = $v->optional('sort')->like(qr'^!?(?:date|subject|sender|size)$')->param // '!date'; + my $search = $v->optional('search')->param; + + if ($v->has_error) { + $self->res->code(400); + $self->render(template => 'error', error => "errors in @{ $v->failed }"); + return; + } + + my ($total_byte_size, $cnt, $new) = _time { $self->users->count($auth, $self->stash('folder')) } $self, 'user count'; + + my ($start, $end) = $self->paginate($cnt); + + $self->timing->begin('user_headers'); + my $headers; + if ($search) { + $headers = $self->users->search( + $auth, $search, $self->stash('folder'), + ); + } + else { + $headers = $self->users->read_headers_for( + auth => $auth, + folder => $self->stash('folder'), + start => $start, + end => $end, + sort => $sort, + ); + } + my $elapsed = $self->timing->elapsed('user_headers'); + $self->app->log->debug("Reading user headers took $elapsed seconds"); + + $self->stash( + msgs => $headers, + mail_folders => $folders, + total_size => $total_byte_size, + total_new_mails => $new, + ); +} + + +sub readmail { + my $self = shift; + + my $mid = $self->stash('id'); + + my $auth = AuthReadMails->new( + user => $self->session(S_USER), + password => $self->session_passwd, + challenge => $self->app->secrets->[0], + ); + + my $mail; + eval { $mail = $self->users->show($auth, $mid) }; + if (my $err = $@) { + if ($err =~ m/unkown mail-id|no such message/) { + $self->reply->not_found; + return; + } + die $@; + } + + $self->render(action => 'readmail', + msg => $mail, + ); +} + + +sub writemail { } + + +sub sendmail { + my $self = shift; + + my %mail; + my $v = $self->validation; + $v->csrf_protect; + + $mail{to} = $v->required('to', 'not_empty')->check('mail_line')->every_param; + $mail{message} = $v->required('body', 'not_empty')->param; + $mail{subject} = $v->required('subject', 'not_empty')->param; + $mail{cc} = $v->optional('cc', 'not_empty')->check('mail_line')->every_param; + $mail{bcc} = $v->optional('bcc', 'not_empty')->check('mail_line')->every_param; + $mail{reply} = $v->optional('back_to', 'not_empty')->check('mail_line')->param; + $mail{attach} = $v->optional('attach', 'non_empty_ul')->upload->param; + $mail{attach_type} = File::Type->new()->mime_type($mail{attach}->asset->get_chunk(0, 512)) if $mail{attach}; + $mail{from} = $self->session(S_USER); + + if ($v->has_error) { + $self->log->debug("mail send failed. Error in @{ $v->failed }"); + + $self->render(action => 'writemail', + warning => $self->l('error_send'), + ); + return; + } + + my $error = $self->send_mail(\%mail); + + if ($error) { + $v->error('send'=> ['internal_error']); # make validation fail so that values are restored + + $self->render(action => 'writemail', + warning => $self->l('error_send'), + ); + return; + } + + $self->flash(message => $self->l('succ_send')); + $self->res->code(303); + $self->redirect_to('displayheaders'); +} + + +sub move { + my $self = shift; + + my $v = $self->validation; + $v->csrf_protect; + + if ($v->has_error) { + return; + } + + my $auth = AuthReadMails->new( + user => $self->session(S_USER), + password => $self->session_passwd, + challenge => $self->app->secrets->[0], + ); + my $folders = $self->users->folders($auth); + + my $mm = $self->every_param('mail'); + my $folder = $self->param('folder'); + + no warnings 'experimental::smartmatch'; + die "$folder not valid" unless $folder ~~ $folders; + + $self->users->move($auth, $_, $folder) for @$mm; + + $self->flash(message => $self->l('succ_move')); + $self->res->code(303); + $self->redirect_to('displayheaders'); +} + + +sub raw { + my $self = shift; + + my $mid = $self->stash('id'); + + my $auth = AuthReadMails->new( + user => $self->session(S_USER), + password => $self->session_passwd, + challenge => $self->app->secrets->[0], + ); + + my $mail = $self->users->show($auth, $mid); + + if ($self->param('body')//'' eq 'html') { + if ($mail->{content_type} eq 'text/html') { + $self->render(text => $mail->{body}) ; + } + elsif ($mail->{content_type} eq 'multipart/alternative') { + my ($content) = grep {$_->{type} eq 'text/html'} @{ $mail->{body} }; + $self->render(text => $content->{val}); + } + else { + $self->res->code(404); + } + } + else { + $self->res->headers->content_type('text/plain'); + $self->render(text => $self->dumper($mail)); + } +} + + +1 + +__END__ + +=encoding utf-8 + +=head1 NAME + +Webmail - All functions comprising the webmail application. + +=head1 SYNOPSIS + + my $r = $app->routes; + $r->get('/about')->to('Webmail#about'); + $r->post('/login')->to('Webmail#login'); + +=head1 DESCRIPTION + +The controller of JWebmail. + +=head1 METHODS + +=head2 noaction + +The login page. This should be the root. + +=head2 auth + + my $a = $r->under('/')->to('Webmail#auth'); + + An intermediate route that makes sure a user has a valid session. + +=head2 login + +Post route that checks login data. + +=head2 logout + +Route that clears session data. + +=head2 about + +Public route. + +=head2 displayheaders + +Provides an overview over messages. + +=head2 readmail + +Displays a single mail. + +=head2 writemail + +A mail editor. + +=head2 sendmail + +Sends a mail written in writemail. + +=head2 move + +Moves mails between mail forlders. + +=head2 raw + +Displays the mail raw, ready to be downloaded. + +=head1 DEPENCIES + +Mojolicious and File::Type + +=cut
\ No newline at end of file diff --git a/lib/JWebmail/Model/Driver/Mock.pm b/lib/JWebmail/Model/Driver/Mock.pm new file mode 100644 index 0000000..eb8c0d0 --- /dev/null +++ b/lib/JWebmail/Model/Driver/Mock.pm @@ -0,0 +1,102 @@ +package JWebmail::Model::Driver::Mock; + +use Mojo::Base -base; + +use List::Util 'sum'; + +use Mojo::JSON qw(decode_json); + + +use constant { + VALID_USER => 'me@example.de', + VALID_PW => 'vwxyz', +}; + +use constant { + LIST_START => 0, + LIST_END => 1, + LIST_SORT => 2, + LIST_FOLDER => 3, +}; + +sub _read_json_file { + my ($file_name) = @_; + + open(my $body_file, '<', $file_name); + local $/; + my $body = <$body_file>; + close $body_file; + + return decode_json($body); +} + + +sub list_reply { + state $init = _read_json_file('msgs.json'); +} +sub read_reply { + state $init = { + 'SC-ORD-MAIL54526c63b751646618a793be3f8329cca@sc-ord-mail5' => _read_json_file('msg2.json'), + 'example' => _read_json_file('msg.json'), + }; +} + + +sub communicate { + no warnings 'experimental::smartmatch'; + + my $self = shift; + + my %args = @_; + + given ($args{mode}) { + when ('auth') { + return (undef, 0) if $args{user} eq VALID_USER && $args{password} eq VALID_PW; + return (undef, 2); + } + when ('list') { + return ([@{ $self->list_reply }[$args{args}->[LIST_START]..$args{args}->[LIST_END]]], 0) if !$args{args}->[LIST_SORT]; + return ([], 0) if $args{args}->[LIST_FOLDER] eq 'test'; + my $s = sub { + my $sort_by = $args{args}->[LIST_SORT]; + my $rev = $sort_by !~ m/^![[:lower:]]+/ ? 1 : -1; + $sort_by =~ s/!//; + return ($a->{$sort_by} cmp $b->{$sort_by}) * $rev; + }; + return ([sort { &$s } @{ $self->list_reply }[$args{args}->[LIST_START]..$args{args}->[LIST_END]]], 0); + } + when ('count') { + return ({ + count => scalar(@{ $self->list_reply }), + size => sum(map {$_->{size}} @{ $self->list_reply }), + new => 0, + }, 0); + } + when ('read-mail') { + my $mid = $args{args}->[0]; + my $mail = $self->read_reply->{$mid}; + return ($mail, 0) if $mail; + return ({error => 'unkown mail-id'}, 3); + } + when ('folders') { + return ([qw(cur test devel debug)], 0); + } + when ('move') { + local $, = ' '; + say "@{ $args{args} }"; + return (undef, 0); + } + default { return ({error => 'unkown mode'}, 3); } + } +} + + +1 + +__END__ + +=head1 NAME + +Mock - Simple file based mock for the L<JWebmail::Model::ReadMails> module. + +=cut
\ No newline at end of file diff --git a/lib/JWebmail/Model/Driver/QMailAuthuser.pm b/lib/JWebmail/Model/Driver/QMailAuthuser.pm new file mode 100644 index 0000000..65e90f1 --- /dev/null +++ b/lib/JWebmail/Model/Driver/QMailAuthuser.pm @@ -0,0 +1,142 @@ +package JWebmail::Model::Driver::QMailAuthuser; + +use Mojo::Base -base; + +use IPC::Open2; +use File::Basename 'fileparse'; +use JSON::PP; + + +has 'user'; +has 'maildir'; +has 'include'; +has qmail_dir => '/var/qmail/'; +has prog => [fileparse(__FILE__)]->[1] . '/QMailAuthuser/Extract.pm'; +has logfile => '/dev/null'; + + +sub communicate { + use autodie; + + 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' + . ' perl ' + . join('', map { ' -I ' . $_ } @{ $self->include }) + . ' -- ' + . 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 + + my $m = JWebmail::Model::ReadMails->new(driver => JWebmail::Model::Driver::QMailAuthuser->new(...)); + +=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 + +User name + +=item password + +User password + +=item challenge + +Challenge when using cram + +=back + +=head1 SEE ALSO + +L<JWebmail::Model::ReadMails>, L<JWebmail::Model::Driver::QMailAuthuser::Extract> + +=cut
\ No newline at end of file diff --git a/lib/JWebmail/Model/Driver/QMailAuthuser/Extract.pm b/lib/JWebmail/Model/Driver/QMailAuthuser/Extract.pm new file mode 100755 index 0000000..30ac4e9 --- /dev/null +++ b/lib/JWebmail/Model/Driver/QMailAuthuser/Extract.pm @@ -0,0 +1,293 @@ +package JWebmail::Model::Driver::QMailAuthuser::Extract; + +use v5.18; +use strict; +use warnings; +use utf8; + +use POSIX (); +use JSON::PP; +use Carp; +use Encode v2.88 qw(decode); + +use open IO => ':encoding(UTF-8)', ':std'; +no warnings 'experimental::smartmatch'; + +use Mail::Box::Manager; + +use constant { + ROOT_MAILDIR => '.', +}; + + +sub main { + my ($maildir) = shift(@ARGV) =~ m/(.*)/; + my ($su) = shift(@ARGV) =~ m/(.*)/; + my ($user) = shift(@ARGV) =~ m/([[:alpha:]]+)/; + my $mode = shift @ARGV; _ok($mode =~ m/([[:alpha:]-]{1,20})/); + my @args = @ARGV; + + delete $ENV{PATH}; + + my $netfehcom_uid = getpwnam($su); + #$> = $netfehcom_uid; + die "won't stay as root" if $netfehcom_uid == 0; + POSIX::setuid($netfehcom_uid); + if ($!) { + warn 'error setting uid'; + exit(1); + } + + my $folder = Mail::Box::Manager->new->open( + folder => "$maildir/$user/", + type => 'maildir', + access => 'rw', + ); + + my $reply = do { + given ($mode) { + when('list') { list($folder, @args) } + when('read-mail') { read_mail($folder, @args) } + when('count') { count_messages($folder, @args) } + when('search') { search($folder, @args) } + when('folders') { folders($folder, @args) } + when('move') { move($folder, @args) } + default { {error => 'unkown mode', mode => $mode} } + } + }; + $folder->close; + + print encode_json $reply; + if (ref $reply eq 'HASH' && $reply->{error}) { + exit 3; + } +} + + +sub _sort_mails { + my $sort = shift // ''; + my $reverse = 1; + + if ($sort =~ m/^!/) { + $reverse = -1; + $sort = substr $sort, 1; + } + + given ($sort) { + when ('date') { return sub { ($a->timestamp <=> $b->timestamp) * $reverse } } + when ('sender') { return sub { ($a->from->[0] cmp $b->from->[0]) * $reverse } } + when ('subject') { return sub { ($a->subject cmp $b->subject) * $reverse } } + when ('size') { return sub { ($a->size <=> $b->size) * $reverse } } + when ('') { return sub { ($a->timestamp <=> $b->timestamp) * $reverse } } + default { warn "unkown sort-verb '$sort'"; return sub { ($a->timestamp <=> $b->timestamp) * $reverse } } + } +} + + +sub _ok { + if (!shift) { + carp 'verify failed'; + exit 4; + } +} + + +sub list { + my ($f, $start, $end, $sortby, $folder) = @_; + $folder = ".$folder"; + + _ok($start =~ m/^\d+$/); + _ok($end =~ m/^\d+$/); + _ok(0 <= $start && $start <= $end); + _ok($sortby =~ m/^(!?\w+|\w*)$/n); + _ok($folder ~~ [$f->listSubFolders, ROOT_MAILDIR]); + + $f = $f->openSubFolder($folder) if $folder ne ROOT_MAILDIR; + + return [] if $start == $end; + + my $sref = _sort_mails($sortby); + my @msgs = $f->messages; + @msgs = sort { &$sref } @msgs; + @msgs = @msgs[$start..$end]; + + my @msgs2; + + for my $msg (@msgs) { + my $msg2 = { + #subject => scalar decode_mimewords($msg->subject), + subject => decode('MIME-Header', $msg->subject), + from => _addresses($msg->from), + to => _addresses($msg->to), + cc => _addresses($msg->cc), + bcc => _addresses($msg->bcc), + date => _iso8601_utc($msg->timestamp), + size => $msg->size, + content_type => ''. $msg->contentType, + mid => $msg->messageId, + new => $msg->label('seen'), + }; + push @msgs2, $msg2; + } + + return \@msgs2; +} + + +sub count_messages { + my ($f, $folder) = @_; + $folder = ".$folder"; + + _ok($folder ~~ [$f->listSubFolders, ROOT_MAILDIR]); + + $f = $f->openSubFolder($folder) if $folder ne ROOT_MAILDIR; + + return { + count => scalar($f->messages('ALL')), + size => $f->size, + new => scalar $f->messages('!seen'), + } +} + + +sub _iso8601_utc { + my @date_time = gmtime(shift); + $date_time[5] += 1900; + $date_time[4]++; + return sprintf('%6$04d-%5$02d-%4$02dT%3$02d:%2$02d:%1$02dZ', @date_time); +} + +sub _unquote { my $x = shift; [$x =~ m/"(.*?)"(?<!\\)/]->[0] || $x } + +sub _addresses { + [map { {address => $_->address, name => _unquote(decode('MIME-Header', $_->phrase))} } @_] +} + + +sub read_mail { + my ($folder, $mid) = @_; + + my $msg = $folder->find($mid); + return {error => 'no such message', mid => $mid} unless $msg; + return { + subject => decode('MIME-Header', $msg->subject), + from => _addresses($msg->from), + to => _addresses($msg->to), + cc => _addresses($msg->cc), + bcc => _addresses($msg->bcc), + date => _iso8601_utc($msg->timestamp), + size => $msg->size, + content_type => ''. $msg->contentType, + body => do { + if ($msg->isMultipart) { + [map {{type => ''. $_->contentType, val => '' . $_->decoded}} $msg->body->parts] + } + else { + '' . $msg->body->decoded + } + }, + } +} + + +sub search { + my $f = shift; + my $search_pattern = shift; + my $folder = shift; + $folder = ".$folder"; + + $f = $f->openSubFolder($folder) if $folder ne ROOT_MAILDIR; + + my @msgs = $f->messages(sub { + my $m = shift; + + return scalar(grep { $_->decoded =~ /$search_pattern/ || (decode('MIME-Header', $_->subject)) =~ /$search_pattern/ } $m->body->parts) + if $m->isMultipart; + $m->body->decoded =~ /$search_pattern/ ||(decode('MIME-Header', $m->subject)) =~ /$search_pattern/; + }); + + my @msgs2; + for my $msg (@msgs) { + my $msg2 = { + subject => decode('MIME-Header', $msg->subject), + from => _addresses($msg->from), + to => _addresses($msg->to), + cc => _addresses($msg->cc), + bcc => _addresses($msg->bcc), + date => _iso8601_utc($msg->timestamp), + size => $msg->size, + content_type => ''. $msg->contentType, + mid => $msg->messageId, + }; + push @msgs2, $msg2; + } + + return \@msgs2; +} + + +sub folders { + my $f = shift; + + return [grep { $_ =~ m/^\./ && $_ =~ s/\.// && 1 } $f->listSubFolders]; +} + + +sub move { + my ($f, $mid, $dst) = @_; + $dst = ".$dst"; + + _ok($dst ~~ [$f->listSubFolders, ROOT_MAILDIR]); + + $f->moveMessage($dst, $dst->find($mid)); +} + + +main() if !caller; + +1 + +__END__ + +=encoding utf-8 + +=head1 NAME + +JWebmail::Model::Driver::QMailAuthuser::Extract - Maildir reader + +=head1 SYNOPSIS + +Extract delivers information about emails. +Runs with elevated priviliges. + +=head1 DESCRIPTION + +This programm is started by qmail-authuser with elevated priviliges after +a succsessful login. +Input directives are provided as command line arguments. +Output is delivered via STDOUT and log information via STDERR. + +=head1 ARGUMENTS + + prog <maildir> <system-user> <mail-user> <mode> <args...> + +=head2 Modes + + list <start> <end> <sort-by> <folder> + count <folder> + read-mail <mid> + search <pattern> <folder> + folders + move <mid> <dst-folder> + +All arguments must be supplied for a given mode even if empty (as ''). + +=head1 DEPENDENCIES + +Currently Mail::Box::Manager does all the hard work. + +=head1 SEE ALSO + +L<JWebmail::Model::Driver::QMailAuthuser> + +=cut
\ No newline at end of file diff --git a/lib/JWebmail/Model/ReadMails.pm b/lib/JWebmail/Model/ReadMails.pm new file mode 100644 index 0000000..0f2e1cc --- /dev/null +++ b/lib/JWebmail/Model/ReadMails.pm @@ -0,0 +1,227 @@ +package JWebmail::Model::ReadMails; + +use Mojo::Base -base; + +use Class::Struct AuthReadMails => { + user => '$', + password => '$', + challenge => '$', +}; + + +has 'driver'; + + +sub verify_user { + + my $self = shift; + + my ($user, $password) = @_; + + return !scalar $self->driver->communicate( + user => $user, + password => $password, + mode => 'auth', + ) +} + + +sub read_headers_for { + + my $self = shift; + + my %h = @_; + my ($auth, $folder, $start, $end, $sort) = @h{qw(auth folder start end sort)}; + + my ($resp, $rc) = $self->driver->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->driver->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->driver->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->driver->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->driver->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->driver->communicate( + user => $auth->user, + password => $auth->password, + challenge => $auth->challenge, + mode => 'move', + args => [$mid, $folder], + ); + die "connection error: $resp->{error}" if $rc; + return 1; +} + + +1 + +__END__ + +=encoding utf-8 + +=head1 NAME + +ReadMails - Read recieved mails + +=head1 SYNOPSIS + + my $m = JWebmail::Model::ReadMails->new(driver => ...); + $m->search($auth, qr/Hot singles in your area/, ''); + +=head1 DESCRIPTION + +This module is a facade for the actions of its driver. +All actions are delegated to it. + +The first parameter is authentication info as AuthReadMails +whith the rest varying. + +The communication is stateless. + +=head1 ATTRIBUTES + +=head2 driver + +The driver does the actual work of reading the mailbox. + +=head1 METHODS + +=head2 new + +Instantiate a new object. The 'driver' option is required. + +=head2 verify_user + +Checks user name and password. + +=head2 read_headers_for + +Provides bundeled information on a subset of mails of a mailbox. +Can be sorted and of varying size. + +=head2 count + +Returns size of the mail box folder in bytes the number of mails. + +=head2 show + +Returns a sepecific mail as a perl hash. + +=head2 search + +Searches for a message with the given pattern. + +=head2 folders + +List all mailbox sub folders. + +=head2 move + +Move mails between folders. + +=head1 CLASSES + +=head2 AuthReadMails + +A struct that bundles auth data. + +=head3 Attributes + +=head4 user + +The user name. + +=head4 password + +The users password in plaintext or as hmac if cram is used. + +=head4 challenge + +Optinal challange for when you use cram authentication. + +=head3 Methods + +=head4 new + +=head1 SEE ALSO + +L<JWebmail::Model::Driver::QMailAuthuser>, L<JWebmail::Model::Driver::Mock>, L<JWebmail> + +=cut
\ No newline at end of file diff --git a/lib/JWebmail/Model/WriteMails.pm b/lib/JWebmail/Model/WriteMails.pm new file mode 100644 index 0000000..5df5379 --- /dev/null +++ b/lib/JWebmail/Model/WriteMails.pm @@ -0,0 +1,143 @@ +package JWebmail::Model::WriteMails; + +use v5.18; +use warnings; +use utf8; + +use Exporter 'import'; +our @EXPORT_OK = qw(sendmail); +use Data::Dumper; + +use Email::MIME; + + +our $Block_Writes = 0; + + +sub _build_mail { + my $mail = shift; + + my $text_part = Email::MIME->create( + attributes => { + content_type => 'text/plain', + charset => 'utf-8', + encoding => '8bit', + }, + body_str => $mail->{message}, + ); + my $attach; + $attach = Email::MIME->create( + attributes => { + content_type => $mail->{attach_type}, + encoding => 'base64', + }, + body => $mail->{attach}->asset->slurp, + ) if $mail->{attach}; + + my $email = Email::MIME->create( + header_str => [ + From => $mail->{from}, + To => $mail->{to}, + Subject => $mail->{subject}, + 'X-Mailer' => 'JWebmail', + ], + parts => [$text_part, $attach || () ], + ); + $email->header_str_set(CC => @{$mail->{cc}}) if $mail->{cc}; + $email->header_str_set('Reply-To' => $mail->{reply}) if $mail->{reply}; + + return $email->as_string; +} + + +sub _send { + my ($mime, @recipients) = @_; + + open(my $m, '|-', 'sendmail', '-i', @recipients) + or die 'Connecting to sendmail failed. Is it in your PATH?'; + $m->print($mime->as_string); + close($m); + return $? >> 8; +} + + +sub sendmail { + my $mail = shift; + + my $mime = _build_mail($mail); + + my @recipients; + push @recipients, @{ $mail->{to} } if $mail->{to}; + push @recipients, @{ $mail->{cc} } if $mail->{cc}; + push @recipients, @{ $mail->{bcc} } if $mail->{bcc}; + + say $mime if $Block_Writes; + return 1 if $Block_Writes; + + return _send($mime, @recipients); +} + + +1 + +__END__ + +=encoding utf-8 + +=head1 NAME + +WriteMails - Build and send mails via a sendmail interface + +=head1 SYNOPSIS + + JWebmail::Model::WriteMails::sendmail { + from => ..., + to => ..., + subject => ..., + }; + +=head1 DESCRIPTION + +Build and send mails. + +=head1 FUNCTIONS + +=head2 sendmail + +Send the mail immediately. + +=head3 from + +The sender. + +=head3 to + +The recipient(s). + +=head3 reply + +The address the recipient is meant to reply to (optinal, if missing from is assumed). + +=head3 cc + +Secondary recipients, visible to other. + +=head3 bcc + +Secondary recipients, invisible to other. + +=head3 subject + +=head3 message + +The message body. Should be plain text encoded as utf-8. + +=head3 attach + +Optinal attachment. + +=head3 attach_type + +The mime type of the attachment. + +=cut
\ No newline at end of file diff --git a/lib/JWebmail/Plugin/Helper.pm b/lib/JWebmail/Plugin/Helper.pm new file mode 100644 index 0000000..5e557d1 --- /dev/null +++ b/lib/JWebmail/Plugin/Helper.pm @@ -0,0 +1,448 @@ +package JWebmail::Plugin::Helper; + +use Mojo::Base 'Mojolicious::Plugin'; + +use POSIX qw(floor round log ceil); +use MIME::Base64; +use Encode; +use Mojo::Util 'xml_escape'; +use List::Util qw(min max); + +use constant TRUE_RANDOM => eval { require Crypt::Random; Crypt::Random->import('makerandom_octet'); 1 }; +use constant HMAC => eval { require Digest::HMAC_MD5; Digest::HMAC_MD5->import('hmac_md5'); 1 }; + +### filter and checks for mojo validator + +sub mail_line { + my ($v, $name, $value, @args) = @_; + + my $mail_addr = qr/\w+\@\w+\.\w+/; + # my $unescaped_quote = qr/"(*nlb:\\)/; # greater perl version required + my $unescaped_quote = qr/"(?<!:\\)/; + + return $value !~ /^( + ( + ( + ( + $unescaped_quote.*?$unescaped_quote + ) | ( + [\w\s]* + ) + ) + \s*<$mail_addr> + ) | ( + $mail_addr + ))$ + /xno; +} + + +sub filter_empty_upload { + my ($v, $name, $value) = @_; + + return $value->filename ? $value : undef; +} + +### template formatting functions + +sub print_sizes10 { + my $var = shift; + if ($var == 0) { return '0 Byte'; } + + my $i = floor(((log($var)/log(10))+1e-5) / 3); + my $expo = $i * 3; + + my @PREFIX; + $PREFIX[0] = 'Byte'; + $PREFIX[1] = 'kByte'; + $PREFIX[2] = 'MByte'; + $PREFIX[3] = 'GByte'; + $PREFIX[4] = 'TByte'; + $PREFIX[5] = 'PByte'; + + return sprintf('%.0f %s', $var / (10**$expo), $PREFIX[$i]); +} + + +sub print_sizes2 { + my $var = shift; + if ($var == 0) { return '0 Byte'; } + + my $i = floor(((log($var)/log(2))+1e-5) / 10); + my $expo = $i * 10; + my %PREFIX = ( + 0 => 'Byte', + 1 => 'KiByte', + 2 => 'MiByte', + 3 => 'GiByte', + 4 => 'TiByte', + 5 => 'PiByte', + ); + my $pref = $PREFIX{$i}; + return round($var / (2**$expo)) . " $pref"; +} + +### mime type html render functions + +my $render_text_plain = sub { + my ($c, $content) = @_; + + $content = xml_escape($content); + $content =~ s/\n/<br>/g; + + return $content; +}; + + +my $render_text_html = sub { + my $c_ = shift; + + return '<iframe src="' . $c_->url_for('rawid', id => $c_->stash('id'))->query(body => 'html') . '" class=html-mail />'; +}; + + +our %MIME_Render_Subs = ( + 'text/plain' => $render_text_plain, + 'text/html' => $render_text_html, +); + + +sub mime_render { + my ($c, $enc, $cont) = @_; + + my $renderer = $MIME_Render_Subs{$enc}; + return '' unless defined $renderer; + return $renderer->($c, $cont); +}; + +### session password handling + +use constant { S_PASSWD => 'pw', S_OTP_S3D_PW => 'otp_s3d_pw' }; + +sub _rand_data { + my $len = shift; + + return makerandom_octet(Length => $len, Strength => 0); +} + +sub _pseudo_rand_data { + my $len = shift; + + my $res = ''; + for (0..$len-1) { + vec($res, $_, 8) = int rand 256; + } + + return $res; +} + +sub session_passwd { + my ($c, $passwd) = @_; + + warn_cram($c); + warn_crypt($c); + + if (defined $passwd) { # set + if ( HMAC && lc($c->config->{'session'}{secure} || 'none') eq 'cram' ) { + $c->session(S_PASSWD() => $passwd ? encode_base64(hmac_md5($passwd, $c->app->secrets->[0]), '') : ''); + } + elsif (lc($c->config->{'session'}->{secure} || 'none') eq 's3d') { + unless ($passwd) { + $c->s3d(S_PASSWD, ''); + delete $c->session->{S_OTP_S3D_PW()}; + return; + } + die "'$passwd' contains invalid character \\n" if $passwd =~ /\n/; + if (length $passwd < 20) { + $passwd .= "\n" . " " x (20 - length($passwd) - 1); + } + my $rand_bytes = TRUE_RANDOM ? _rand_data(length $passwd) : _pseudo_rand_data(length $passwd); + $c->s3d(S_PASSWD, encode_base64(encode('UTF-8', $passwd) ^ $rand_bytes, '')); + $c->session(S_OTP_S3D_PW, encode_base64($rand_bytes, '')); + } + else { + $c->session(S_PASSWD() => $passwd); + } + } + else { # get + if ( HMAC && lc($c->config->{'session'}->{secure} || 'none') eq 'cram' ) { + return ($c->app->secrets->[0], $c->session(S_PASSWD)); + } + elsif (lc($c->config->{'session'}->{secure} || 'none') eq 's3d') { + my $pw = decode_base64($c->s3d(S_PASSWD) || ''); + my $otp = decode_base64($c->session(S_OTP_S3D_PW) || ''); + my ($res) = split "\n", decode('UTF-8', $pw ^ $otp), 2; + return $res; + } + else { + return $c->session(S_PASSWD); + } + } +} + +sub warn_cram { + my $c = shift; + + state $once = 0; + + if ( !HMAC && !$once && lc($c->config->{'session'}->{secure} || 'none') eq 'cram' ) { + $c->log->warn("cram requires Digest::HMAC_MD5. Falling back to 'none'."); + } + + $once = 1; +} + +sub warn_crypt { + my $c = shift; + + state $once = 0; + + if ( !TRUE_RANDOM && !$once && lc($c->config->{'session'}->{secure} || 'none') eq 's3d' ) { + $c->log->warn("Falling back to pseudo random generation. Please install Crypt::Random"); + } + + $once = 1; +} + +### pagination + +sub _clamp { + my ($x, $y, $z) = @_; + + die '!($x <= $z)' unless $x <= $z; + + if ($x <= $y && $y <= $z) { + return $y; + } + + return $x if ($y < $x); + return $z if ($z < $y); +} + +sub _paginate { + my %args = @_; + + my $first_item = $args{first_item}; + my $page_size = $args{page_size} || 1; + my $total_items = $args{total_items}; + + my $first_item1 = $total_items ? $first_item+1 : 0; + + my $current_page = ceil($first_item/$page_size); + my $total_pages = ceil($total_items/$page_size); + + my $page = sub { + my $page_ = shift; + return [0, 0] unless $total_items; + $page_ = _clamp(0, $page_, $total_pages-1); + [_clamp(1, $page_*$page_size + 1, $total_items), _clamp(1, ($page_+1)*$page_size, $total_items)] + }; + + return ( + first_item => $first_item1, + last_item => _clamp($first_item1, $first_item + $page_size, $total_items), + total_items => $total_items, + page_size => $page_size, + + total_pages => $total_pages, + current_page => $current_page + 1, + + first_page => $page->(0), + prev_page => $page->($current_page-1), + next_page => $page->($current_page+1), + last_page => $page->($total_pages-1), + ); +} + +sub paginate { + my $c = shift; + my $count = shift; + + my $v = $c->validation; + my $start = $v->optional('start')->num(0, undef)->param // 0; + my $psize = $v->optional('page_size')->num(1, undef)->param // 50; + + $start = _clamp(0, $start, max($count-1, 0)); + my $end = _clamp($start, $start+$psize-1, max($count-1, 0)); + + $c->stash(_paginate(first_item => $start, page_size => $psize, total_items => $count)); + + return $start, $end; +} + +### registering + +sub register { + my ($self, $app, $conf) = @_; + + if (ref $conf->{import} eq 'ARRAY' and my @import = @{ $conf->{import} }) { + no warnings 'experimental::smartmatch'; + + # selective import + $app->helper(print_sizes10 => sub { shift; print_sizes10(@_) }) + if 'print_sizes10' ~~ @import; + $app->helper(print_sizes2 => sub { shift; print_sizes2(@_) }) + if 'print_sizes2' ~~ @import; + $app->helper(mime_render => \&mime_render) + if 'mime_render' ~~ @import; + $app->helper(session_passwd => \&session_passwd) + if 'session_passwd' ~~ @import; + $app->helper(paginate => \&paginate) + if 'paginate' ~~ @import; + $app->validator->add_check(mail_line => \&mail_line) + if 'mail_line' ~~ @import; + $app->validator->add_filter(non_empty_ul => \&filter_empty_upload) + if 'non_empty_ul' ~~ @import; + } + elsif (!$conf->{import}) { # default imports + $app->helper(print_sizes10 => sub { shift; print_sizes10(@_) }); + $app->helper(mime_render => \&mime_render); + $app->helper(session_passwd => \&session_passwd); + $app->helper(paginate => \&paginate); + + $app->validator->add_check(mail_line => \&mail_line); + + $app->validator->add_filter(non_empty_ul => \&filter_empty_upload); + } +} + + +1 + +__END__ + +=encoding utf-8 + +=head1 NAME + +Helper - Functions used as helpers in controller and templates and additional validator checks and filters + +=head1 SYNOPSIS + + use Mojo::Base 'Mojolicious'; + + use JWebmail::Plugin::Helper; + + sub startup($self) { + $self->helper(mime_render => \&JWebmail::Plugin::Helper::mime_render); + } + + # or + + $app->plugin('Helper'); + +=head1 DESCRIPTION + +L<JWebmail::Helper> provides useful helper functions and validator cheks and filter for +L<JWebmail::Controller::All> and various templates. + +=head1 FUNCTIONS + +=head2 mail_line + +A check for validator used in mail headers for fields containing email addresses. + + $app->validator->add_check(mail_line => \&JWebmail::Plugin::Helper::mail_line); + + my $v = $c->validation; + $v->required('to', 'not_empty')->check('mail_line'); + +=head2 filter_empty_upload + +A filter for validator used to filter out empty uploads. + + $app->validator->add_filter(non_empty_ul => \&JWebmail::Plugin::Helper::filter_empty_upload); + + my $v = $c->validation; + $v->required('file_upload', 'non_empty_ul'); + +=head2 print_sizes10 + +A helper for templates used to format byte sizes. + + $app->helper(print_sizes10 => sub { shift; JWebmail::Plugin::Helper::print_sizes10(@_) }); + + %= print_sizes10 12345 # => 12 kB + +=head2 print_sizes2 + +A helper for templates used to format byte sizes. + + %= print_sizes10 12345 # => 12 KiB + +This is not registered by default. + +=head2 paginate + +A helper for calculationg page bounds. + +Takes the total number of items as argument. + +Reads in 'start' and 'page_size' query arguments. +start is 0 based. + +Returns the calculated start and end points as 0 based inclusive range. + +Sets the stash values (all 1 based inclusive): + + first_item + last_item + total_items + page_size + total_pages + current_page + first_page + prev_page + next_page + last_page + +=head2 mime_render + +A helper for templates used to display the content of a mail for the browser. +The output is valid html and should not be escaped. + + $app->helper(mime_render => \&JWebmail::Plugin::Helper::mime_render); + + %== mime_render 'text/plain' $content + +=head2 session_passwd + +A helper used to set and get the session password. The behaivour can be altered by +setting the config variable C<< session => {secure => 's3d'} >>. + + $app->helper(session_passwd => \&JWebmail::Plugin::Helper::session_passwd); + + $c->session_passwd('s3cret'); + +Currently the following modes are supported: + +=over 6 + +=item none + +password is plainly stored in session cookie + +=item cram + +challenge response authentication mechanism uses the C<< $app->secret->[0] >> as nonce. +This is optional if Digest::HMAC_MD5 is installed. + +=item s3d + +data is stored on the server. Additionally the password is encrypted by an one-time-pad that is stored in the user cookie. + +=back + +=head1 DEPENDENCIES + +Mojolicious, Crypt::Random and optianally Digest::HMAC_MD5. + +=head1 SEE ALSO + +L<JWebmail>, L<JWebmail::Controller::All>, L<Mojolicious>, L<Mojolicious::Controller> + +=head1 NOTICE + +This package is part of JWebmail. + +=cut
\ No newline at end of file diff --git a/lib/JWebmail/Plugin/I18N.pm b/lib/JWebmail/Plugin/I18N.pm new file mode 100644 index 0000000..dc10fdd --- /dev/null +++ b/lib/JWebmail/Plugin/I18N.pm @@ -0,0 +1,212 @@ +package JWebmail::Plugin::I18N; + +use Mojo::Base 'Mojolicious::Plugin'; + +use Mojolicious::Controller; +use Mojo::File; +use Mojo::Util 'monkey_patch'; + + +has '_language_loaded' => sub { {} }; + + +sub register { + my ($self, $app, $conf) = @_; + + my $i18n_log = $app->log->context('[' . __PACKAGE__ . ']'); + + # config + # 1. what languages + # 2. where are the files + # 3. fallback language + # + # look for languages automatically + my $defaultLang = $conf->{default_language} || 'en'; + my $fileLocation = $conf->{directory} && Mojo::File->new($conf->{directory})->is_abs + ? $conf->{directory} + : $app->home->child($conf->{directory} || 'lang'); + my @languages = keys %{$conf->{languages} // {}}; + + unless (@languages) { + @languages = map { $_ =~ s|^.*/(..)\.lang$|$1|r } glob("$fileLocation/*.lang"); + } + + $app->defaults(lang => $defaultLang); + $app->defaults(languages => [@languages]); + + # load languages + my $TXT; + for my $l (@languages) { + $TXT->{$l} = _loadi18n($fileLocation, $l, $i18n_log); + } + + { + local $" = ','; + $i18n_log->debug("loaded languages (@languages)"); + } + + $self->_language_loaded( { map { $_ => 1 } @languages } ); + + # add translator as helper + my $i18n = sub { + my ($lang, $word) = @_; + $TXT->{$lang}{$word} || scalar( + local $" = ' ', + $lang && $word ? $app->log->debug('[' . __PACKAGE__ . "] missing translation for $lang:$word @{[ caller(2) ]}[0..2]") : (), + '', + ) + }; + $app->helper( l => sub { my $c = shift; $i18n->($c->stash->{lang}, shift) } ); + + # rewrite url + $app->hook(before_dispatch => sub { $self->read_language_hook(@_) }); + + # patch url_for + my $mojo_url_for = Mojolicious::Controller->can('url_for'); + my $i18n_url_for = sub { + my $c = shift; + my $url = $mojo_url_for->($c, @_); + + my $args = (ref $_[0] eq 'HASH' and $_[0]) || (ref $_[1] eq 'HASH' and $_[1]) || do { my %x = @_[(@_ % 2) .. $#_]; \%x }; + my $lang = $args->{lang} // $c->stash->{lang}; + + if ( $lang && (ref $_[0] eq 'HASH' || !ref $_[0] && ($_[0]//'') !~ m![:@/.]!) ) { + unshift @{ $url->path->parts }, $lang + if ($url->path->parts->[0] // '') ne $lang; + $url = $url->to_abs(Mojo::URL->new('/')); + } + + return $url; + }; + monkey_patch 'Mojolicious::Controller', url_for => $i18n_url_for; + + 0 +} + + +sub read_language_hook { + my $self = shift; + my $c = shift; + + # URL detection + if (my $path = $c->req->url->path) { + + my $part = $path->parts->[0]; + + if ( $part && $self->_language_loaded->{$part} ) { + # Ignore static files + return if $c->res->code; + + $c->app->log->debug('[' . __PACKAGE__ . "] Found language $part in URL $path"); + + # Save lang in stash + $c->stash(lang => $part); + + if ( @{ $path->parts } == 1 && !$path->trailing_slash ) { + return $c->redirect_to($c->req->url->path->trailing_slash(1)); # default controller adds language back + } + + # Clean path + shift @{$path->parts}; + $path->trailing_slash(0); + } + } +} + + +sub _loadi18n { + + my $langsubdir = shift; + my $lang = shift; + my $log = shift; + + my $langFile = "$langsubdir/$lang.lang"; + my $TXT; + + if ( -f $langFile ) { + $TXT = Config::Tiny->read($langFile, 'utf8')->{'_'}; + if ($@ || !defined $TXT) { + $log->error("error reading file $langFile: $@"); + } + } + else { + $log->warn("language file $langFile does not exist!"); + } + return $TXT; +} + + +1 + +__END__ + +=encoding utf8 + +=head1 NAME + +JWebmail::Plugin::I18N - Custom Made I18N Support Inspired by Mojolicious::Plugin::I18N + +=head1 SYNOPSIS + + $app->plugin('I18N', { + languages => [qw(en de es)], + default_language => 'en', + directory => '/path/to/language/files/', + }) + + # in your controller + $c->l('hello') + + # in your templates + <%= l 'hello' %> + + @@ de.lang + login = anmelden + userid = nuzerkennung + passwd = passwort + failed = fehlgeschlagen + about = über + + example.com/de/myroute # $c->stash('lang') eq 'de' + example.com/myroute # $c->stash('lang') eq $defaultLanguage + + # on example.com/de/myroute + url_for('my_other_route') #=> example.com/de/my_other_route + + url_for('my_other_route', lang => 'es') #=> example.com/es/my_other_route + +=head1 DESCRIPTION + +L<JWebmail::Plugin::I18N> provides I18N support. + +The language will be taken from the first path segment of the url. +Be carefult with colliding routes. + +Mojolicious::Controller::url_for is patched so that the current language will be kept for +router named urls. + +=head1 OPTIONS + +=head2 default_language + +The default language when no other information is provided. + +=head2 directory + +Directory to look for language files. + +=head2 languages + +List of allowed languages. +Files of the pattern "$lang.lang" will be looked for. + +=head1 HELPERS + +=head2 l + +This is used for your translations. + + $c->l('hello') + $app->helper('hello')->() + +=cut
\ No newline at end of file diff --git a/lib/JWebmail/Plugin/I18N2.pm b/lib/JWebmail/Plugin/I18N2.pm new file mode 100644 index 0000000..53813de --- /dev/null +++ b/lib/JWebmail/Plugin/I18N2.pm @@ -0,0 +1,185 @@ +package JWebmail::Plugin::I18N2; + +use Mojo::Base 'Mojolicious::Plugin'; + +use Mojolicious::Controller; +use Mojo::File; +use Mojo::Util 'monkey_patch'; + + +has '_language_loaded' => sub { {} }; + + +sub register { + my ($self, $app, $conf) = @_; + + my $i18n_log = $app->log->context('[' . __PACKAGE__ . ']'); + + # config + # 1. what languages + # 2. where are the files + # 3. fallback language + # + # look for languages automatically + my $defaultLang = $conf->{default_language} || 'en'; + my $fileLocation = $conf->{directory} && Mojo::File->new($conf->{directory})->is_abs + ? $conf->{directory} + : $app->home->child($conf->{directory} || 'lang'); + my @languages = keys %{$conf->{languages} // {}}; + + unless (@languages) { + @languages = map { $_ =~ s|^.*/(..)\.lang$|$1|r } glob("$fileLocation/*.lang"); + } + + $app->defaults(languages => [@languages]); + + # load languages + my $TXT; + for my $l (@languages) { + $TXT->{$l} = _loadi18n($fileLocation, $l, $i18n_log); + } + + { + local $" = ','; + $i18n_log->debug("loaded languages (@languages)"); + } + + $self->_language_loaded( { map { $_ => 1 } @languages } ); + + # add translator as helper + my $i18n = sub { + my ($lang, $word) = @_; + $TXT->{$lang}{$word} || scalar( + local $" = ' ', + $lang && $word ? $app->log->debug('[' . __PACKAGE__ . "] missing translation for $lang:$word @{[ caller(2) ]}[0..2]") : (), + '', + ) + }; + $app->helper( l => sub { my $c = shift; $i18n->($c->stash->{lang}, shift) } ); + + $app->hook(before_dispatch => sub { + my $c = shift; + unshift @{ $c->req->url->path->parts }, '' + unless $self->_language_loaded->{$c->req->url->path->parts->[0] || ''}; + }); + + # patch url_for + my $mojo_url_for = Mojolicious::Controller->can('url_for'); + my $i18n_url_for = sub { + my $c = shift; + if (ref $_[0] eq 'HASH') { + $_[0]->{lang} ||= $c->stash('lang'); + } + elsif (ref $_[1] eq 'HASH') { + $_[1]->{lang} ||= $c->stash('lang'); + } + elsif (@_) { + push @_, lang => $c->stash('lang'); + } + else { + @_ = {lang => $c->stash('lang')}; + } + return $mojo_url_for->($c, @_); + }; + monkey_patch 'Mojolicious::Controller', url_for => $i18n_url_for; + + return $app->routes->any('/:lang' => {lang => 'en'}); +} + + +sub _loadi18n { + + my $langsubdir = shift; + my $lang = shift; + my $log = shift; + + my $langFile = "$langsubdir/$lang.lang"; + my $TXT; + + if ( -f $langFile ) { + $TXT = Config::Tiny->read($langFile, 'utf8')->{'_'}; + if ($@ || !defined $TXT) { + $log->error("error reading file $langFile: $@"); + } + } + else { + $log->warn("language file $langFile does not exist!"); + } + return $TXT; +} + + +1 + +__END__ + +=encoding utf8 + +=head1 NAME + +JWebmail::Plugin::I18N2 - Custom Made I18N Support an alternative to JWebmail::Plugin::I18N + +=head1 SYNOPSIS + + $app->plugin('I18N2', { + languages => [qw(en de es)], + default_language => 'en', + directory => '/path/to/language/files/', + }) + + # in your controller + $c->l('hello') + + # in your templates + <%= l 'hello' %> + + @@ de.lang + login = anmelden + userid = nuzerkennung + passwd = passwort + failed = fehlgeschlagen + about = über + + example.com/de/myroute # $c->stash('lang') eq 'de' + example.com/myroute # $c->stash('lang') eq $defaultLanguage + + # on example.com/de/myroute + url_for('my_other_route') #=> example.com/de/my_other_route + + url_for('my_other_route', lang => 'es') #=> example.com/es/my_other_route + +=head1 DESCRIPTION + +L<JWebmail::Plugin::I18N2> provides I18N support. + +The language will be taken from the first path segment of the url. +Be carefult with colliding routes. + +Mojolicious::Controller::url_for is patched so that the current language will be kept for +router named urls. + +=head1 OPTIONS + +=head2 default_language + +The default language when no other information is provided. + +=head2 directory + +Directory to look for language files. + +=head2 languages + +List of allowed languages. +Files of the pattern "$lang.lang" will be looked for. + +=head1 HELPERS + +=head2 l + +This is used for your translations. + + $c->l('hello') + $app->helper('hello')->() + +=cut
\ No newline at end of file diff --git a/lib/JWebmail/Plugin/INIConfig.pm b/lib/JWebmail/Plugin/INIConfig.pm new file mode 100644 index 0000000..fe0fb1a --- /dev/null +++ b/lib/JWebmail/Plugin/INIConfig.pm @@ -0,0 +1,136 @@ +package JWebmail::Plugin::INIConfig; +use Mojo::Base 'Mojolicious::Plugin::Config'; + +use List::Util 'all'; + +use Config::Tiny; + + +sub parse { + my ($self, $content, $file, $conf, $app) = @_; + + my $ct = Config::Tiny->new; + my $config = $ct->read_string($content, 'utf8'); + die qq{Can't parse config "$file": } . $ct->errstr unless defined $config; + + $config = _process_config($config) unless $conf->{flat}; + + return $config; +} + + +sub _process_config { + my $val_prev = shift; + my %val = %$val_prev; + + # arrayify section with number keys + for my $key (keys %val) { + if (keys %{$val{$key}} && all { $_ =~ /\d+/} keys %{$val{$key}}) { + my $tmp = $val{$key}; + $val{$key} = []; + + for (keys %$tmp) { + $val{$key}[$_] = $tmp->{$_}; + } + } + } + + # merge top section + my $top_section = $val{'_'}; + delete $val{'_'}; + for (keys %$top_section) { + $val{$_} = $top_section->{$_} unless $val{$_}; + } + + # make implicit nesting explicit + for my $key (grep { $_ =~ /^\w+(::\w+)+$/} keys %val) { + + my @sections = split m/::/, $key; + my $x = \%val; + my $y; + for (@sections) { + $x->{$_} = {} unless ref $x->{$_};# eq 'HASH'; + $y = $x; + $x = $x->{$_}; + } + # merge + if (ref $val{$key} eq 'ARRAY') { + $y->{$sections[-1]} = []; + $x = $y->{$sections[-1]}; + for ( keys @{ $val{$key} } ) { + $x->[$_] = $val{$key}[$_]; + } + } + else { + for ( keys %{ $val{$key} } ) { + $x->{$_} = $val{$key}{$_}; + } + } + delete $val{$key}; + } + + return \%val +} + + +1 + +__END__ + +=encoding utf-8 + +=head1 NAME + +INIConfig - Reads in ini config files. + +=head1 SYNOPSIS + + $app->plugin('INIConfig'); + + @@ my_app.conf + + # global section + key = val ; line comment + [section] + other_key = other_val + [other::section] + 0 = key1 + 1 = key2 + 2 = key3 + +=head1 DESCRIPTION + +INI configuration is simple with limited nesting and propper comments. +For more precise specification on the syntax see the Config::Tiny documentation +on metacpan. + +=head1 OPTIONS + +=head2 default + +Sets default configuration values. + +=head2 ext + +Sets file extension defaults to '.conf'. + +=head2 file + +Sets file name default '$app->moniker'. + +=head2 flat + +Keep configuration to exactly two nesting levels for all +and disable auto array conversion. + +=head1 METHODS + +=head2 parse + +overrides the parse method of Mojolicious::Plugin::Config + +=head1 DEPENDENCIES + +Config::Tiny + +=cut
\ No newline at end of file diff --git a/lib/JWebmail/Plugin/ServerSideSessionData.pm b/lib/JWebmail/Plugin/ServerSideSessionData.pm new file mode 100644 index 0000000..9890358 --- /dev/null +++ b/lib/JWebmail/Plugin/ServerSideSessionData.pm @@ -0,0 +1,147 @@ +package JWebmail::Plugin::ServerSideSessionData; + +use Mojo::Base 'Mojolicious::Plugin'; + +use Mojo::JSON qw(decode_json encode_json); +use Mojo::File; + +use constant { + S_KEY => 's3d.key', +}; + + +has '_session_directory'; +sub session_directory { my $self = shift; @_ ? $self->_session_directory(Mojo::File->new(@_)) : $self->_session_directory } + +has 'expiration'; +has 'cleanup_interval'; + +has '_cleanup'; +sub cleanup { + my $self = shift; + if (@_) { + return $self->_cleanup(@_); + } + else { + if ($self->_cleanup < time) { + return 0; + } + else { + $self->_cleanup(time + $self->cleanup_interval); + return 1; + } + } +} + + +sub s3d { + my $self = shift; + my $c = shift; + + # cleanup old sessions + if ($self->cleanup) { + my $t = time; + for ($self->session_directory->list->each) { + if ( $_->stat->mtime + $self->expiration < $t ) { + $_->remove; + } + } + } + + my $file = $self->session_directory->child($c->session(S_KEY) || $c->req->request_id . $$); + + if (-e $file) { + if ($file->stat->mtime + $self->expiration < time) { + $file->remove; + } + else { + $file->touch; + } + } + my $data = decode_json($file->slurp) if (-s $file); + + my ($key, $val) = @_; + + if (defined $val) { # set + unless (-e $file) { + $c->session(S_KEY, $file->basename); + } + $data = ref $data ? $data : {}; + $data->{$key} = $val; + + #$file->spurt(encode_json $data); + open(my $f, '>', $file) or die "$!"; + chmod 0600, $f; + $f->say(encode_json $data); + close($f); + } + else { # get + return defined $key ? $data->{$key} : $data; + } +}; + + +sub register { + my ($self, $app, $conf) = @_; + + $self->session_directory($conf->{directory} || "/tmp/" . $app->moniker); + $self->expiration($conf->{expiration} || $app->sessions->default_expiration); + $self->cleanup_interval($conf->{cleanup_interval} || $self->expiration); + $self->cleanup(time + $self->cleanup_interval); + + unless (-d $self->session_directory) { + mkdir($self->session_directory) + or $! ? die "failed to create directory: $!" : 1; + } + + $app->helper( s3d => sub { $self->s3d(@_) } ); +} + + +1 + +__END__ + +=encoding utf-8 + +=head1 NAME + +ServeSideSessionData - Stores session data on the server (alias SSSD or S3D) + +=head1 SYNOPSIS + + $app->plugin('ServeSideSessionData'); + + $c->s3d(data => 'Hello, S3D'); + $c->s3d('data'); + +=head1 DESCRIPTION + +Store data temporarily on the server. +The only protetction on the server are struct user access rights. + +=head1 OPTIONS + +=head2 directory + +default C<< 'tmp/' . $app->moniker >> + +=head2 expiration + +default session expiration + +=head2 cleanup_interval + +default session expiration + +=head1 HELPERS + +=head2 s3d + +Stores and retrieves values. + + $c->s3d(data => 'Hello, S3D'); + $c->s3d('data'); + $c->s3d->{data}; + +=cut
\ No newline at end of file |