#!/usr/pkg/bin/perl
# Program name: SendYmail
# Description: SendYmail allows you to send e-mails through Yahoo! Mail,
#              using your favorite e-mail client. SendYmail works as a
#              gateway between Yahoo! Mail web interface and your e-mail
#              program, and can be used in conjunction with FetchYahoo
#              (http://fetchyahoo.twizzler.org/) or
#              YoSucker (http://yosucker.sourceforge.net/) to emulate a
#              POP3/SMTP-like interface.
# Author: Anderson Lizardo <lizardo@users.sourceforge.net>
# Project: http://sourceforge.net/projects/sendymail/

# Copyright (C) 2003-2005 Anderson Lizardo
#
# 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

# Configuration File parsing code based on ParseConfigFile() subroutine
# from FetchYahoo (C) Ravi Ramkissoon
# Localization code based on Localize() subroutine from FetchYahoo

use strict;
use warnings;

require Crypt::SSLeay; # Needed for HTTPS protocol handling

use POSIX qw(setsid strftime);
use Digest::MD5 qw(md5_hex);
use LWP::UserAgent;
use HTTP::Cookies;
use MIME::Parser;
use MIME::Words qw(decode_mimewords);
use Mail::Address;
use File::Temp qw(tempdir);
use File::Path qw(rmtree);
use Getopt::Long;
use HTML::Form;

sub Log;
sub Login;
sub Logout;
sub Send_mail;
sub Attach_files;
sub Parse_mail;
sub Parse_config;
sub daemonize;
sub Get_intl;
sub Set_intl;

# Program version
my $version = "0.5.8";

# Temporary directory used in Send_mail() function
my $temp_dir = "";

# Configuration file
my $config_file = $ENV{"HOME"} . "/.sendymailrc";

# Yahoo! secure login site
my $login_url = "https://login.yahoo.com";

# Faked User Agent. This is only useful to avoid Yahoo identifying us as
# an automated script. You don't need to change this
my $user_agent = "Mozilla/5.0";

my %config = (
    background => 0,
    debug => 0,
    logout => 1,
    logfile => $ENV{"HOME"} . "/sendymail.log",
);

Parse_config($config_file);

open (LOGFILE, ">>" . $config{"logfile"}) or
die "Could not open log file " . $config{"logfile"} . ": $!\n";

# Autoflush LOGFILE
my $log_fh = select(LOGFILE); $| = 1; select($log_fh);

$SIG{INT} = sub {
    Log("Got SIGINT, removing temporary files...");
    rmtree($temp_dir, 0, 1);
    exit 130;
};
$SIG{__WARN__} = sub { Log("Warning: " . $_[0]) if $_[0]; };
$SIG{__DIE__} = sub {
    my ($error_msg) = @_;
    $error_msg =~ s/\n$//g;
    Log("Error: " . $error_msg);
    Log("Removing temporary files...");
    rmtree($temp_dir, 0, 1);
    die "Error: " . $error_msg . "\n";
};


Log("Starting SendYmail $version");

if (!$config{"username"} or !$config{"password"}) {
    die "Invalid username and/or password format on $config_file\n";
}

my $mail = Parse_mail();

if ($config{"background"}) {
    Log("Going to background...");
    daemonize();
}

my $ym_ua = LWP::UserAgent->new(cookie_jar => {}, agent => $user_agent);

my $ym_response = Login(
    lwp_ua => \$ym_ua,
    username => $config{"username"},
    password => $config{"password"},
);

Send_mail(
    lwp_ua => \$ym_ua,
    http_response => $ym_response,
    %$mail,
);

if ($config{"logout"}) {
    Logout(lwp_ua => \$ym_ua);
}

Log("Removing temporary files...");
rmtree($temp_dir, 0, 1);

Log("SendYmail finished");
close LOGFILE or die "Could not close log file: $!\n";

exit 0;

##############
# Subroutines
##############

# Log - print messages on log files
#  Log ($message)
#  message: log message
sub Log {
    my ($msg) = @_;
    print LOGFILE strftime('%b %d %T', localtime) . " [$$] $msg\n";
}

# Http_error - default interface for HTTP error messages
#  Http_error ($http_response)
#  http_response: HTTP::Response object to process
sub Http_error {
    my ($http_response) = @_;
    die "Could not access " . $http_response->request->uri . ": " .
    $http_response->status_line . "\n";
}

