#! /usr/bin/perl

# mail-people.pl

# Given an LDAP filter,

# Read an email template which contains strings of the form
# #ldap_attribute_in_upper_case# and look up those attributes from
# the entries selected by the filter, substitute the attribute values
# found and send the email to the people.

# Provides options to just print to standard output instead of sending
# the emails, and also a limit of the number to send (just to check it
# seems okay).

# Accepts a list of UIDs to send the email to, from stdin or files on
# command line.  Good for send warning letters to students.

# Email sending is based on simple_mime.pl from figure 7.6 on page 185
# of "Network Programming with Perl" by Lincoln Stein

# Copyright (C) 2004  Nick Urbanik <nicku(at)vtc.edu.hk>

# This program is free software; you can redistribute it and/or
# modify it under the terms of the GNU General Public License
# as published by the Free Software Foundation; either version 2
# of the License, or (at your option) any later version.

# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.

# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.

# $Id: mail-people.pl,v 1.6 2004/05/17 04:18:58 nicku Exp $
# $Log: mail-people.pl,v $
# Revision 1.6  2004/05/17 04:18:58  nicku
# Made the situation more clear about whether a message was sent or
# not.  Now we say if it has been "sent" or just "processed".
#
# Revision 1.5  2004/03/18 18:57:36  nicku
# Added CC option (used to CC to Tony Siu)
# modified filter to a simple search for uid.  Probably should specify
# what attribute to search for in an option.
#
# Revision 1.4  2004/03/08 07:19:43  nicku
# Added support for ~/.signature file.
#
# Revision 1.3  2004/03/06 00:53:14  nicku
# Fixed syntax error (Oh dear!)
# Added options of sender and bcc to make this useful to others besides myself.
#
# Revision 1.2  2004/03/06 00:18:35  nicku
# Added support for substitution of the subject line as well as the
# email body, since it is convenient and trivial to implement.

use warnings;
use strict;
use MIME::Entity;
use Carp;
use Getopt::Long;
use Net::LDAP;
use MIME::Types;

use constant ICT_LDAP_SERVER => 'ldap.tyict.vtc.edu.hk';
use constant ICT_DIR_BASE => 'ou=People,dc=tyict,dc=vtc,dc=edu,dc=hk';
use constant MAX_EMAIL_COUNT_DEFAULT => 200;
use constant DEFAULT_FILTER => '(&(course=41300)(year=2))';
use constant DEFAULT_SCOPE => 'one';
use constant DEFAULT_SENDER => '"Nick Urbanik" <nicku@vtc.edu.hk>';

# Format of the email template:
# File is the text of an email, but tokens are replaced
# if they occur, such as:
#  #CN#             => cn
#  #CLASSCODE#      => classcode
#  #GIVENNAME#      => givenname
#  #SN#             => sn
#  #INSTITUTEEMAIL# => instituteEmail
# Can use any LDAP attribute in upper case between a pair of hashes.
# THE FIRST LINE IS THE SUBJECT.

sub read_template($) {
    my $email_template_file = shift;
    open TEMPLATE, "<", $email_template_file
        or die "Unable to open $email_template_file: $!";
    my $subject = <TEMPLATE>;
    my $email_body;
    {
        local $/;
        $email_body = <TEMPLATE>;
    }
    close TEMPLATE;
    return ( $subject, $email_body );
}

# Scan the string for strings of the form #[A-Z]+#
# return a lowercased list of them.

# The parameter is the string that is the raw template:
sub get_attributes($) {
    local $_ = shift;
    my @attrs = map { lc } m/#([A-Z]+)#/gs;
    push @attrs, 'instituteemail'
        unless grep { lc $_ eq 'instituteemail' } @attrs;
    push @attrs, 'cn'
        unless grep { lc $_ eq 'cn' } @attrs;
    # print "\@attrs=@attrs\n";
    return @attrs;
}

sub edit_template(\%$$) {
    my ( $attrs, $template, $subject ) = @_;
    while ( my ( $attr, $value ) = each %$attrs ) {
        $template =~ s/#\U$attr\E#/$value/g;
        $subject  =~ s/#\U$attr\E#/$value/g;
    }
    return ( $template, $subject );
}

our $print = 1;
our $send_email = 0;
our $limit = MAX_EMAIL_COUNT_DEFAULT;
our $sender = DEFAULT_SENDER;
our $bcc = DEFAULT_SENDER;
our $cc;
our $sign = 1;

our $email_sent_count = 0;

