File Coverage

blib/lib/Net/IMAP/Server.pm
Criterion Covered Total %
statement 9 9 100.0
branch n/a
condition n/a
subroutine 3 3 100.0
pod n/a
total 12 12 100.0


line stmt bran cond sub pod time code
1             package Net::IMAP::Server;
2              
3 13     13   47183 use warnings;
  13         61  
  13         921  
4 13     13   89 use strict;
  13         58  
  13         541  
5              
6 13     13   57 use base qw/Net::Server::Coro Class::Accessor/;
  13         41  
  13         6683  
7              
8             use UNIVERSAL::require;
9             use Coro;
10             use 5.008_008;
11              
12             our $VERSION = '1.39';
13              
14             =head1 NAME
15              
16             Net::IMAP::Server - A single-threaded multiplexing IMAP server
17             implementation, using L.
18              
19             =head1 SYNOPSIS
20              
21             use Net::IMAP::Server;
22             Net::IMAP::Server->new(
23             port => 193,
24             ssl_port => 993,
25             auth_class => "Your::Auth::Class",
26             model_class => "Your::Model::Class",
27             user => "nobody",
28             group => "nobody",
29             )->run;
30              
31             =head1 DESCRIPTION
32              
33             This model provides a complete implementation of the C
34             specification, along with several IMAP4rev1 extensions. It provides
35             separation of the mailbox and message store from the client
36             interaction loop.
37              
38             Note that, following RFC suggestions, login is not allowed except
39             under either SSL or TLS. Thus, you are required to have a F
40             directory under the current working directory, containing files
41             F and C. Failure to do so will cause
42             the server to fail to start. Note that if the default paths suit your
43             needs, you can specify different ones using the L and
44             L arguments to L.
45              
46             =head1 INTERFACE
47              
48             The primary method of using this module is to supply your own model
49             and auth classes, which inherit from
50             L and
51             L. This allows you to back your
52             messages from arbitrary data sources, or provide your own
53             authorization backend. For the most part, the implementation of the
54             IMAP components should be opaque.
55              
56             =head1 METHODS
57              
58             =cut
59              
60             __PACKAGE__->mk_accessors(
61             qw/port ssl_port
62             auth_class model_class connection_class
63             command_class
64             poll_every
65             unauth_idle auth_idle unauth_commands
66             /
67             );
68              
69             =head2 new PARAMHASH
70              
71             Creates a new IMAP server object. This doesn't even bind to the
72             sockets; it merely initializes the object. It will C if it
73             cannot find the appropriate certificate files. Valid arguments to
74             C include:
75              
76             =over
77              
78             =item port
79              
80             The port to bind to. Defaults to port 1430.
81              
82             =item ssl_port
83              
84             The port to open an SSL listener on; by default, this is disabled, and
85             any true value enables it.
86              
87             =item auth_class
88              
89             The name of the class which implements authentication. This must be a
90             subclass of L.
91              
92             =item model_class
93              
94             The name of the class which implements the model backend. This must
95             be a subclass of L.
96              
97             =item connection_class
98              
99             On rare occasions, you may wish to subclass the connection class; this
100             class must be a subclass of L.
101              
102             =item poll_every
103              
104             How often the current mailbox should be polled, in seconds; defaults
105             to 0, which means it will be polled after every client command.
106              
107             =item unauth_commands
108              
109             The number of commands before unauthenticated users are disconnected.
110             The default is 10; set to zero to disable.
111              
112             =item unauth_idle
113              
114             How long, in seconds, to wait before disconnecting idle connections
115             which have not authenticated yet. The default is 5 minutes; set to
116             zero to disable (which is not advised).
117              
118             =item auth_idle
119              
120             How long, in seconds, to wait before disconnecting authenticated
121             connections. By RFC specification, this B be longer than 30
122             minutes. The default is an hour; set to zero to disable.
123              
124             =item server_cert
125              
126             Path to the SSL certificate that the server should use. This can be
127             either a relative or absolute path.
128              
129             =item server_key
130              
131             Path to the SSL certificate key that the server should use. This can
132             be either a relative or absolute path.
133              
134             =back
135              
136             It also accepts the following L arguments -- see its
137             documentation for details on their use.
138              
139             =over
140              
141             =item L
142              
143             =item L
144              
145             =item L
146              
147             =item L
148              
149             =item L
150              
151             =item L
152              
153             =item L
154              
155             =item L
156              
157             =item L
158              
159             =item L
160              
161             =item L
162              
163             =item L
164              
165             =item L
166              
167             =item L
168              
169             =item L
170              
171             =back
172              
173             =cut
174              
175             sub new {
176             my $class = shift;
177              
178             my $self = Class::Accessor::new(
179             $class,
180             { port => 1430,
181             ssl_port => 0,
182             auth_class => "Net::IMAP::Server::DefaultAuth",
183             model_class => "Net::IMAP::Server::DefaultModel",
184             connection_class => "Net::IMAP::Server::Connection",
185             poll_every => 0,
186             unauth_idle => 5*60,
187             auth_idle => 60*60,
188             unauth_commands => 10,
189             @_,
190             command_class => {},
191             connection => {},
192             }
193             );
194              
195             $self->{server}{$_} = $self->{$_}
196             for grep {defined $self->{$_}}
197             qw/log_level log_file
198             syslog_logsock syslog_ident syslog_logopt syslog_facility
199             pid_file chroot user group
200             reverse_lookups allow deny cidr_allow cidr_deny
201             /;
202              
203             UNIVERSAL::require( $self->auth_class )
204             or die "Can't require auth class: $@\n";
205             $self->auth_class->isa("Net::IMAP::Server::DefaultAuth")
206             or die
207             "Auth class (@{[$self->auth_class]}) doesn't inherit from Net::IMAP::Server::DefaultAuth\n";
208              
209             UNIVERSAL::require( $self->model_class )
210             or die "Can't require model class: $@\n";
211             $self->model_class->isa("Net::IMAP::Server::DefaultModel")
212             or die
213             "Model class (@{[$self->model_class]}) doesn't inherit from Net::IMAP::Server::DefaultModel\n";
214              
215             UNIVERSAL::require( $self->connection_class )
216             or die "Can't require connection class: $@\n";
217             $self->connection_class->isa("Net::IMAP::Server::Connection")
218             or die
219             "Connection class (@{[$self->connection_class]}) doesn't inherit from Net::IMAP::Server::Connection\n";
220              
221             return $self;
222             }
223              
224             =head2 run
225              
226             Starts the server; this method shouldn't be expected to return.
227             Within this method, C<$Net::IMAP::Server::Server> is set to the object
228             that this was called on; thus, all IMAP objects have a way of
229             referring to the server -- and though L, whatever parts
230             of the IMAP internals they need.
231              
232             Any arguments are passed through to L.
233              
234             =cut
235              
236             sub run {
237             my $self = shift;
238             my @proto = qw/TCP/;
239             my @port = $self->port;
240             if ( $self->ssl_port ) {
241             push @proto, "SSL";
242             push @port, $self->ssl_port;
243             }
244             local $Net::IMAP::Server::Server = $self;
245             $self->SUPER::run(
246             @_,
247             proto => \@proto,
248             port => \@port,
249             );
250             }
251              
252             =head2 process_request
253              
254             Accepts a client connection; this method is needed for the
255             L infrastructure.
256              
257             =cut
258              
259             sub process_request {
260             my $self = shift;
261             my $handle = $self->{server}{client};
262             my $conn = $self->connection_class->new(
263             io_handle => $handle,
264             server => $self,
265             );
266             $self->connection($conn);
267             $conn->handle_lines;
268             }
269              
270             =head2 DESTROY
271              
272             On destruction, ensure that we close all client connections and
273             listening sockets.
274              
275             =cut
276              
277             DESTROY {
278             my $self = shift;
279             $_->close for grep { defined $_ } @{ $self->connections };
280             $self->server_close;
281             }
282              
283             =head2 connections
284              
285             Returns an arrayref of L objects which
286             are currently connected to the server.
287              
288             =cut
289              
290             sub connections {
291             my $self = shift;
292             return [ values %{$self->{connection}} ];
293             }
294              
295             =head2 connection
296              
297             Returns the currently active L object,
298             if there is one. This is determined by examining the current
299             coroutine.
300              
301             =cut
302              
303             sub connection {
304             my $class = shift;
305             my $self = ref $class ? $class : $Net::IMAP::Server::Server;
306             if (@_) {
307             if (defined $_[0]) {
308             $self->{connection}{$Coro::current . ""} = shift;
309             } else {
310             delete $self->{connection}{$Coro::current . ""};
311             }
312             }
313             return $self->{connection}{$Coro::current . ""};
314             }
315              
316             =head2 concurrent_mailbox_connections [MAILBOX]
317              
318             This can be called as either a class method or an instance method; it
319             returns the set of connections which are concurrently connected to the
320             given mailbox object (which defaults to the current connection's
321             selected mailbox)
322              
323             =cut
324              
325             sub concurrent_mailbox_connections {
326             my $class = shift;
327             my $self = ref $class ? $class : $Net::IMAP::Server::Server;
328             my $selected = shift || $self->connection->selected;
329              
330             return () unless $selected;
331             return
332             grep { $_->is_auth and $_->is_selected and $_->selected eq $selected }
333             @{ $self->connections };
334             }
335              
336             =head2 concurrent_user_connections [USER]
337              
338             This can be called as either a class method or an instance method; it
339             returns the set of connections whose
340             L is the same as the given
341             L (which defaults to the current connection's user)
342              
343             =cut
344              
345             sub concurrent_user_connections {
346             my $class = shift;
347             my $self = ref $class ? $class : $Net::IMAP::Server::Server;
348             my $user = shift || $self->connection->auth->user;
349              
350             return () unless $user;
351             return
352             grep { $_->is_auth and $_->auth->user eq $user }
353             @{ $self->connections };
354             }
355              
356             =head2 capability
357              
358             Returns the C string for the server. This string my be
359             modified by the connection before being sent to the client (see
360             L).
361              
362             =cut
363              
364             sub capability {
365             my $self = shift;
366             return "IMAP4rev1 STARTTLS CHILDREN LITERAL+ UIDPLUS ID NAMESPACE";
367             }
368              
369             =head2 id
370              
371             Returns a hash of properties to be conveyed to the client, should they
372             ask the server's identity.
373              
374             =cut
375              
376             sub id {
377             return (
378             name => "Net-IMAP-Server",
379             version => $Net::IMAP::Server::VERSION,
380             );
381             }
382              
383             =head2 add_command NAME => PACKAGE
384              
385             Adds the given command C to the server's list of known commands.
386             C should be the name of a class which inherits from
387             L.
388              
389             =cut
390              
391             sub add_command {
392             my $self = shift;
393             my ($name, $package) = @_;
394             if (not $package->require) {
395             $self->log( 1, $@ );
396             } elsif (not $package->isa('Net::IMAP::Server::Command')) {
397             $self->log( 1, "$package is not a Net::IMAP::Server::Command!" );
398             } else {
399             $self->command_class->{uc $name} = $package;
400             }
401             }
402              
403             =head2 log SEVERITY, MESSAGE
404              
405             By default, defers to L, which outputs to syslog, a
406             logfile, or STDERR, depending how it was configured. L's
407             default is to print to STDERR. If you have custom logging needs,
408             override this method, or L.
409              
410             =cut
411              
412             1; # Magic true value required at end of module
413             __END__