# Login - authenticate the user on Yahoo!
#  $http_response = Login (lwp_ua => \$lwp_ua,
#                          username => "username",
#                          password => "password")
#  username: Yahoo! user ID
#  password: user password
#  lwp_ua: LWP::UserAgent object of the opened YM session. It will be used on
#      others subroutines to identificate the session to be processed
#  http_response: HTTP::Response object of the last request made. This is
#      useful for obtaining the base URL.
sub Login {
    my %args = @_;
    Log("Authenticating user \"" . $args{"username"} . "\"...");
    # Access main page and prepares the authentication
    my $url = $login_url;
    my $response = ${$args{"lwp_ua"}}->get($url);
    Http_error($response) unless $response->is_success;

    my %i18n = Set_intl("common");
    if (!$response->content =~ /$i18n{"sign_in"}/) {
        die "Could not access main page\n";
    }

    my @forms = HTML::Form->parse($response->content, $response->base());
    foreach (@forms) { $_->attr("name", "") unless defined $_->attr("name") };
    @forms = grep $_->attr("name") eq "login_form", @forms;
    die "Form \"Login\" not found" unless @forms;
    my $form = shift @forms;

    $form->method("get");

    $form->value(".done", "http://mail.yahoo.com");

    # Needed for MD5 hashing
    $form->value(".js", 1);
    $form->value(".hash", 1);
    $form->value(".md5", 1);

    $form->value("login", $args{"username"});
    my $enc_passwd = md5_hex(md5_hex($args{"password"}) . $form->value(".challenge"));
    $form->value("passwd", $enc_passwd);
    
    $response = ${$args{"lwp_ua"}}->request($form->click);
    Http_error($response) unless $response->is_success;

    if ($response->content =~ /window.location.replace\("([^"]*)"/) {
        Log("Redirecting manually to $1...") if $config{"debug"};
        $response = ${$args{"lwp_ua"}}->get($1);
        Http_error($response) unless $response->is_success;
    }
    
    if ($response->content =~ /$i18n{"bad_password"}/) {
        die "Incorrect password for \"" . $args{"username"} . "\"\n";
    }
    elsif ($response->content =~ /$i18n{"bad_userid"}/) {
        die "User \"" . $args{"username"} . "\" does not exist\n";
    }
    elsif ($response->content =~ /$i18n{"server_down"}/) {
        die "Yahoo! services are currently unavailable\n";
    }

    return $response;
}

# Logout - close a Yahoo! Mail's session
#  $http_response = Logout (lwp_ua => \$lwp_ua)
sub Logout {
    my %args = @_;
    Log("Closing session...");
    my $response = ${$args{"lwp_ua"}}->get($login_url . "/config/login?logout=1");
    Http_error($response) unless $response->is_success;
    
    my %i18n = Set_intl("common");
    if ($response->content =~ /$i18n{"logout"}/) {
        Log("Session closed");
    }
    else {
        die "Could not close session\n";
    }
    return $response;
}

# TODO : add HTML mail support
#  Send_mail - send e-mails through Yahoo! Mail
#  $http_response = Send_mail(lwp_ua => \$lwp_ua,
#                             http_response => \$http_response,
#                             to => $to,
#                             cc => $cc,
#                             bcc => $bcc,
#                             subject => $subject,
#                             body => $body,
#                             attachments => \@attachments)
#   to: e-mail's receiver(s)
#   cc: carbon copy receiver(s)
#   bcc: hidden carbon copy receiver(s)
#   subject: message subject
#   body: message body
#   attachments: ARRAY with filenames to be attached
sub Send_mail {
    my %args = @_;
    Log("Accessing Yahoo! Mail main page...");
    my $response = ${$args{"lwp_ua"}}->get("http://mail.yahoo.com");
    Http_error($response) unless $response->is_success;

    Log("Composing message...");
    my $base_url = $response->base()->scheme() . "://" . $response->base()->host();
    $response = ${$args{"lwp_ua"}}->get($base_url . "/ym/Compose");
    Http_error($response) unless $response->is_success;

    if (!$response->content =~ /AttachFiles\(\)/) {
        die "Could not access Compose page\n";
    }

    my @forms = HTML::Form->parse($response->content, $response->base());
    foreach (@forms) { $_->attr("name", "") unless defined $_->attr("name") };
    @forms = grep $_->attr("name") eq "Compose", @forms;
    die "Form \"Compose\" not found" unless @forms;
    my $form = shift @forms;

    $form->value("To", $args{"to"});
    $form->value("Cc", $args{"cc"});
    $form->value("Bcc", $args{"bcc"});
    $form->value("Subj", $args{"subject"});
    $form->value("Body", $args{"body"});
    Attach_files(
        lwp_ua => $args{"lwp_ua"},
        html_form => \$form,
        attachments => $args{"attachments"}) if @{$args{"attachments"}};
    Log("Sending message...");
    $form->value("SEND", "Send");
    $response = ${$args{"lwp_ua"}}->request($form->click);
    Http_error($response) unless $response->is_success;
    if ($config{"debug"}) {
        my %i18n;
        if (%i18n = Set_intl(Get_intl($response))) {
            if ($response->content =~ /$i18n{"msg_sent"}/) {
                Log("Message sent");
            }
            elsif ($response->content =~ /$i18n{"bad_field"}/) {
                die "Invalid characters in field \"$1\"\n";
            }
            else {
                die "Could not send message\n";
            }
        }
    }
    return $response;
}