sub send_email_to(\%\$$\@)
{
    my ( $attr, $template, $subj, $attachments ) = @_;
    my ( $email_body, $subject ) = edit_template %$attr, $$template, $subj;
    my $name = $$attr{cn} or die "No name to send to: %$attr\n";
    my $email = $$attr{instituteemail} or die "No email for $name\n";

    my %entity_params = (
            Sender              => $sender,
            'Return-Path'       => $sender,
            From                => $sender,
            Subject             => $subject,
            To                  => "\"$name\" <$email>",
            Data                => $email_body,
                                  );
    $entity_params{Bcc} = $bcc if $bcc;
    $entity_params{Cc}  = $cc if $cc;
    # create a top-level entity:
    my $msg = MIME::Entity->build( %entity_params );
    foreach my $a ( @$attachments ) {
        my $ext = $a;
        print "Cannot find attachment $a\n" and next unless -r $a;
        $ext =~ s/.*\.([^.]+)$/$1/;
        my $mimetypes = MIME::Types->new;
        my $mime_type = $mimetypes->mimeTypeOf( $ext );
        $msg->attach(
                     Type => $mime_type,
                     Path => $a,
                    );
    }

    $msg->sign( File => "$ENV{HOME}/.signature" )
        or die "unable to sign: $!" if $sign;

    if ( $send_email ) {
        eval {
            print "sending to $name <$email>\n";
            $msg->send( 'sendmail' ) or die "Could not send: $!";
        };
        warn $@ if $@;
        print "sent to $name <$email>\n" unless $@;
    }

    $msg->print( \*STDOUT ) if $print;
    print 'Email ', ++$email_sent_count, " to $name\t<$email> processed\n";
    print "Reached limit\n" and exit 0 if $email_sent_count == $limit;
}

our $debug = 0;

sub search_for($$$$$$\@\@) {
    my ( $ldap, $filter, $base, $scope, $template,
         $subject, $attrs, $attachments ) = @_;
    my $mesg = $ldap->search(
                             base   => $base,
                             filter => $filter,
                             scope  => $scope,
                             attrs  => $attrs,
                            );

    if ( $mesg->code ) {
        warn $mesg->error;
        return;
    }

    foreach my $entry ( $mesg->entries ) {
        my %attr;
        foreach my $attr ( $entry->attributes ) {
            $attr{lc $attr} = $entry->get_value( $attr );
            # Want to truncate given names like Kim-man, Albert to Albert:
            if ( lc $attr eq 'givenname'
                 and index( $attr{lc $attr}, ',' ) > -1 ) {
                $attr{lc $attr} =~ s/.*,\s+([^,]+$)/$1/;
            }
        }
        while ( my ( $a, $v ) = each %attr ) {
            print "key=$a, value=$v.\n" if $debug;
        }
        send_email_to %attr, $template, $subject, @$attachments;
    }
}

our $filter        = DEFAULT_FILTER;
our $server        = ICT_LDAP_SERVER;
our $base          = ICT_DIR_BASE;
our $template_file = "email.templ";
our $scope         = DEFAULT_SCOPE;
our $read_uids     = 0;
our @attachments;

sub usage() {
    my $program = $0;
    $program =~ s!.*/(.*)!$1!;
    print <<USAGE;
usage: $program OPTIONS
OPTIONS:
   OPTION           DEFAULT
   --ldapserver=s   $server
   --base=s         $base
   --filter=s       $filter
   --limit=i        $limit
   --print!         $print
   --mail!          $send_email
   --verbose|debug! $debug
   --template=s     $template_file
   --scope=s        $scope
   --read-uids!     $read_uids
   --sender=s       $sender
   --bcc=s          $bcc
   --cc=s           $cc
   --sign!          $sign (Attach signature from $ENV{HOME}/.signature)
   --attach=s       @attachments

Some useful filters to copy and paste/edit:
(&(course=41300)(year=2)(|(classCode=X)(classCode=W)))
(&(course=41300)(year=3))
(&(course=41300)(year=3)(registrationDate=*-03))
(&(course=41300)(year=3)(registrationDate=*-03)(classCode=W))
(&(course=41300)(year=3)(registrationDate=*-03)(|(classCode=X)(classCode=W)))
(acType=STF*)

Format of the email template:
File is the text of an email, but tokens are replaced
if they occur, such as:
#CN#             => cn
#CLASSCODE#      => classcode
#GIVENNAME#      => givenname
#SN#             => sn
#INSTITUTEEMAIL# => instituteEmail
#YEAR#           => year
#COURSE#         => course
Can use any LDAP attribute in upper case between a pair of hashes.
THE FIRST LINE IS THE SUBJECT.
USAGE
    exit 1;
}

GetOptions(
           'ldapserver=s'   => \$server,
           'base=s'         => \$base,
           'filter=s'       => \$filter,
           'limit=i'        => \$limit,
           'print!'         => \$print,
           'mail!'          => \$send_email,
           'verbose|debug!' => \$debug,
           'template=s'     => \$template_file,
           'scope=s'        => \$scope,
           'read-uids!'     => \$read_uids,
           'sender=s'       => \$sender,
           'bcc=s'          => \$bcc,
           'cc=s'           => \$cc,
           'sign!'          => \$sign,
           'attach=s'       => \@attachments,
           'help'           => \&usage,
          ) or usage;

our ( $subject, $template ) = read_template $template_file;
our @attrs = get_attributes $template;

our $ldap = Net::LDAP->new( $server ) or die "$@";
my $r = $ldap->bind;

if ( $read_uids ) {
    while ( <> ) {
        chomp;
        # remove comments, allow them anywhere:
        s/\s*#.*//;
        next unless length > 1;
        #my $thefilter = "(&$filter(uid=$_))";
        my $thefilter = "(uid=$_)";
        search_for $ldap, $thefilter, $base, $scope, $template, $subject,
            @attrs, @attachments;
    }
} else {
    search_for $ldap, $filter, $base, $scope, $template, $subject, @attrs,
        @attachments;
}

$ldap->unbind;