lib/PublicInbox/POP3.pm

   1 # Copyright (C) all contributors <meta@public-inbox.org>
   2 # License: AGPL-3.0+ <https://www.gnu.org/licenses/agpl-3.0.txt>
   3 #
   4 # Each instance of this represents a POP3 client connected to
   5 # public-inbox-{netd,pop3d}.  Much of this was taken from IMAP.pm and NNTP.pm
   6 #
   7 # POP3 is one mailbox per-user, so the "USER" command is like the
   8 # format of -imapd and is mapped to $NEWSGROUP.$SLICE (large inboxes
   9 # are sliced into 50K mailboxes in both POP3 and IMAP to avoid overloading
  10 # clients)
  11 #
  12 # Unlike IMAP, the "$NEWSGROUP" mailbox (without $SLICE) is a rolling
  13 # window of the latest messages.  We can do this for POP3 since the
  14 # typical POP3 session is short-lived while long-lived IMAP sessions
  15 # would cause slices to grow on the server side without bounds.
  16 #
  17 # Like IMAP, POP3 also has per-session message sequence numbers (MSN),
  18 # which require mapping to UIDs.  The offset of an entry into our
  19 # per-client cache is: (MSN-1)
  20 #
  21 # fields:
  22 # - uuid - 16-byte (binary) UUID representation (before successful login)
  23 # - cache - one-dimentional arrayref of (UID, bytesize, oidhex)
  24 # - nr_dele - number of deleted messages
  25 # - expire - string of packed unsigned short offsets
  26 # - user_id - user-ID mapped to UUID (on successful login + lock)
  27 # - txn_max_uid - for storing max deleted UID persistently
  28 # - ibx - PublicInbox::Inbox object
  29 # - slice - unsigned integer slice number (0..Inf), -1 => latest
  30 # - salt - pre-auth for APOP
  31 # - uid_dele - maximum deleted from previous session at login (NNTP ARTICLE)
  32 # - uid_base - base UID for mailbox slice (0-based) (same as IMAP)
  33 package PublicInbox::POP3;
  34 use v5.12;
  35 use parent qw(PublicInbox::DS);
  36 use PublicInbox::GitAsyncCat;
  37 use PublicInbox::DS qw(now);
  38 use Errno qw(EAGAIN);
  39 use Digest::MD5 qw(md5);
  40 use PublicInbox::IMAP; # for UID slice stuff
  41
  42 use constant {
  43         LINE_MAX => 512, # XXX unsure
  44 };
  45
  46 # XXX FIXME: duplicated stuff from NNTP.pm and IMAP.pm
  47
  48 sub out ($$;@) {
  49         my ($self, $fmt, @args) = @_;
  50         printf { $self->{pop3d}->{out} } $fmt."\n", @args;
  51 }
  52
  53 sub do_greet {
  54         my ($self) = @_;
  55         my $s = $self->{salt} = sprintf('%x.%x', int(rand(0x7fffffff)), time);
  56         $self->write("+OK POP3 server ready <$s\@public-inbox>\r\n");
  57 }
  58
  59 sub new {
  60         my ($cls, $sock, $pop3d) = @_;
  61         (bless { pop3d => $pop3d }, $cls)->greet($sock)
  62 }
  63
  64 # POP user is $UUID1@$NEWSGROUP.$SLICE
  65 sub cmd_user ($$) {
  66         my ($self, $mailbox) = @_;
  67         $self->{salt} // return \"-ERR already authed\r\n";
  68         $mailbox =~ s/\A([a-f0-9\-]+)\@//i or
  69                 return \"-ERR no UUID@ in mailbox name\r\n";
  70         my $user = $1;
  71         $user =~ tr/-//d; # most have dashes, some (dbus-uuidgen) don't
  72         $user =~ m!\A[a-f0-9]{32}\z!i or return \"-ERR user has no UUID\r\n";
  73         my $slice;
  74         $mailbox =~ s/\.([0-9]+)\z// and $slice = $1 + 0;
  75         my $ibx = $self->{pop3d}->{pi_cfg}->lookup_newsgroup($mailbox) //
  76                 return \"-ERR $mailbox does not exist\r\n";
  77         my $uidmax = $ibx->mm(1)->num_highwater // 0;
  78         if (defined $slice) {
  79                 my $max = int($uidmax / PublicInbox::IMAP::UID_SLICE);
  80                 my $tip = "$mailbox.$max";
  81                 return \"-ERR $mailbox.$slice does not exist ($tip does)\r\n"
  82                         if $slice > $max;
  83                 $self->{uid_base} = $slice * PublicInbox::IMAP::UID_SLICE;
  84                 $self->{slice} = $slice;
  85         } else { # latest 50K messages
  86                 my $base = $uidmax - PublicInbox::IMAP::UID_SLICE;
  87                 $self->{uid_base} = $base < 0 ? 0 : $base;
  88                 $self->{slice} = -1;
  89         }
  90         $self->{ibx} = $ibx;
  91         $self->{uuid} = pack('H*', $user); # deleted by _login_ok
  92         $slice //= '(latest)';
  93         \"+OK $ibx->{newsgroup} slice=$slice selected\r\n";
  94 }
  95
  96 sub _login_ok ($) {
  97         my ($self) = @_;
  98         if ($self->{pop3d}->lock_mailbox($self)) {
  99                 $self->{uid_max} = $self->{ibx}->over(1)->max;
 100                 \"+OK logged in\r\n";
 101         } else {
 102                 \"-ERR [IN-USE] unable to lock maildrop\r\n";
 103         }
 104 }
 105
 106 sub cmd_apop {
 107         my ($self, $mailbox, $hex) = @_;
 108         my $res = cmd_user($self, $mailbox); # sets {uuid}
 109         return $res if substr($$res, 0, 1) eq '-';
 110         my $s = delete($self->{salt}) // die 'BUG: salt missing';
 111         return _login_ok($self) if md5("<$s\@public-inbox>anonymous") eq
 112                                 pack('H*', $hex);
 113         $self->{salt} = $s;
 114         \"-ERR APOP password mismatch\r\n";
 115 }
 116
 117 sub cmd_pass {
 118         my ($self, $pass) = @_;
 119         $self->{ibx} // return \"-ERR mailbox unspecified\r\n";
 120         my $s = delete($self->{salt}) // return \"-ERR already authed\r\n";
 121         return _login_ok($self) if $pass eq 'anonymous';
 122         $self->{salt} = $s;
 123         \"-ERR password is not `anonymous'\r\n";
 124 }
 125
 126 sub cmd_stls {
 127         my ($self) = @_;
 128         ($self->{sock} // return)->can('stop_SSL') and
 129                 return \"-ERR TLS already enabled\r\n";
 130         $self->{pop3d}->{ssl_ctx_opt} or
 131                 return \"-ERR can't start TLS negotiation\r\n";
 132         $self->write(\"+OK begin TLS negotiation now\r\n");
 133         PublicInbox::TLS::start($self->{sock}, $self->{pop3d});
 134         $self->requeue if PublicInbox::DS::accept_tls_step($self);
 135         undef;
 136 }
 137
 138 sub need_txn ($) {
 139         exists($_[0]->{salt}) ? \"-ERR not in TRANSACTION\r\n" : undef;
 140 }
 141
 142 sub _stat_cache ($) {
 143         my ($self) = @_;
 144         my ($beg, $end) = (($self->{uid_dele} // -1) + 1, $self->{uid_max});
 145         PublicInbox::IMAP::uid_clamp($self, \$beg, \$end);
 146         my (@cache, $m);
 147         my $sth = $self->{ibx}->over(1)->dbh->prepare_cached(<<'', undef, 1);
 148 SELECT num,ddd FROM over WHERE num >= ? AND num <= ?
 149 ORDER BY num ASC
 150
 151         $sth->execute($beg, $end);
 152         do {
 153                 $m = $sth->fetchall_arrayref({}, 1000);
 154                 for my $x (@$m) {
 155                         PublicInbox::Over::load_from_row($x);
 156                         push(@cache, $x->{num}, $x->{bytes} + 0, $x->{blob});
 157                         undef $x; # saves ~1.5M memory w/ 50k messages
 158                 }
 159         } while (scalar(@$m) && ($beg = $cache[-3] + 1));
 160         \@cache;
 161 }
 162
 163 sub cmd_stat {
 164         my ($self) = @_;
 165         my $err; $err = need_txn($self) and return $err;
 166         my $cache = $self->{cache} //= _stat_cache($self);
 167         my $tot = 0;
 168         for (my $i = 1; $i < scalar(@$cache); $i += 3) { $tot += $cache->[$i] }
 169         my $nr = @$cache / 3 - ($self->{nr_dele} // 0);
 170         "+OK $nr $tot\r\n";
 171 }
 172
 173 # for LIST and UIDL
 174 sub _list {
 175         my ($desc, $idx, $self, $msn) = @_;
 176         my $err; $err = need_txn($self) and return $err;
 177         my $cache = $self->{cache} //= _stat_cache($self);
 178         if (defined $msn) {
 179                 my $base_off = ($msn - 1) * 3;
 180                 my $val = $cache->[$base_off + $idx] //
 181                                 return \"-ERR no such message\r\n";
 182                 "+OK $desc listing follows\r\n$msn $val\r\n.\r\n";
 183         } else { # always +OK, even if no messages
 184                 my $res = "+OK $desc listing follows\r\n";
 185                 my $msn = 0;
 186                 for (my $i = 0; $i < scalar(@$cache); $i += 3) {
 187                         ++$msn;
 188                         defined($cache->[$i]) and
 189                                 $res .= "$msn $cache->[$i + $idx]\r\n";
 190                 }
 191                 $res .= ".\r\n";
 192         }
 193 }
 194
 195 sub cmd_list { _list('scan', 1, @_) }
 196 sub cmd_uidl { _list('unique-id', 2, @_) }
 197
 198 sub mark_dele ($$) {
 199         my ($self, $off) = @_;
 200         my $base_off = $off * 3;
 201         my $cache = $self->{cache};
 202         my $uid = $cache->[$base_off] // return; # already deleted
 203
 204         my $old = $self->{txn_max_uid} //= $uid;
 205         $self->{txn_max_uid} = $uid if $uid > $old;
 206
 207         $cache->[$base_off] = undef; # clobber UID
 208         $cache->[$base_off + 1] = 0; # zero bytes (simplifies cmd_stat)
 209         $cache->[$base_off + 2] = undef; # clobber oidhex
 210         ++$self->{nr_dele};
 211 }
 212
 213 sub retr_cb { # called by git->cat_async via ibx_async_cat
 214         my ($bref, $oid, $type, $size, $args) = @_;
 215         my ($self, $off, $top_nr) = @$args;
 216         my $hex = $self->{cache}->[$off * 3 + 2] //
 217                 die "BUG: no hex (oid=$oid)";
 218         if (!defined($oid)) {
 219                 # it's possible to have TOCTOU if an admin runs
 220                 # public-inbox-(edit|purge), just move onto the next message
 221                 warn "E: $hex missing in $self->{ibx}->{inboxdir}\n";
 222                 $self->write(\"-ERR no such message\r\n");
 223                 return $self->requeue;
 224         } elsif ($hex ne $oid) {
 225                 $self->close;
 226                 die "BUG: $hex != $oid";
 227         }
 228         PublicInbox::IMAP::to_crlf_full($bref);
 229         if (defined $top_nr) {
 230                 my ($hdr, $bdy) = split(/\r\n\r\n/, $$bref, 2);
 231                 $bref = \$hdr;
 232                 $hdr .= "\r\n\r\n";
 233                 my @tmp = split(/^/m, $bdy);
 234                 $hdr .= join('', splice(@tmp, 0, $top_nr));
 235         } elsif (exists $self->{expire}) {
 236                 $self->{expire} .= pack('S', $off + 1);
 237         }
 238         $$bref =~ s/^\./../gms;
 239         $$bref .= substr($$bref, -2, 2) eq "\r\n" ? ".\r\n" : "\r\n.\r\n";
 240         $self->msg_more("+OK message follows\r\n");
 241         $self->write($bref);
 242         $self->requeue;
 243 }
 244
 245 sub cmd_retr {
 246         my ($self, $msn, $top_nr) = @_;
 247         return \"-ERR lines must be a non-negative number\r\n" if
 248                         (defined($top_nr) && $top_nr !~ /\A[0-9]+\z/);
 249         my $err; $err = need_txn($self) and return $err;
 250         my $cache = $self->{cache} //= _stat_cache($self);
 251         my $off = $msn - 1;
 252         my $hex = $cache->[$off * 3 + 2] // return \"-ERR no such message\r\n";
 253         ${ibx_async_cat($self->{ibx}, $hex, \&retr_cb,
 254                         [ $self, $off, $top_nr ])};
 255 }
 256
 257 sub cmd_noop { $_[0]->write(\"+OK\r\n") }
 258
 259 sub cmd_rset {
 260         my ($self) = @_;
 261         my $err; $err = need_txn($self) and return $err;
 262         delete $self->{cache};
 263         delete $self->{txn_max_uid};
 264         \"+OK\r\n";
 265 }
 266
 267 sub cmd_dele {
 268         my ($self, $msn) = @_;
 269         my $err; $err = need_txn($self) and return $err;
 270         $self->{cache} //= _stat_cache($self);
 271         $msn =~ /\A[1-9][0-9]*\z/ or return \"-ERR no such message\r\n";
 272         mark_dele($self, $msn - 1) ? \"+OK\r\n" : \"-ERR no such message\r\n";
 273 }
 274
 275 # RFC 2449
 276 sub cmd_capa {
 277         my ($self) = @_;
 278         my $STLS = !$self->{ibx} && !$self->{sock}->can('stop_SSL') &&
 279                         $self->{pop3d}->{ssl_ctx_opt} ? "\nSTLS\r" : '';
 280         $self->{expire} = ''; # "EXPIRE 0" allows clients to avoid DELE commands
 281         <<EOM;
 282 +OK Capability list follows\r
 283 TOP\r
 284 USER\r
 285 PIPELINING\r
 286 UIDL\r
 287 EXPIRE 0\r
 288 RESP-CODES\r$STLS
 289 .\r
 290 EOM
 291 }
 292
 293 sub close {
 294         my ($self) = @_;
 295         $self->{pop3d}->unlock_mailbox($self);
 296         $self->SUPER::close;
 297 }
 298
 299 # must be called inside a state_dbh transaction with flock held
 300 sub __cleanup_state {
 301         my ($self, $txn_id) = @_;
 302         my $user_id = $self->{user_id} // die 'BUG: no {user_id}';
 303         $self->{pop3d}->{-state_dbh}->prepare_cached(<<'')->execute($txn_id);
 304 DELETE FROM deletes WHERE txn_id = ? AND uid_dele = -1
 305
 306         my $sth = $self->{pop3d}->{-state_dbh}->prepare_cached(<<'');
 307 SELECT COUNT(*) FROM deletes WHERE user_id = ?
 308
 309         $sth->execute($user_id);
 310         my $nr = $sth->fetchrow_array;
 311         if ($nr == 0) {
 312                 $sth = $self->{pop3d}->{-state_dbh}->prepare_cached(<<'');
 313 DELETE FROM users WHERE user_id = ?
 314
 315                 $sth->execute($user_id);
 316         }
 317         $nr;
 318 }
 319
 320 sub cmd_quit {
 321         my ($self) = @_;
 322         if (defined(my $txn_id = $self->{txn_id})) {
 323                 my $user_id = $self->{user_id} // die 'BUG: no {user_id}';
 324                 if (my $exp = delete $self->{expire}) {
 325                         mark_dele($self, $_) for unpack('S*', $exp);
 326                 }
 327                 my $keep = 1;
 328                 my $dbh = $self->{pop3d}->{-state_dbh};
 329                 my $lk = $self->{pop3d}->lock_for_scope;
 330                 $dbh->begin_work;
 331
 332                 if (defined(my $max = $self->{txn_max_uid})) {
 333                         $dbh->prepare_cached(<<'')->execute($max, $txn_id, $max)
 334 UPDATE deletes SET uid_dele = ? WHERE txn_id = ? AND uid_dele < ?
 335
 336                 } else {
 337                         $keep = $self->__cleanup_state($txn_id);
 338                 }
 339                 $dbh->prepare_cached(<<'')->execute(time, $user_id) if $keep;
 340 UPDATE users SET last_seen = ? WHERE user_id = ?
 341
 342                 $dbh->commit;
 343                 # we MUST do txn_id F_UNLCK here inside ->lock_for_scope:
 344                 $self->{did_quit} = 1;
 345                 $self->{pop3d}->unlock_mailbox($self);
 346         }
 347         $self->write(\"+OK public-inbox POP3 server signing off\r\n");
 348         $self->close;
 349         undef;
 350 }
 351
 352 # returns 1 if we can continue, 0 if not due to buffered writes or disconnect
 353 sub process_line ($$) {
 354         my ($self, $l) = @_;
 355         my ($req, @args) = split(/[ \t]+/, $l);
 356         return 1 unless defined($req); # skip blank line
 357         $req = $self->can('cmd_'.lc($req));
 358         my $res = $req ? eval { $req->($self, @args) } :
 359                 \"-ERR command not recognized\r\n";
 360         my $err = $@;
 361         if ($err && $self->{sock}) {
 362                 $l =~ s/\r?\n//s;
 363                 warn("error from: $l ($err)\n");
 364                 $res = \"-ERR program fault - command not performed\r\n";
 365         }
 366         defined($res) ? $self->write($res) : 0;
 367 }
 368
 369 # callback used by PublicInbox::DS for any (e)poll (in/out/hup/err)
 370 sub event_step {
 371         my ($self) = @_;
 372         local $SIG{__WARN__} = $self->{pop3d}->{warn_cb};
 373         return unless $self->flush_write && $self->{sock} && !$self->{long_cb};
 374
 375         # only read more requests if we've drained the write buffer,
 376         # otherwise we can be buffering infinitely w/o backpressure
 377         my $rbuf = $self->{rbuf} // \(my $x = '');
 378         my $line = index($$rbuf, "\n");
 379         while ($line < 0) {
 380                 return $self->close if length($$rbuf) >= LINE_MAX;
 381                 $self->do_read($rbuf, LINE_MAX, length($$rbuf)) or return;
 382                 $line = index($$rbuf, "\n");
 383         }
 384         $line = substr($$rbuf, 0, $line + 1, '');
 385         $line =~ s/\r?\n\z//s;
 386         return $self->close if $line =~ /[[:cntrl:]]/s;
 387         my $t0 = now();
 388         my $fd = fileno($self->{sock}); # may become invalid after process_line
 389         my $r = eval { process_line($self, $line) };
 390         my $pending = $self->{wbuf} ? ' pending' : '';
 391         out($self, "[$fd] %s - %0.6f$pending - $r", $line, now() - $t0);
 392         return $self->close if $r < 0;
 393         $self->rbuf_idle($rbuf);
 394
 395         # maybe there's more pipelined data, or we'll have
 396         # to register it for socket-readiness notifications
 397         $self->requeue unless $pending;
 398 }
 399
 400 no warnings 'once';
 401 *cmd_top = \&cmd_retr;
 402
 403 1;