#  Attach_files - attach files to be sent through Yahoo! Mail. The total size
#				 of files cannot be greater than 10.0 MB. This is Yahoo!'s
#				 limitation, not of this program ;-).
#  Attach_files (lwp_ua => \$lwp_ua,
#                html_form => \$html_form,
#                attachments => \@attachments)
sub Attach_files {
    my %args = @_;
    Log("Attaching files to the message...");
    ${$args{"html_form"}}->value("ATT", 1);
    my $response = ${$args{"lwp_ua"}}->request(${$args{"html_form"}}->click);
    Http_error($response) unless $response->is_success;

    if (!$response->content =~ /AttachMoreFiles\(\)/) {
        die "Could not access file attaching function\n";
    }

    my @forms = HTML::Form->parse($response->content, $response->base());
    foreach (@forms) { $_->attr("name", "") unless defined $_->attr("name") };
    @forms = grep $_->attr("name") eq "Attachments", @forms;
    die "Form \"Attachments\" not found" unless @forms;
    ${$args{"html_form"}} = shift @forms;

    my $i = 0;
    ${$args{"html_form"}}->value("userFile" . $i++, $_) foreach (@{$args{"attachments"}});
    ${$args{"html_form"}}->value("UPL", "Attach Files");
    $response = ${$args{"lwp_ua"}}->request(${$args{"html_form"}}->click);
    Http_error($response) unless $response->is_success;
    if ($config{"debug"}) {
        my %i18n;
        if (%i18n = Set_intl(Get_intl($response))) {
            if ($response->content =~ /$i18n{"files_added"}/) {
                Log("Files attached");
            }
            elsif ($response->content =~ /$i18n{"file_size"}/) {
                die "Total attachment size can not be greater than 10.0 MB\n";
            }
        }
    }

    @forms = HTML::Form->parse($response->content, $response->base());
    foreach (@forms) { $_->attr("name", "") unless defined $_->attr("name") };
    @forms = grep $_->attr("name") eq "Compose", @forms;
    die "Form \"Compose\" not found" unless @forms;
    ${$args{"html_form"}} = shift @forms;
    $response = ${$args{"lwp_ua"}}->request(${$args{"html_form"}}->make_request);
    Http_error($response) unless $response->is_success;

    @forms = HTML::Form->parse($response->content, $response->base());
    foreach (@forms) { $_->attr("name", "") unless defined $_->attr("name") };
    @forms = grep $_->attr("name") eq "Compose", @forms;
    die "Form \"Compose\" not found" unless @forms;
    ${$args{"html_form"}} = shift @forms;
    if (${$args{"html_form"}}->value("NumAtt")) {
        Log(${$args{"html_form"}}->value("NumAtt") . " file(s) attached");
    }
    else {
        die "Could not attach files\n";
    }
}

# Get_header - extract headers from MIME messages
#  Get_header ($mime_header, $header)
#  mime_header_ref: MIME::Head object
#  header: header to extract
sub Get_header {
    my ($mime_header, $header) = @_;
    if (defined $mime_header->get($header)) {
        my $hdr = decode_mimewords($mime_header->get($header));
        $mime_header->replace($header, $hdr);
        $mime_header->unfold($header);
        $hdr = $mime_header->get($header);
        $hdr =~ s/\n$//;
        return $hdr;
    }
    else {
        return "";
    }
}

