lib/PublicInbox/IMAP.pm

   1 # Copyright (C) 2020 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 an IMAP client connected to
   5 # public-inbox-imapd.  Much of this was taken from NNTP, but
   6 # further refined while experimenting on future ideas to handle
   7 # slow storage.
   8 #
   9 # data notes:
  10 # * NNTP article numbers are UIDs and message sequence numbers (MSNs)
  11 # * Message sequence numbers (MSNs) can be stable since we're read-only.
  12 #   Most IMAP clients use UIDs (I hope), and we can return a dummy
  13 #   message if a client requests a non-existent MSN.
  14
  15 package PublicInbox::IMAP;
  16 use strict;
  17 use base qw(PublicInbox::DS);
  18 use fields qw(imapd logged_in ibx long_cb -login_tag);
  19 use PublicInbox::Eml;
  20 use PublicInbox::DS qw(now);
  21 use PublicInbox::Syscall qw(EPOLLIN EPOLLONESHOT);
  22 use Errno qw(EAGAIN);
  23 my $Address;
  24 for my $mod (qw(Email::Address::XS Mail::Address)) {
  25         eval "require $mod" or next;
  26         $Address = $mod and last;
  27 }
  28 die "neither Email::Address::XS nor Mail::Address loaded: $@" if !$Address;
  29
  30 sub LINE_MAX () { 512 } # does RFC 3501 have a limit like RFC 977?
  31
  32 my %FETCH_NEED_BLOB = ( # for future optimization
  33         'BODY.PEEK[HEADER]' => 1,
  34         'BODY.PEEK[TEXT]' => 1,
  35         'BODY.PEEK[]' => 1,
  36         'BODY[HEADER]' => 1,
  37         'BODY[TEXT]' => 1,
  38         'BODY[]' => 1,
  39         'RFC822.HEADER' => 1,
  40         'RFC822.SIZE' => 1, # needs CRLF conversion :<
  41         'RFC822.TEXT' => 1,
  42         BODY => 1,
  43         BODYSTRUCTURE => 1,
  44         ENVELOPE => 1,
  45         FLAGS => 0,
  46         INTERNALDATE => 0,
  47         RFC822 => 1,
  48         UID => 0,
  49 );
  50 my %FETCH_ATT = map { $_ => [ $_ ] } keys %FETCH_NEED_BLOB;
  51
  52 # aliases (RFC 3501 section 6.4.5)
  53 $FETCH_ATT{FAST} = [ qw(FLAGS INTERNALDATE RFC822.SIZE) ];
  54 $FETCH_ATT{ALL} = [ @{$FETCH_ATT{FAST}}, 'ENVELOPE' ];
  55 $FETCH_ATT{FULL} = [ @{$FETCH_ATT{ALL}}, 'BODY' ];
  56
  57 for my $att (keys %FETCH_ATT) {
  58         my %h = map { $_ => 1 } @{$FETCH_ATT{$att}};
  59         $FETCH_ATT{$att} = \%h;
  60 }
  61
  62 sub greet ($) {
  63         my ($self) = @_;
  64         my $capa = capa($self);
  65         $self->write(\"* OK [$capa] public-inbox-imapd ready\r\n");
  66 }
  67
  68 sub new ($$$) {
  69         my ($class, $sock, $imapd) = @_;
  70         my $self = fields::new($class);
  71         my $ev = EPOLLIN;
  72         my $wbuf;
  73         if ($sock->can('accept_SSL') && !$sock->accept_SSL) {
  74                 return CORE::close($sock) if $! != EAGAIN;
  75                 $ev = PublicInbox::TLS::epollbit();
  76                 $wbuf = [ \&PublicInbox::DS::accept_tls_step, \&greet ];
  77         }
  78         $self->SUPER::new($sock, $ev | EPOLLONESHOT);
  79         $self->{imapd} = $imapd;
  80         if ($wbuf) {
  81                 $self->{wbuf} = $wbuf;
  82         } else {
  83                 greet($self);
  84         }
  85         $self->update_idle_time;
  86         $self;
  87 }
  88
  89 sub capa ($) {
  90         my ($self) = @_;
  91         my $capa = 'CAPABILITY IMAP4rev1';
  92         if ($self->{logged_in}) {
  93                 $capa .= ' COMPRESS=DEFLATE';
  94         } else {
  95                 if (!($self->{sock} // $self)->can('accept_SSL') &&
  96                         $self->{imapd}->{accept_tls}) {
  97                         $capa .= ' STARTTLS';
  98                 }
  99                 $capa .= ' AUTH=ANONYMOUS';
 100         }
 101 }
 102
 103 sub login_success ($$) {
 104         my ($self, $tag) = @_;
 105         $self->{logged_in} = 1;
 106         my $capa = capa($self);
 107         "$tag OK [$capa] Logged in\r\n";
 108 }
 109
 110 sub auth_challenge_ok ($) {
 111         my ($self) = @_;
 112         my $tag = delete($self->{-login_tag}) or return;
 113         login_success($self, $tag);
 114 }
 115
 116 sub cmd_login ($$$$) {
 117         my ($self, $tag) = @_; # ignore ($user, $password) = ($_[2], $_[3])
 118         login_success($self, $tag);
 119 }
 120
 121 sub cmd_logout ($$) {
 122         my ($self, $tag) = @_;
 123         delete $self->{logged_in};
 124         $self->write(\"* BYE logging out\r\n$tag OK logout completed\r\n");
 125         $self->shutdn; # PublicInbox::DS::shutdn
 126         undef;
 127 }
 128
 129 sub cmd_authenticate ($$$) {
 130         my ($self, $tag) = @_; # $method = $_[2], should be "ANONYMOUS"
 131         $self->{-login_tag} = $tag;
 132         "+\r\n"; # challenge
 133 }
 134
 135 sub cmd_capability ($$) {
 136         my ($self, $tag) = @_;
 137         '* '.capa($self)."\r\n$tag OK\r\n";
 138 }
 139
 140 sub cmd_noop ($$) { "$_[1] OK NOOP completed\r\n" }
 141
 142 sub cmd_examine ($$$) {
 143         my ($self, $tag, $mailbox) = @_;
 144         my $ibx = $self->{imapd}->{groups}->{$mailbox} or
 145                 return "$tag NO Mailbox doesn't exist: $mailbox\r\n";
 146         my $mm = $ibx->mm;
 147         my $max = $mm->num_highwater // 0;
 148         # RFC 3501 2.3.1.1 -  "A good UIDVALIDITY value to use in
 149         # this case is a 32-bit representation of the creation
 150         # date/time of the mailbox"
 151         my $uidvalidity = $mm->created_at or return "$tag BAD UIDVALIDITY\r\n";
 152         my $uidnext = $max + 1;
 153
 154         # XXX: do we need this? RFC 5162/7162
 155         my $ret = $self->{ibx} ? "* OK [CLOSED] previous closed\r\n" : '';
 156         $self->{ibx} = $ibx;
 157         $ret .= <<EOF;
 158 * $max EXISTS\r
 159 * $max RECENT\r
 160 * FLAGS (\\Seen)\r
 161 * OK [PERMANENTFLAGS ()] Read-only mailbox\r
 162 EOF
 163         $ret .= "* OK [UNSEEN $max]\r\n" if $max;
 164         $ret .= "* OK [UIDNEXT $uidnext]\r\n" if defined $uidnext;
 165         $ret .= "* OK [UIDVALIDITY $uidvalidity]\r\n" if defined $uidvalidity;
 166         $ret .= "$tag OK [READ-ONLY] EXAMINE/SELECT complete\r\n";
 167 }
 168
 169 sub _esc ($) {
 170         my ($v) = @_;
 171         if (!defined($v)) {
 172                 'NIL';
 173         } elsif ($v =~ /[{"\r\n%*\\\[]/) { # literal string
 174                 '{' . length($v) . "}\r\n" . $v;
 175         } else { # quoted string
 176                 qq{"$v"}
 177         }
 178 }
 179
 180 sub addr_envelope ($$;$) {
 181         my ($eml, $x, $y) = @_;
 182         my $v = $eml->header_raw($x) //
 183                 ($y ? $eml->header_raw($y) : undef) // return 'NIL';
 184
 185         my @x = $Address->parse($v) or return 'NIL';
 186         '(' . join('',
 187                 map { '(' . join(' ',
 188                                 _esc($_->name), 'NIL',
 189                                 _esc($_->user), _esc($_->host)
 190                         ) . ')'
 191                 } @x) .
 192         ')';
 193 }
 194
 195 sub eml_envelope ($) {
 196         my ($eml) = @_;
 197         '(' . join(' ',
 198                 _esc($eml->header_raw('Date')),
 199                 _esc($eml->header_raw('Subject')),
 200                 addr_envelope($eml, 'From'),
 201                 addr_envelope($eml, 'Sender', 'From'),
 202                 addr_envelope($eml, 'Reply-To', 'From'),
 203                 addr_envelope($eml, 'To'),
 204                 addr_envelope($eml, 'Cc'),
 205                 addr_envelope($eml, 'Bcc'),
 206                 _esc($eml->header_raw('In-Reply-To')),
 207                 _esc($eml->header_raw('Message-ID')),
 208         ) . ')';
 209 }
 210
 211 sub uid_fetch_cb { # called by git->cat_async
 212         my ($bref, $oid, $type, $size, $fetch_m_arg) = @_;
 213         my ($self, undef, $ibx, undef, undef, $msgs, $want) = @$fetch_m_arg;
 214         my $smsg = shift @$msgs or die 'BUG: no smsg';
 215         $smsg->{blob} eq $oid or die "BUG: $smsg->{blob} != $oid";
 216         $$bref =~ s/(?<!\r)\n/\r\n/sg; # make strict clients happy
 217
 218         # fixup old bug from import (pre-a0c07cba0e5d8b6a)
 219         $$bref =~ s/\A[\r\n]*From [^\r\n]*\r\n//s;
 220
 221         $self->msg_more("* $smsg->{num} FETCH (UID $smsg->{num}");
 222
 223         $want->{'RFC822.SIZE'} and
 224                 $self->msg_more(' RFC822.SIZE '.length($$bref));
 225         $want->{INTERNALDATE} and
 226                 $self->msg_more(' INTERNALDATE "'.$smsg->internaldate.'"');
 227         $want->{FLAGS} and $self->msg_more(' FLAGS ()');
 228         for ('RFC822', 'BODY[]', 'BODY.PEEK[]') {
 229                 next unless $want->{$_};
 230                 $self->msg_more(" $_ {".length($$bref)."}\r\n");
 231                 $self->msg_more($$bref);
 232         }
 233
 234         my $eml = PublicInbox::Eml->new($bref);
 235
 236         $want->{ENVELOPE} and
 237                 $self->msg_more(' ENVELOPE '.eml_envelope($eml));
 238
 239         for my $f ('RFC822.HEADER', 'BODY[HEADER]', 'BODY.PEEK[HEADER]') {
 240                 next unless $want->{$f};
 241                 $self->msg_more(" $f {".length(${$eml->{hdr}})."}\r\n");
 242                 $self->msg_more(${$eml->{hdr}});
 243         }
 244         for my $f ('RFC822.TEXT', 'BODY[TEXT]') {
 245                 next unless $want->{$f};
 246                 $self->msg_more(" $f {".length($$bref)."}\r\n");
 247                 $self->msg_more($$bref);
 248         }
 249         # TODO BODY/BODYSTRUCTURE, specific headers
 250         $self->msg_more(")\r\n");
 251 }
 252
 253 sub uid_fetch_m { # long_response
 254         my ($self, $tag, $ibx, $beg, $end, $msgs, $want) = @_;
 255         if (!@$msgs) { # refill
 256                 @$msgs = @{$ibx->over->query_xover($$beg, $end)};
 257                 if (!@$msgs) {
 258                         $self->write(\"$tag OK Fetch done\r\n");
 259                         return;
 260                 }
 261                 $$beg = $msgs->[-1]->{num} + 1;
 262         }
 263         my $git = $ibx->git;
 264         $git->cat_async_begin; # TODO: actually make async
 265         $git->cat_async($msgs->[0]->{blob}, \&uid_fetch_cb, \@_);
 266         $git->cat_async_wait;
 267         1;
 268 }
 269
 270 sub cmd_uid_fetch ($$$;@) {
 271         my ($self, $tag, $range, @want) = @_;
 272         my $ibx = $self->{ibx} or return "$tag BAD No mailbox selected\r\n";
 273         if ($want[0] =~ s/\A\(//s) {
 274                 $want[-1] =~ s/\)\z//s or return "$tag BAD no rparen\r\n";
 275         }
 276         my %want = map {;
 277                 my $x = $FETCH_ATT{uc($_)} or return "$tag BAD param: $_\r\n";
 278                 %$x;
 279         } @want;
 280         my ($beg, $end);
 281         my $msgs = [];
 282         if ($range =~ /\A([0-9]+):([0-9]+)\z/s) {
 283                 ($beg, $end) = ($1, $2);
 284         } elsif ($range =~ /\A([0-9]+):\*\z/s) {
 285                 ($beg, $end) =  ($1, $ibx->mm->num_highwater // 0);
 286         } elsif ($range =~ /\A[0-9]+\z/) {
 287                 my $smsg = $ibx->over->get_art($range) or return "$tag OK\r\n";
 288                 push @$msgs, $smsg;
 289                 ($beg, $end) = ($range, 0);
 290         } else {
 291                 return "$tag BAD\r\n";
 292         }
 293         long_response($self, \&uid_fetch_m, $tag, $ibx,
 294                                 \$beg, $end, $msgs, \%want);
 295 }
 296
 297 sub uid_search_all { # long_response
 298         my ($self, $tag, $ibx, $num) = @_;
 299         my $uids = $ibx->mm->ids_after($num);
 300         if (scalar(@$uids)) {
 301                 $self->msg_more(join(' ', '', @$uids));
 302         } else {
 303                 $self->write(\"\r\n$tag OK\r\n");
 304                 undef;
 305         }
 306 }
 307
 308 sub uid_search_uid_range { # long_response
 309         my ($self, $tag, $ibx, $beg, $end) = @_;
 310         my $uids = $ibx->mm->msg_range($beg, $end, 'num');
 311         if (@$uids) {
 312                 $self->msg_more(join('', map { " $_->[0]" } @$uids));
 313         } else {
 314                 $self->write(\"\r\n$tag OK\r\n");
 315                 undef;
 316         }
 317 }
 318
 319 sub cmd_uid_search ($$$;) {
 320         my ($self, $tag, $arg, @rest) = @_;
 321         my $ibx = $self->{ibx} or return "$tag BAD No mailbox selected\r\n";
 322         $arg = uc($arg);
 323         if ($arg eq 'ALL' && !@rest) {
 324                 $self->msg_more('* SEARCH');
 325                 my $num = 0;
 326                 long_response($self, \&uid_search_all, $tag, $ibx, \$num);
 327         } elsif ($arg eq 'UID' && scalar(@rest) == 1) {
 328                 if ($rest[0] =~ /\A([0-9]+):([0-9]+|\*)\z/s) {
 329                         my ($beg, $end) = ($1, $2);
 330                         $end = ($ibx->mm->minmax)[1] if $end eq '*';
 331                         $self->msg_more('* SEARCH');
 332                         long_response($self, \&uid_search_uid_range,
 333                                         $tag, $ibx, \$beg, $end);
 334                 } elsif ($rest[0] =~ /\A[0-9]+\z/s) {
 335                         my $uid = $rest[0];
 336                         $uid = $ibx->over->get_art($uid) ? " $uid" : '';
 337                         "* SEARCH$uid\r\n$tag OK\r\n";
 338                 } else {
 339                         "$tag BAD\r\n";
 340                 }
 341         } else {
 342                 "$tag BAD\r\n";
 343         }
 344 }
 345
 346 sub args_ok ($$) { # duplicated from PublicInbox::NNTP
 347         my ($cb, $argc) = @_;
 348         my $tot = prototype $cb;
 349         my ($nreq, undef) = split(';', $tot);
 350         $nreq = ($nreq =~ tr/$//) - 1;
 351         $tot = ($tot =~ tr/$//) - 1;
 352         ($argc <= $tot && $argc >= $nreq);
 353 }
 354
 355 # returns 1 if we can continue, 0 if not due to buffered writes or disconnect
 356 sub process_line ($$) {
 357         my ($self, $l) = @_;
 358         my ($tag, $req, @args) = split(/[ \t]+/, $l);
 359         if (@args && uc($req) eq 'UID') {
 360                 $req .= "_".(shift @args);
 361         }
 362         my $res = eval {
 363                 if (my $cmd = $self->can('cmd_'.lc($req // ''))) {
 364                         $cmd->($self, $tag, @args);
 365                 } else { # this is weird
 366                         auth_challenge_ok($self) //
 367                                 "$tag BAD Error in IMAP command $req: ".
 368                                 "Unknown command\r\n";
 369                 }
 370         };
 371         my $err = $@;
 372         if ($err && $self->{sock}) {
 373                 $l =~ s/\r?\n//s;
 374                 err($self, 'error from: %s (%s)', $l, $err);
 375                 $res = "$tag BAD program fault - command not performed\r\n";
 376         }
 377         return 0 unless defined $res;
 378         $self->write($res);
 379 }
 380
 381 sub long_step {
 382         my ($self) = @_;
 383         # wbuf is unset or empty, here; {long} may add to it
 384         my ($fd, $cb, $t0, @args) = @{$self->{long_cb}};
 385         my $more = eval { $cb->($self, @args) };
 386         if ($@ || !$self->{sock}) { # something bad happened...
 387                 delete $self->{long_cb};
 388                 my $elapsed = now() - $t0;
 389                 if ($@) {
 390                         err($self,
 391                             "%s during long response[$fd] - %0.6f",
 392                             $@, $elapsed);
 393                 }
 394                 out($self, " deferred[$fd] aborted - %0.6f", $elapsed);
 395                 $self->close;
 396         } elsif ($more) { # $self->{wbuf}:
 397                 $self->update_idle_time;
 398
 399                 # COMPRESS users all share the same DEFLATE context.
 400                 # Flush it here to ensure clients don't see
 401                 # each other's data
 402                 $self->zflush;
 403
 404                 # no recursion, schedule another call ASAP, but only after
 405                 # all pending writes are done.  autovivify wbuf:
 406                 my $new_size = push(@{$self->{wbuf}}, \&long_step);
 407
 408                 # wbuf may be populated by $cb, no need to rearm if so:
 409                 $self->requeue if $new_size == 1;
 410         } else { # all done!
 411                 delete $self->{long_cb};
 412                 my $elapsed = now() - $t0;
 413                 my $fd = fileno($self->{sock});
 414                 out($self, " deferred[$fd] done - %0.6f", $elapsed);
 415                 my $wbuf = $self->{wbuf}; # do NOT autovivify
 416
 417                 $self->requeue unless $wbuf && @$wbuf;
 418         }
 419 }
 420
 421 sub err ($$;@) {
 422         my ($self, $fmt, @args) = @_;
 423         printf { $self->{imapd}->{err} } $fmt."\n", @args;
 424 }
 425
 426 sub out ($$;@) {
 427         my ($self, $fmt, @args) = @_;
 428         printf { $self->{imapd}->{out} } $fmt."\n", @args;
 429 }
 430
 431 sub long_response ($$;@) {
 432         my ($self, $cb, @args) = @_; # cb returns true if more, false if done
 433
 434         my $sock = $self->{sock} or return;
 435         # make sure we disable reading during a long response,
 436         # clients should not be sending us stuff and making us do more
 437         # work while we are stream a response to them
 438         $self->{long_cb} = [ fileno($sock), $cb, now(), @args ];
 439         long_step($self); # kick off!
 440         undef;
 441 }
 442
 443 # callback used by PublicInbox::DS for any (e)poll (in/out/hup/err)
 444 sub event_step {
 445         my ($self) = @_;
 446
 447         return unless $self->flush_write && $self->{sock};
 448
 449         $self->update_idle_time;
 450         # only read more requests if we've drained the write buffer,
 451         # otherwise we can be buffering infinitely w/o backpressure
 452
 453         my $rbuf = $self->{rbuf} // (\(my $x = ''));
 454         my $r = 1;
 455
 456         if (index($$rbuf, "\n") < 0) {
 457                 my $off = length($$rbuf);
 458                 $r = $self->do_read($rbuf, LINE_MAX, $off) or return;
 459         }
 460         while ($r > 0 && $$rbuf =~ s/\A[ \t]*([^\n]*?)\r?\n//) {
 461                 my $line = $1;
 462                 return $self->close if $line =~ /[[:cntrl:]]/s;
 463                 my $t0 = now();
 464                 my $fd = fileno($self->{sock});
 465                 $r = eval { process_line($self, $line) };
 466                 my $pending = $self->{wbuf} ? ' pending' : '';
 467                 out($self, "[$fd] %s - %0.6f$pending", $line, now() - $t0);
 468         }
 469
 470         return $self->close if $r < 0;
 471         my $len = length($$rbuf);
 472         return $self->close if ($len >= LINE_MAX);
 473         $self->rbuf_idle($rbuf);
 474         $self->update_idle_time;
 475
 476         # maybe there's more pipelined data, or we'll have
 477         # to register it for socket-readiness notifications
 478         $self->requeue unless $self->{wbuf};
 479 }
 480
 481 sub compressed { undef }
 482
 483 sub zflush {} # overridden by IMAPdeflate
 484
 485 # RFC 4978
 486 sub cmd_compress ($$$) {
 487         my ($self, $tag, $alg) = @_;
 488         return "$tag BAD DEFLATE only\r\n" if uc($alg) ne "DEFLATE";
 489         return "$tag BAD COMPRESS active\r\n" if $self->compressed;
 490
 491         # CRIME made TLS compression obsolete
 492         # return "$tag NO [COMPRESSIONACTIVE]\r\n" if $self->tls_compressed;
 493
 494         PublicInbox::IMAPdeflate->enable($self, $tag);
 495         $self->requeue;
 496         undef
 497 }
 498
 499 sub cmd_starttls ($$) {
 500         my ($self, $tag) = @_;
 501         my $sock = $self->{sock} or return;
 502         if ($sock->can('stop_SSL') || $self->compressed) {
 503                 return "$tag BAD TLS or compression already enabled\r\n";
 504         }
 505         my $opt = $self->{imapd}->{accept_tls} or
 506                 return "$tag BAD can not initiate TLS negotiation\r\n";
 507         $self->write(\"$tag OK begin TLS negotiation now\r\n");
 508         $self->{sock} = IO::Socket::SSL->start_SSL($sock, %$opt);
 509         $self->requeue if PublicInbox::DS::accept_tls_step($self);
 510         undef;
 511 }
 512
 513 # for graceful shutdown in PublicInbox::Daemon:
 514 sub busy {
 515         my ($self, $now) = @_;
 516         ($self->{rbuf} || $self->{wbuf} || $self->not_idle_long($now));
 517 }
 518
 519 # we're read-only, so SELECT and EXAMINE do the same thing
 520 no warnings 'once';
 521 *cmd_select = \&cmd_examine;
 522
 523 1;