diff --git a/perl/Net/IMAP/Server.pm b/perl/Net/IMAP/Server.pm index 80450c8..4bc00ef 100644 --- a/perl/Net/IMAP/Server.pm +++ b/perl/Net/IMAP/Server.pm @@ -1,4 +1,5 @@ package Net::IMAP::Server; +# vim: set shiftwidth=4 tabstop=4 softtabstop=4 expandtab: use warnings; use strict; @@ -7,6 +8,8 @@ use base qw/Net::Server::Coro Class::Accessor/; use UNIVERSAL::require; use Coro; +use IO::File; +use Sys::Syslog qw(:standard :macros); our $VERSION = '1.23'; @@ -63,6 +66,9 @@ __PACKAGE__->mk_accessors( poll_every unauth_idle auth_idle unauth_commands server_cert server_key + log_level + log_file + log_type / ); @@ -144,6 +150,30 @@ either relative or absolute path. Path to the SSL certificate key that the server should use. This can be either relative or absolute path. +=item log_level + +Level of log verbosity. The higher number the more verbose log messages +will be. Available values are: + + 0 - error + 1 - warning + 2 - notice + 3 - info + 4 - debug + +=item log_type + +Type of logging we want. Available values are: + +Available logging types: + STDOUT Write log messages to standard output (default). + SYSLOG Use syslog + FILE Write log messages to custom file + +=item log_file + +If the log_type is set to "FILE", this must contain the path to the log file. + =back =cut @@ -164,6 +194,8 @@ sub new { unauth_commands => 10, server_cert => "certs/server-cert.pem", server_key => "certs/server-key.pem", + log_level => 2, + log_type => "STDOUT", @_, command_class => {}, connection => {}, @@ -176,6 +208,9 @@ sub new { "Can't read certificates ($server_cert and $server_key)\n"; } + # Prepare logging + $self->prepare_log(); + UNIVERSAL::require( $self->auth_class ) or die "Can't require auth class: $@\n"; $self->auth_class->isa("Net::IMAP::Server::DefaultAuth") @@ -224,6 +259,25 @@ sub run { ); } +=head2 prepare_log + +Open logging file or prepare syslog for logging. + +=cut + +sub prepare_log { + my $self = shift; + + if ($self->log_type eq "SYSLOG") { + Sys::Syslog::openlog("$$", undef, Sys::Syslog::LOG_MAIL); + + } elsif ($self->log_type eq "FILE") { + open $self->{'log_fd'}, ">>".$self->log_file + or die "Cannot open log file for writing: ".$self->log_file; + $self->{'log_fd'}->autoflush(1); + } +} + =head2 process_request Accepts a client connection; this method is needed for the @@ -375,6 +429,39 @@ sub add_command { } } +=head2 log($level,$msg) + +Log message according to $self->log_file. Function will log only +messages with level less or equal to $self->log_level. Default level for +a message is 2 (notice). + +=cut + +sub log { + my ($self, $level, $msg) = @_; + + $level = 2 unless defined $level; + if ($level <= $self->log_level) { + chomp($msg); + $msg = $self->log_time . " $msg\n"; + + if ($self->log_type eq "SYSLOG") { + my $priority = { + 0 => LOG_ERR, + 1 => LOG_WARNING, + 2 => LOG_NOTICE, + 3 => LOG_INFO, + 4 => LOG_DEBUG, + }->{$level}; + Sys::Syslog::syslog($priority, $msg); + } elsif ($self->log_type eq "FILE") { + print {$self->{'log_fd'}} $msg; + } else { # STDOUT + print $msg; + } + } +} + 1; # Magic true value required at end of module __END__ diff --git a/perl/Net/IMAP/Server/Command.pm b/perl/Net/IMAP/Server/Command.pm index 545b322..2170312 100644 --- a/perl/Net/IMAP/Server/Command.pm +++ b/perl/Net/IMAP/Server/Command.pm @@ -374,17 +374,6 @@ sub bad_command { return 0; } -=head2 log MESSAGE - -Identical to L. - -=cut - -sub log { - my $self = shift; - $self->connection->log(@_); -} - =head2 out MESSAGE Identical to L. diff --git a/perl/Net/IMAP/Server/Command/Create.pm b/perl/Net/IMAP/Server/Command/Create.pm index 294104e..67a2c97 100644 --- a/perl/Net/IMAP/Server/Command/Create.pm +++ b/perl/Net/IMAP/Server/Command/Create.pm @@ -37,7 +37,8 @@ sub run { my $base = $self->connection->model->root; for my $n (0.. $#parts) { - my $path = join($self->connection->model->root->separator, @parts[0 .. $n]); + my $sep = $self->connection->model->root->separator || ""; + my $path = join($sep, @parts[0 .. $n]); my $part = $self->connection->model->lookup($path); unless ($part) { unless ($part = $base->create( name => $parts[$n] )) { diff --git a/perl/Net/IMAP/Server/Command/List.pm b/perl/Net/IMAP/Server/Command/List.pm index aaef217..c0d8016 100644 --- a/perl/Net/IMAP/Server/Command/List.pm +++ b/perl/Net/IMAP/Server/Command/List.pm @@ -27,14 +27,19 @@ sub run { # In the special case of a query for the delimiter, give them our delimiter if ( $search eq "" ) { - $self->tagged_response( q{(\Noselect) "} - . $self->connection->model->root->separator - . q{" ""} ); + my $sep = (defined $self->connection->model->root->separator) + ? q{"}.$self->connection->model->root->separator.q{"} : "NIL"; + $self->tagged_response( qq|(\\Noselect) $sep ""| ); } else { my $sep = $self->connection->model->root->separator; $search = quotemeta($search); $search =~ s/\\\*/.*/g; - $search =~ s/\\%/[^$sep]+/g; + if (defined $sep) { + $search =~ s/\\%/[^$sep]*/g; + } + else { + $search =~ s/\\%/.*/g; + } my $regex = qr{^\Q$root\E$search$}; $self->connection->model->root->update_tree; $self->traverse( $self->connection->model->root, $regex ); @@ -48,9 +53,11 @@ sub list_out { my $node = shift; my @props = @_; - my $str = $self->data_out([map {\$_} @props]); - $str .= q{ "} . $self->connection->model->root->separator . q{" }; - $str .= q{"} . Encode::encode('IMAP-UTF-7',$node->full_path) . q{"}; + my $sep = (defined $self->connection->model->root->separator) + ? q{"}.$self->connection->model->root->separator.q{"} : "NIL"; + my $name = q{"}.Encode::encode('IMAP-UTF-7',$node->full_path).q{"}; + + my $str = $self->data_out([map {\$_} @props]) . " $sep $name"; $self->tagged_response($str); } @@ -61,6 +68,7 @@ sub traverse { my @props; push @props, @{$node->children} ? '\HasChildren' : '\HasNoChildren'; + push @props, '\Noinferiors' if not defined $self->connection->model->root->separator; push @props, '\Noselect' unless $node->is_selectable; $self->list_out($node, @props) if $node->parent and diff --git a/perl/Net/IMAP/Server/Command/Rename.pm b/perl/Net/IMAP/Server/Command/Rename.pm index cab5435..ec4046a 100644 --- a/perl/Net/IMAP/Server/Command/Rename.pm +++ b/perl/Net/IMAP/Server/Command/Rename.pm @@ -34,7 +34,8 @@ sub run { my $base = $self->connection->model->root; for my $n (0.. $#parts) { - my $path = join($self->connection->model->root->separator, @parts[0 .. $n]); + my $sep = $self->connection->model->root->separator || ""; + my $path = join($sep, @parts[0 .. $n]); my $part = $self->connection->model->lookup($path); unless ($part) { unless ($part = $base->create( name => $parts[$n] )) { diff --git a/perl/Net/IMAP/Server/Command/Uid.pm b/perl/Net/IMAP/Server/Command/Uid.pm index eb5859f..15f0e39 100644 --- a/perl/Net/IMAP/Server/Command/Uid.pm +++ b/perl/Net/IMAP/Server/Command/Uid.pm @@ -29,8 +29,7 @@ sub run { if ($subcommand =~ /^(copy|fetch|store|search|expunge)$/i ) { $self->$subcommand(@rest); } else { - $self->log( - $subcommand . " wasn't understood by the 'UID' command" ); + $self->log(4, $subcommand . " wasn't understood by the 'UID' command" ); $self->no_failed( alert => q{Your client sent a UID command we didn't understand} ); } diff --git a/perl/Net/IMAP/Server/Connection.pm b/perl/Net/IMAP/Server/Connection.pm index 52cea1d..e7c8803 100644 --- a/perl/Net/IMAP/Server/Connection.pm +++ b/perl/Net/IMAP/Server/Connection.pm @@ -1,4 +1,5 @@ package Net::IMAP::Server::Connection; +# vim: set shiftwidth=4 tabstop=4 softtabstop=4 expandtab: use warnings; use strict; @@ -182,9 +183,7 @@ sub handle_lines { cede; } - $self->log( - "-(@{[$self]},@{[$self->auth ? $self->auth->user : '???']},@{[$self->is_selected ? $self->selected->full_path : 'unselected']}): Connection closed by remote host" - ); + $self->log(2, "Connection closed by remote host"); }; my $err = $@; warn $err @@ -241,9 +240,7 @@ sub handle_command { my $self = shift; my $content = shift; - $self->log( - "C(@{[$self]},@{[$self->auth ? $self->auth->user : '???']},@{[$self->is_selected ? $self->selected->full_path : 'unselected']}): $content" - ); + $self->log(4, "C: $content"); if ( $self->pending ) { $self->pending->($content); @@ -273,7 +270,7 @@ sub handle_command { $handler->bad_command($1); } else { $handler->no_command("Server error"); - $self->log($error); + $self->log(4, $error); } } } @@ -565,19 +562,6 @@ sub capability { return $base; } -=head2 log MESSAGE - -Logs the message to standard error, using C. - -=cut - -sub log { - my $self = shift; - my $msg = shift; - chomp($msg); - warn $msg . "\n"; -} - =head2 untagged_response STRING Sends an untagged response to the client; a newline ia automatically @@ -603,9 +587,7 @@ sub out { my $msg = shift; if ( $self->io_handle and $self->io_handle->peerport ) { if ( $self->io_handle->print( $msg . "\r\n" ) ) { - $self->log( - "S(@{[$self]},@{[$self->auth ? $self->auth->user : '???']},@{[$self->is_selected ? $self->selected->full_path : 'unselected']}): $msg" - ); + $self->log(4, "S: $msg"); } else { $self->close; die "Error printing\n"; @@ -616,4 +598,19 @@ sub out { } } +=head2 + +Log a message with some additional information (current user and selected mailbox). + +=cut + +sub log { + my ($self, $level, $msg) = @_; + + my $user = $self->auth ? $self->auth->user : "n/a"; + my $mailbox = $self->is_selected ? $self->selected->full_path : "n/a"; + my $logmsg = "[user=$user mailbox=$mailbox] $msg"; + $self->server->log($level, $logmsg); +} + 1; diff --git a/perl/Net/IMAP/Server/DefaultModel.pm b/perl/Net/IMAP/Server/DefaultModel.pm index 02cbb9e..92b0aaf 100644 --- a/perl/Net/IMAP/Server/DefaultModel.pm +++ b/perl/Net/IMAP/Server/DefaultModel.pm @@ -101,16 +101,24 @@ Utility method which splits a given C according to the mailbox separator, as determined by the L of the L. May C if the path (which is expected to be encoded using IMAP-UTF-7) is -invalid. See L. +invalid. See L. If the mailbox hierarchy is flat +(i.e. the separator is undef), returns the name without change. =cut sub split { my $self = shift; my $name = shift; + $name = eval { Encode::decode('IMAP-UTF-7', $name) }; die "BAD Invalid UTF-7 encoding\n" unless defined $name; - return grep {length} split quotemeta $self->root->separator, $name; + + if (defined $self->root->separator) { + return grep {length} split quotemeta $self->root->separator, $name; + } + else { + return $name; + } } =head2 lookup PATH diff --git a/perl/Net/IMAP/Server/Mailbox.pm b/perl/Net/IMAP/Server/Mailbox.pm index 4511f71..12053f0 100644 --- a/perl/Net/IMAP/Server/Mailbox.pm +++ b/perl/Net/IMAP/Server/Mailbox.pm @@ -342,6 +342,9 @@ sub close { } Returns the path separator. Note that only the path separator of the root mailbox matters. Defaults to a forward slash. +If the function returns is undef, the server supports only flat +mailboxes (i.e. no child mailboxes are allowed). + =cut sub separator { diff --git a/perl/Net/Server/Proto/SSL.pm b/perl/Net/Server/Proto/SSL.pm index 387c7d6..c7f72e8 100644 --- a/perl/Net/Server/Proto/SSL.pm +++ b/perl/Net/Server/Proto/SSL.pm @@ -82,7 +82,7 @@ sub log_connect { my $host = $sock->NS_host; my $port = $sock->NS_port; my $proto = $sock->NS_proto; - $server->log(2,"Binding to $proto port $port on host $host\n"); + $server->log(2, "Binding to $proto port $port on host $host"); } ### connect the first time diff --git a/perl/Net/Server/Proto/TCP.pm b/perl/Net/Server/Proto/TCP.pm index 66fdb37..8c6cb06 100644 --- a/perl/Net/Server/Proto/TCP.pm +++ b/perl/Net/Server/Proto/TCP.pm @@ -65,7 +65,7 @@ sub log_connect { my $host = $sock->NS_host; my $port = $sock->NS_port; my $proto = $sock->NS_proto; - $server->log(2,"Binding to $proto port $port on host $host\n"); + $server->log(2, "Binding to $proto port $port on host $host"); } ### connect the first time diff --git a/perl/Net/Server/Proto/UNIX.pm b/perl/Net/Server/Proto/UNIX.pm index 438322b..53b9f3e 100644 --- a/perl/Net/Server/Proto/UNIX.pm +++ b/perl/Net/Server/Proto/UNIX.pm @@ -102,8 +102,7 @@ sub log_connect { my $server = shift; my $unix_path = $sock->NS_unix_path; my $type = ($sock->NS_unix_type == SOCK_STREAM) ? 'SOCK_STREAM' : 'SOCK_DGRAM'; - - $server->log(2,"Binding to UNIX socket file $unix_path using $type\n"); + $server->log(2, "Binding to UNIX socket file $unix_path using $type\n"); } ### connect the first time