# Parse_mail - parse messages and extract fields used by Send_mail subroutine
#  \%mail = Parse_mail ()
#  mail: HASH reference containing each mail component (to, cc, bcc, subject,
#        body, attachments)
sub Parse_mail {
    # The e-mail client will be set to use a sendmail-like command for mail
    # sending. The command given need to be the path for this program. The
    # style of command arguments given to sendmail is:
    #
    # <command> [options] mail1@server.com mail2@server.com ...
    #
    # all [options] are ignored.
    # "mail1@server.com mail2@server.com ..." is the list of "effective"
    # recipients. This list will be stored in @session_recipients

    # Sendmail-like options below taken from Postfix sendmail(1) man page
    #GetOptions("B=s", "F=s", "b=s", "f=s", "i", "o=s", "r=s", "t", "v");
    GetOptions("i", "f=s");

    my @session_recipients = @ARGV;
    Log("Parsing message from standard input...");
    $temp_dir = tempdir("sendymailXXXXXX", TMPDIR => 1);
    
    my $msg_parser = new MIME::Parser;
    $msg_parser->output_under($temp_dir);
    my $message = $msg_parser->parse(\*STDIN);
    my ($bdy_text, @attachs);
    # If message is multipart (has attachments)
    if ($message->parts) {
        foreach ($message->parts) {
            # the text part of a message often has mime-type "text/plain" and
            # other than "attachment" content-disposition (eg: "inline")
            # FIXME : is this true for any mail client?
            # At least Pine doesn't use "inline" content-disposition
            my $content_disposition =
            $_->head->mime_attr("content-disposition");
            $content_disposition = "" unless defined $content_disposition;
            # A very ugly way to do this, but Pine doesn't specify the
            # "content-disposition" header...
            if ($_->effective_type eq "text/plain" and
            !($content_disposition =~ /^attachment$/i)) {
                $bdy_text = $_->bodyhandle->as_string;
            # other parts are treated as attachments
            }
            elsif ($_->effective_type eq "message/rfc822") {
                die "Mail fowarding as attachment is unsupported\n";
            }
            else {
                push(@attachs,$_->bodyhandle->path);
            }
        }
    }
    # not-multipart messages are supposed to not have attachments
    else {
        $bdy_text = $message->bodyhandle->as_string;
    }

    my $headers = $message->head;
    my $hdr_subj = Get_header($headers, "subject");
    my $hdr_to = Get_header($headers, "to");
    my $hdr_cc = Get_header($headers, "cc");

    my @addrs = Mail::Address->parse("$hdr_to, $hdr_cc");
    my %addrs_hash = ();
    foreach (@addrs) { $addrs_hash{$_->address()} = 1 };
    # Effective ("session") recipients not present on TO or CC headers are
    # "hidden" or BCC recipients
    my $hdr_bcc;
    foreach (@session_recipients) {
        if (!$addrs_hash{$_}) { $hdr_bcc .= "$_, " };
    }
    if (defined $hdr_bcc) {
        $hdr_bcc =~ s/, $//;
    } else {
        $hdr_bcc = "";
    }
    return {
        to => $hdr_to,
        cc => $hdr_cc,
        bcc => $hdr_bcc,
        subject => $hdr_subj,
        body => $bdy_text,
        attachments => \@attachs,
    };
}

sub Parse_config {
    open(CONFIG, $_[0]) ||
        die "Could not open configuration file " . $_[0] . ": $!\n";
    while (<CONFIG>) {
        next if (/^\s*#/);
        if (/^\s*(\w+)\s*=\s*(\S+)\s*$/i) {
            my $key = $1;
            my $value = $2;
            $value =~ s/\$HOME/$ENV{"HOME"}/g;
            $config{$key} = $value;
        }
    }
    close CONFIG;
}

# Taken from perlipc Perl doc
sub daemonize {
    $SIG{CHLD} = "IGNORE";
    chdir "/" or die "Could not change to root dir: $!\n";
    # FIXME : Is there some way to not use /dev/null directly, for
    # platform-independency?
    open STDIN, "/dev/null" or die "Could not read /dev/null: $!\n";
    open STDOUT, ">/dev/null" or die "Could not write to /dev/null: $!\n";
    defined(my $pid = fork) or die "Could not fork: $!\n";
    exit if $pid;
    setsid or die "Could not start a new session: $!\n";
    open STDERR, ">&STDOUT" or die "Could not dup STDOUT: $!\n";
}

sub Get_intl {
    my ($http_response) = @_;
    if ($http_response->content =~ /\.intl=([^&"]+)[&"]/) {
        return $1;
    }
    else {
        return "unknown";
    }
}

#####################################
# International Yahoo accounts (i18n)
#####################################
sub Set_intl {
    my ($loc) = @_;
    # The following messages need to be translated EXACTLY as in YM pages
    # If your country is not here, please insert it and send me to addition in
    # future releases. DON'T edit "common" record
    my %i18n = (
        common => {
            sign_in => "Sign in with your ID and password to continue",
            logout => "You have signed out of the Yahoo! network",
            bad_password => "Invalid Password",
            bad_userid => "This Yahoo! ID does not exist",
            server_down => "This page is currently unavailable",
        },
        br => {
            msg_sent => "Mensagem enviada",
            files_added => "Os seguintes arquivos foram anexados  mensagem",
            file_size => "Um arquivo anexado no pode ter mais que 3.0 megabytes de tamanho",
            bad_field => "H um erro no campo <b>([^<]*)</b>",
        },
        us => {
            msg_sent => "Message Sent",
            files_added => "The following files have been attached",
            file_size => "An attached file cannot exceed 3.0 encoded megabytes",
            bad_field => "There is an error in the <b>([^<]*)</b> field",
        },
    );

    # Aliases
    $i18n{"ca"} = $i18n{"us"};
    
    if ($i18n{$loc}) {
        return %{$i18n{$loc}};
    }
    elsif ($config{"debug"}) {
        warn "Unsupported country code ($loc), disabling debugging\n";
        $config{"debug"} = 0;
    }
    return ();
}
