File Coverage

blib/lib/Mail/POP3/Server.pm
Criterion Covered Total %
statement 165 246 67.0
branch 42 104 40.3
condition 6 21 28.5
subroutine 24 30 80.0
pod 23 23 100.0
total 260 424 61.3


line stmt bran cond sub pod time code
1             package Mail::POP3::Server;
2              
3 4     4   29 use strict;
  4         11  
  4         122  
4 4     4   20 use IO::Socket;
  4         8  
  4         22  
5 4     4   1883 use IO::File;
  4         38  
  4         508  
6 4     4   28 use POSIX;
  4         8  
  4         25  
7 4     4   8744 use IO::Select;
  4         7029  
  4         13996  
8              
9             =head2 POP3 command-handlers:
10              
11             =over
12              
13             =item commandUSER
14              
15             =item commandPASS
16              
17             =item commandLIST
18              
19             =item commandSTAT
20              
21             =item commandRETR
22              
23             =item commandDELE
24              
25             =item commandRSET
26              
27             =item commandQUIT
28              
29             =item commandNOOP
30              
31             =item commandUIDL
32              
33             =item commandTOP
34              
35             =back
36              
37             =cut
38              
39             # These are the only commands accepted
40             my %COMMAND2FUNC = (
41             USER => \&commandUSER,
42             PASS => \&commandPASS,
43             LIST => \&commandLIST,
44             STAT => \&commandSTAT,
45             RETR => \&commandRETR,
46             DELE => \&commandDELE,
47             RSET => \&commandRSET,
48             QUIT => \&commandQUIT,
49             NOOP => \&commandNOOP,
50             UIDL => \&commandUIDL,
51             TOP => \&commandTOP,
52             );
53             my %COMMAND2OKNOLOGIN = (
54             USER => 1,
55             PASS => 1,
56             QUIT => 1,
57             );
58             my $CRLF = "\015\012";
59              
60             =head2 new
61              
62             Takes config hash-ref.
63              
64             =cut
65              
66             sub new {
67 2     2 1 1538 my ($class, $config) = @_;
68 2         6 my $self = {};
69 2         4 bless $self, $class;
70 2         14 $self->{CONFIG} = $config;
71 2         6 $self->{CLIENT_CRYPT_PASSWD} = '';
72 2         4 $self->{MAILDIR} = "";
73 2         6 $self->{RECEIVED_HEADER} = ""; # these two are set in commandUSER
74 2         6 $self->{ADDEDBYTES} = 0;
75 2         4 $self->{MAILBOX_OPENED} = 0;
76 2         4 $self->{PASSWORD_GIVEN} = 0;
77 2         6 $self->{AUTH_TYPE} = $self->{CONFIG}->{auth_type};
78 2         6 $self;
79             }
80              
81             sub _make_closure {
82 6     6   25 my ($self, $subref) = @_;
83 6     0   265 sub { $subref->($self) };
  0         0  
84             }
85              
86             =head2 start
87              
88             Takes input, output filehandles, and client IP.
89              
90             =cut
91              
92             # Do the security checks and then get the first command
93             sub start {
94 1     1 1 2144 my ($self, $input_fh, $output_fh, $client_ip) = @_;
95 1         45 $self->{CLIENT_IP} = $client_ip;
96 1         82 $self->{CLIENT_FQDN} = $self->peer_lookup($self->{CLIENT_IP});
97 1         27 $self->{INPUT_FH} = $input_fh;
98 1         24 $self->{OUTPUT_FH} = $output_fh;
99             # Set the default output file handle
100 1         60 select $self->{OUTPUT_FH};
101 1         59 $| = 1;
102             # Try and catch anything nasty and restore mailbox. This can
103             # lead to emails being downloaded more than once but at least they
104             # shouldn't be lost.
105 1         40 local $SIG{HUP} = $self->_make_closure(\&force_shutdown);
106 1         37 local $SIG{TERM} = $self->_make_closure(\&force_shutdown);
107 1         27 local $SIG{PIPE} = $self->_make_closure(\&force_shutdown);
108 1 50       71 local $SIG{USR1} = $self->_make_closure(\&force_shutdown)
109             unless $^O =~ /MSWin32/;
110 1         20 local $SIG{SEGV} = $self->_make_closure(\&force_shutdown);
111             # Catch kernel alarms and close gracefully if the client stalls
112 1         22 local $SIG{ALRM} = $self->_make_closure(\&force_shutdown);
113             my $security_connection = $self->{CONFIG}->{connection_class}->new(
114             $self->{CONFIG}
115 1         105 );
116             my ($was_ok, $log_entry) = $security_connection->check(
117             $client_ip,
118             $self->{CLIENT_FQDN},
119 1         133 );
120 1 50       7 map { $self->log_entry($_) } @$log_entry if $self->{CONFIG}->{debug} == 1;
  0         0  
121 1 50       17 $self->shutdown unless $was_ok;
122             # Log the connection IP and time if global debugging is on
123 1 50 33     21 if ($self->{CONFIG}->{debug} and $self->{CONFIG}->{debug} == 1) {
124 1         31 $self->log_entry("$self->{CLIENT_IP}\tconnected at");
125             }
126             # Send the mpopd greeting.
127 1         60 print "+OK $self->{CONFIG}->{greeting}$CRLF";
128 1         6 while (1) {
129 8         63 my $request = "";
130 8         22 my $char;
131 8         95 my $select = IO::Select->new;
132 8         128 $select->add($input_fh);
133 8         616 while (1) {
134             # Set the kernel alarm for $self->{CONFIG}->{timeout}
135             # seconds and then only wait that long for the next command
136             # from the client.
137             # The whole read process is eval'ed. See man perlfunc -> portability
138 56         103 eval {
139 56 50       170 if ($^O !~ /MSWin32/) {
140             # can_read doesn't work on win32! rely on it just blocking
141             die "alarm\n"
142 56 50       181 unless $select->can_read($self->{CONFIG}->{timeout});
143             }
144 56         2355 sysread $input_fh, $char, 1;
145             };
146 56 50       146 if ($@) {
147 0 0       0 $self->force_shutdown('timeout') if $@ eq "alarm\n";
148             } else {
149 56 50       123 last unless defined $char;
150 56 100       115 last if $char eq "\012";
151 48         86 $request .= $char;
152             # commented because one should "be liberal in what one accepts"
153             # $self->force_shutdown('line too long') if (length($request) > 50);
154             }
155             }
156 8 50       32 $self->force_shutdown unless defined $char;
157             # remove all but alphanumeric chars and whitespace from the
158             # request, and only accept 3-50 chars total (UIDL could be long'ish)
159             # commented because one should "be liberal in what one accepts"
160             # $request =~ s/^([\s\w]{3,50})/$1/g;
161 8         50 $request =~ s/\r|\n//g;
162 8         65 my ($command, $arg, $arg1) = split /\s+/, $request, 3;
163 8 100       39 $arg = '' unless defined $arg;
164 8 100       20 $arg1 = '' unless defined $arg1;
165 8         18 $command = uc $command;
166 8         50 $self->log_user_entry("$command $arg $arg1");
167             # Close and warn if an invalid command is received
168 8 50       26 unless ($COMMAND2FUNC{$command}) {
169 0 0       0 $self->log_entry("$self->{CLIENT_IP}\tWARN no command sent, port scan? at") if $self->{CONFIG}->{debug} == 1;
170 0         0 $self->force_shutdown("So, that's the way you want it... :\(");
171             }
172 8 50 66     47 if (!$COMMAND2OKNOLOGIN{$command} and !$self->{PASSWORD_GIVEN}) {
173 0         0 $self->send_to_user("-ERR not logged in yet!");
174 0         0 next;
175             }
176 8         46 $COMMAND2FUNC{$command}->($self, $arg, $arg1);
177             }
178             }
179              
180             sub commandUSER {
181 1     1 1 5 my ($self, $arg, $arg1) = @_;
182 1         3 my $user_name = $arg;
183 1         20 $self->{CLIENT_USERNAME} = $user_name;
184 1 50       7 if ($self->{CONFIG}->{addreceived}->{$user_name}) {
185             $self->{RECEIVED_HEADER} =
186 1         75 "Received: from $self->{CONFIG}->{receivedfrom}$CRLF" .
187             " by mpopd V$self->{CONFIG}->{mpopd_conf_version}$CRLF" .
188             " for $user_name; " .
189             localtime(time) .
190             " $self->{CONFIG}->{timezone}$CRLF";
191 1         8 $self->{ADDEDBYTES} = length($self->{RECEIVED_HEADER});
192             }
193             $self->bad_user unless $self->{CONFIG}->{user_check}->(
194             $self->{CONFIG},
195             $user_name,
196             $self->{CLIENT_FQDN},
197 1 50       232 );
198 1         9 $self->log_user_open($user_name);
199 1         9 $self->log_user_entry("USER $user_name");
200 1         8 $self->send_to_user("+OK $user_name send me your password");
201             }
202              
203             sub commandPASS {
204 1     1 1 4 my ($self, $arg, $arg1) = @_;
205 1 50       7 if ($self->{MAILBOX_OPENED}) {
206 0         0 $self->send_to_user("-ERR already authenticated");
207 0         0 return;
208             }
209 1 50       5 unless ($self->{CLIENT_USERNAME}) {
210 0         0 $self->send_to_user("-ERR I need your USER name first!");
211 0         0 return;
212             }
213             # Check the password supplied
214             $self->{PASSWORD_GIVEN} = $self->{CONFIG}->{password_check}->(
215             $self->{CONFIG},
216             $self->{CLIENT_USERNAME},
217             $self->{CLIENT_FQDN},
218 1         33 $arg,
219             );
220 1 50       24 unless ($self->{PASSWORD_GIVEN}) {
221 0         0 $self->send_to_user(
222             "-ERR access denied $self->{CLIENT_USERNAME} $arg"
223             );
224 0         0 $self->shutdown;
225             }
226 1         16 load_class($self->{CONFIG}->{mailbox_class});
227             $self->{MAILBOX} = $self->{CONFIG}->{mailbox_class}->new(
228             $self->{CLIENT_USERNAME},
229             $arg,
230             $self->{CONFIG}->{mailbox_args}->(
231             $self->{CONFIG},
232             $self->{CLIENT_USERNAME},
233             $self->{CLIENT_FQDN},
234 1         9 ),
235             );
236 1         6 my $lockcnt = 0;
237 1         58 until ($self->{MAILBOX}->lock_acquire) {
238 0 0 0     0 if (
239             !$self->{CONFIG}->{retry_on_lock} or
240             $self->{CONFIG}->{retry_on_lock} == $lockcnt
241             ) {
242 0         0 $self->send_to_user("-ERR Could not get a lock on mailbox!");
243 0         0 return;
244             }
245 0         0 $lockcnt++; # here so if retry == 1, don't drop out first time
246 0         0 sleep 1;
247             }
248 1         7 $self->send_to_user("+OK thanks $self->{CLIENT_USERNAME}...");
249 1         5 $self->{MAILBOX_OPENED} = 1;
250             }
251              
252             =head2 load_class
253              
254             Loads class - function, not method.
255              
256             =cut
257              
258             sub load_class {
259 1     1 1 11 my ($class) = @_;
260 1         5 my $class_file = $class;
261 1         30 $class_file =~ s#::#/#g;
262 1         4 $class_file .= '.pm';
263 1         28 require $class_file;
264             }
265              
266             sub commandSTAT {
267 0     0 1 0 my ($self, $arg, $arg1) = @_;
268             $self->send_to_user(
269             "+OK ".$self->{MAILBOX}->messages." ".$self->{MAILBOX}->octets
270 0         0 );
271             }
272              
273             sub commandLIST {
274 0     0 1 0 my ($self, $arg, $arg1) = @_;
275 0 0       0 if ($arg) {
276 0 0       0 if (!$self->{MAILBOX}->is_valid($arg)) {
277 0         0 $self->send_to_user("-ERR message $arg is not valid");
278 0         0 return;
279             }
280 0         0 $self->send_to_user("+OK $arg " . $self->{MAILBOX}->octets($arg));
281 0         0 return;
282             }
283 0         0 $self->send_to_user("+OK ".$self->{MAILBOX}->messages." messages");
284 0         0 for (1..$self->{MAILBOX}->messages) {
285 0 0       0 if (!$self->{MAILBOX}->is_deleted($_)) {
286 0         0 print "$_ " . $self->{MAILBOX}->octets($_) . " octets$CRLF";
287             }
288             }
289 0         0 print ".$CRLF";
290             }
291              
292             # Send the email requested by $arg to the client
293             sub commandRETR {
294 1     1 1 4 my ($self, $arg, $arg1) = @_;
295 1 50       5 if (!$self->{MAILBOX}->is_valid($arg)) {
296 0         0 $self->send_to_user("-ERR message $arg is not valid");
297 0         0 return;
298             }
299 1         29 my $octets = $self->{MAILBOX}->octets($arg) + $self->{ADDEDBYTES};
300 1         15 print "+OK $octets octets$CRLF";
301 1         12 print $self->{RECEIVED_HEADER};
302 1         8 $self->{MAILBOX}->retrieve($arg, $self->{OUTPUT_FH});
303 1         13 print ".$CRLF";
304 1         15 $self->log_user_entry("RETRieved\t$octets");
305             }
306              
307             sub commandDELE {
308 1     1 1 4 my ($self, $arg, $arg1) = @_;
309 1 50       6 if (!$self->{MAILBOX}->is_valid($arg)) {
310 0         0 $self->send_to_user("-ERR message $arg is not valid");
311 0         0 return;
312             }
313 1         7 $self->send_to_user("+OK message $arg flagged for deletion");
314 1         27 $self->{MAILBOX}->delete($arg);
315             }
316              
317             sub commandNOOP {
318 0     0 1 0 my ($self, $arg, $arg1) = @_;
319 0         0 $self->send_to_user("+OK");
320             }
321              
322             sub commandRSET {
323 0     0 1 0 my ($self, $arg, $arg1) = @_;
324 0         0 $self->{MAILBOX}->reset;
325 0         0 $self->send_to_user("+OK all message flags reset");
326             }
327              
328             sub commandUIDL {
329 2     2 1 7 my ($self, $arg, $arg1) = @_;
330             #print Data::Dumper::Dumper($self->{MAILBOX});
331 2 50       4 if ($arg) {
332 0 0       0 if (!$self->{MAILBOX}->is_valid($arg)) {
333 0         0 $self->send_to_user("-ERR message $arg is not valid");
334 0         0 return;
335             }
336             # must be valid
337 0         0 $self->send_to_user("+OK $arg " . $self->{MAILBOX}->uidl($arg));
338 0         0 return;
339             }
340 2         8 $self->send_to_user("+OK unique-id listing follows");
341 2         26 $self->{MAILBOX}->uidl_list($self->{OUTPUT_FH});
342             }
343              
344             sub commandTOP {
345 1     1 1 3 my ($self, $arg, $arg1) = @_;
346 1         1 my $cnt;
347 1 50       35 if (!$self->{MAILBOX}->is_valid($arg)) {
348 0         0 $self->send_to_user("-ERR message $arg is not valid");
349 0         0 return;
350             }
351 1 50       6 unless ($arg1 >= 0) {
352 0         0 $self->send_to_user("-ERR TOP with wrong number of lines ($arg1)");
353 0         0 return;
354             }
355 1         6 $self->send_to_user("+OK top of message $arg follows");
356 1         11 print $self->{RECEIVED_HEADER};
357             my $top_bytes =
358             $self->{MAILBOX}->top($arg, $self->{OUTPUT_FH}, $arg1) +
359 1         16 $self->{ADDEDBYTES};
360 1         13 print ".$CRLF";
361 1         10 $self->log_user_entry(
362             "TOPped\t$top_bytes"
363             );
364             }
365              
366             sub commandQUIT {
367 1     1 1 5 my ($self, $arg, $arg1) = @_;
368 1 50       6 if (!$self->{CONFIG}->{user_debug}->{$self->{CLIENT_USERNAME}}) {
369 1         2 eval { $self->{MAILBOX}->flush_delete; };
  1         5  
370 1 50       46 if ($@) {
371 0         0 chomp $@;
372             $self->log_entry(
373             "$self->{CLIENT_IP}\t$self->{CLIENT_USERNAME} $@"
374 0 0       0 ) if $self->{CONFIG}->{debug} == 1;
375             }
376             }
377 1         8 $self->force_shutdown("+OK TTFN $self->{CLIENT_USERNAME}...");
378             }
379              
380             =head2 bad_user
381              
382             Handles bad user.
383              
384             =cut
385              
386             # Reject bogus login name and exit or fake a password auth
387             sub bad_user {
388 0     0 1 0 my $self = shift;
389 0 0       0 $self->log_entry("$self->{CLIENT_IP}\tBOGUS user name given at") if $self->{CONFIG}->{debug} == 1;
390 0 0       0 if ($self->{CONFIG}->{reject_bogus_user} == 1) {
391 0         0 print "-ERR no record here of $self->{CLIENT_USERNAME},...$CRLF";
392 0         0 $self->shutdown;
393             } else {
394 0         0 my $request;
395 0         0 print "+OK $self->{CLIENT_USERNAME} send me your password....$CRLF";
396 0         0 alarm 10;
397 0         0 sysread $self->{INPUT_FH}, $request, 1;
398 0         0 alarm 0;
399 0         0 print "-ERR access denied$CRLF";
400 0         0 $self->shutdown;
401             }
402             }
403              
404             =head2 peer_lookup
405              
406             Reverse lookup.
407              
408             =cut
409              
410             # do a reverse lookup
411             sub peer_lookup {
412 1     1 1 29 my ($self, $ip) = @_;
413 1         643 lc gethostbyaddr(inet_aton($ip), IO::Socket::AF_INET);
414             }
415              
416             =head2 log_user_open
417              
418             Optional per-user brief logging of connection times
419              
420             =cut
421              
422             sub log_user_open {
423 1     1 1 4 my ($self, $user_name) = @_;
424 1 50       8 return unless defined $self->{CONFIG}->{user_log}->{$user_name};
425 0 0       0 if (!-d $self->{CONFIG}->{user_log_dir}) {
426 0         0 mkdir $self->{CONFIG}->{user_log_dir};
427 0         0 chmod 01777, $self->{CONFIG}->{user_log_dir};
428             }
429 0         0 my $logfile = "$self->{CONFIG}->{user_log_dir}/${user_name}_log";
430 0         0 $self->{USERLOG_FH} = IO::File->new(
431             ">>$logfile"
432             );
433 0         0 eval {
434             # in case we're on Windoze...
435 0         0 chown((getpwnam $self->{CLIENT_USERNAME})[2], $logfile);
436 0         0 chmod 0600, $logfile;
437             };
438 0         0 $self->log_user_entry("CONNECTION OPENED");
439             }
440              
441             =head2 log_user_close
442              
443             =cut
444              
445             sub log_user_close {
446 1     1 1 4 my ($self) = @_;
447             return unless
448             $self->{USERLOG_FH} and
449 1 50 33     4 defined $self->{CONFIG}->{user_log}->{$self->{CLIENT_USERNAME}};
450 0         0 close $self->{USERLOG_FH};
451             }
452              
453             =head2 log_user_entry
454              
455             Record mpopd conversations in the individual mailbox log.
456              
457             =cut
458              
459             sub log_user_entry {
460 18     18 1 39 my ($self, $response) = @_;
461             return unless
462             $self->{USERLOG_FH} and
463             $self->{CONFIG}->{user_log}->{$self->{CLIENT_USERNAME}} and
464 18 0 33     143 $self->{CONFIG}->{user_log}->{$self->{CLIENT_USERNAME}} == 2;
      33        
465 0 0 0     0 if ($response =~ /^PASS\s+(.*)/ and $self->{CONFIG}->{passsecret}) {
466 0         0 $response =~ s/$1/******/;
467             }
468 0         0 $self->{USERLOG_FH}->print(localtime() . " $response\n");
469             }
470              
471             =head2 send_to_user
472              
473             Takes C<$text>, C<$log_suppress>.
474              
475             CRLF is added here, and also logged if C<$log_suppress> is false
476              
477             =cut
478              
479             sub send_to_user {
480 7     7 1 23 my ($self, $text, $log_suppress) = @_;
481 7         134 print "$text$CRLF";
482 7 50       38 $self->log_user_entry($text) unless $log_suppress;
483             }
484              
485             =head2 force_shutdown
486              
487             # Close the mailbox in a sane state and close the connection
488              
489             =cut
490              
491             sub force_shutdown {
492 1     1 1 4 my ($self, $signoff) = @_;
493 1 50       3 if ($signoff) {
494 1 50       7 if ($signoff eq "ALRM") {
    50          
495 0         0 $signoff = "Haven't got all day you know...";
496             } elsif ($signoff eq "USR1") {
497 0         0 $signoff = "My parent told me to close...";
498             }
499             $self->send_to_user(
500 1         2 $signoff
501             );
502             } else {
503 0         0 $self->send_to_user(
504             "Sorry your time is up :)"
505             );
506             }
507 1         4 $self->log_user_close;
508 1 50       3 if ($self->{MAILBOX_OPENED}) {
509 1         5 $self->{MAILBOX}->lock_release;
510             }
511 1         7 $self->shutdown;
512             }
513              
514             =head2 log_entry
515              
516             Write something in the main mpopd log
517              
518             =cut
519              
520             sub log_entry {
521 1     1 1 6 my ($self, $error) = @_;
522 1 50       28 return unless defined $self->{CONFIG}->{debug_log};
523 1         91 $> = 0;
524 1 50       18 unless ($self->{DEBUG_FH}) {
525 1         46 my ($debuglog_dir) = $self->{CONFIG}->{debug_log} =~ /^(.+)\//;
526 1 50       23 if (!-d $debuglog_dir) {
527 0         0 mkdir $debuglog_dir, 0700;
528             }
529 1 50       79 $self->{DEBUG_FH} = IO::File->new(">>$self->{CONFIG}->{debug_log}")
530             or die "open >>$self->{CONFIG}->{debug_log}: $!\n";
531 1 50       746 my $gid = $^O =~ /MSWin32/ ? 0 : getgrnam("root");
532 1         30 chown 0, $gid, $self->{CONFIG}->{debug_log};
533 1         40 chmod 0600, $self->{CONFIG}->{debug_log};
534             }
535 1         95 my $logtime = localtime(time);
536 1         113 $self->{DEBUG_FH}->print("$error\t$logtime\n");
537 1 50       43 $> = $self->{CLIENT_USER_ID} if $self->{CLIENT_USER_ID};
538             }
539              
540             =head2 shutdown
541              
542             Clean up and exit
543              
544             =cut
545              
546             sub shutdown {
547 1     1 1 3 my $self = shift;
548 1         8 close $self->{INPUT_FH};
549 1         217 exit(0);
550             }
551              
552             1;