Perl/Snippets/IMAP Proxy

A Perl IMAP proxy that does some folder filtering, picked up at Mac OS X Hints.

#! /usr/bin/perl

# Copyright (C) 2004 Lars Eggert.
# All rights reserved.
#
# Redistribution and use in source and binary forms are permitted
# provided that the above copyright notice and this paragraph are
# duplicated in all such forms and that any documentation,
# advertising materials, and other materials related to such
# distribution and use acknowledge that the software was developed
# by the author. The name of the author may not be used to endorse
# or promote products derived from this software without specific
# prior written permission.
#
# THIS SOFTWARE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR
# IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED
# WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
# PURPOSE.

# $Id$


use warnings;
use strict;

use IO::Select;
# uncomment if SSL suport is required
# use IO::Socket::SSL;
use POSIX;

# these need to be perl regexps matching the desired IMAP folders, for example:
my @subscribed = qw(INBOX.*
                    user.ietf
                    user.ietf.(announce|hip|ietf|ipsec|postel.*)
                    user.ietf.(rfc-interest|tcpm|tsvwg|xml2rfc)
                    user.mmi.FreeBSD.*);


# Daemonize!
sub daemon () {
    sub _fork {
        if (defined (my $pid = fork)) { return $pid; }
        else { die "cannot fork: $!"; }
    }
        # fork and exit parent
    if (_fork) { exit 0; }
        # detach ourselves from the terminal
    POSIX::setsid or die "cannot detach from controlling terminal";

    # prevent possibility of acquiring a controlling terminal
    $SIG{'HUP'} = 'IGNORE';
    if (_fork) { exit 0; }
        # change working directory
    chdir "/";

    # clear file creation mask
    umask 0;

    # close open file descriptors
    foreach my $i (0..POSIX::sysconf(&POSIX::_SC_OPEN_MAX)) { POSIX::close $i; }
        # Reopen stderr, stdout, stdin to /dev/null
    open STDIN,  "+>/dev/null";
    open STDOUT, "| /usr/bin/logger -p user.notice";
    open STDERR, "+>&STDOUT";
    STDOUT->autoflush(1);
    STDERR->autoflush(1);
}

my $client = "localhost:143"; # 143 = imap
my (%mua, %imap, %done, %data);
daemon;
my $inbound =
  new IO::Socket::INET(LocalHost => $client, Listen => 15, ReuseAddr => 1);
my $select = IO::Select->new($inbound);
while (1) {
    my @ready = $select->can_read(5);
    foreach my $fd (@ready) {

        # a MUA is opening a new connection to us, open relay to server
        if ($fd == $inbound) {
            # be smart about what NEC server to use
            my $new_mua = $inbound->accept;
            my $new_imap = new IO::Socket::INET("IMAP-SERVER:143");
            # IMAPS is also possible
            # my $new_imap = new IO::Socket::SSL("IMAPS-SERVER:993");
            unless (defined $new_imap) {
                $new_mua->close;
            } else {
                $select->add($new_mua, $new_imap);
                $mua{$new_mua} = $new_imap;
                $imap{$new_imap} = $new_mua;
            }
        # the IMAP server is sending something to the MUA, filter and relay
        } elsif (exists $imap{$fd}) {
            while(1) {
                $fd->blocking(0);
                my $result = sysread $fd, $_, 16384;
                if (not defined $result) {
                    # if we've filtered once before, no need to do this at all
                    last if $done{$fd} or not defined $data{$fd};

                    # check if we have a full mboxlist in data, and if so,
                    # return a filtered version to the MUA
                    if ($data{$fd} =~ /^* LIST () /m) {
                        # data contains list of imap folders
                        if ($data{$fd} =~ /^d+ OK Completed (.*)/m) {
                            # data contains COMPLETE list of folders, filter it
                            # (only folders matching regexps in @subscribed
                            # will be returned to the MUA)
                            foreach my $mbox (@subscribed) {
                                $data{$fd} =~ s/^(*s+)LIST(s+()
                                                s+.*"$mbox"rn)
                                               /$1KEEP$2/gmx;
                            }
                            $data{$fd} =~ s/^* LIST () .*rn//gm;
                            $data{$fd} =~ s/^(* )KEEP( () .*rn)/$1LIST$2/gm;
                            $imap{$fd}->blocking(1);
                            syswrite $imap{$fd}, $data{$fd};
                            delete $data{$fd};
                            $done{$fd} = 1;
                        }
                    } else {
                        # data contains something else, just relay it
                        $imap{$fd}->blocking(1);
                        syswrite $imap{$fd}, $data{$fd};
                        delete $data{$fd};
                    }
                    last;
                } elsif ($result > 0) {
                    if ($done{$fd}) {
                        $imap{$fd}->blocking(1);
                        syswrite $imap{$fd}, $_;
                    } else {
                        $data{$fd} .= $_;
                    }
                } elsif ($result == 0) {
                    # EOF, close the connections
                    $select->remove($fd, $imap{$fd});
                    $fd->close;
                    $imap{$fd}->close;
                    delete $data{$fd};
                    delete $done{$fd};
                    last;
                }
            }
                    # the MUA is sending something to the IMAP server, just relay
        } elsif (exists $mua{$fd}) {
            while (1) {
                $fd->blocking(0);
                my $result = sysread $fd, $_, 16384;
                if (not defined $result) {
                    last;
                } elsif ($result > 0) {
                    $mua{$fd}->blocking(1);
                    syswrite $mua{$fd}, $_;
                } elsif ($result == 0) {
                    # EOF, close the connections
                    $select->remove($fd, $mua{$fd});
                    $fd->close;
                    $mua{$fd}->close;
                    last;
                }
            }
        }
    }
}
$inbound->close;