#!/usr/pkg/bin/perl
#
my $revision = '$Id: mailblogger.pl,v 1.4 2005/06/15 14:50:22 bre Exp $';
my $version = 'Anomy 0.0.0 : mailblogger.pl';
#
##  Copyright (c) 2005 Bjarni R. Einarsson. All rights reserved.
##  This program is free software; you can redistribute it
##  and/or modify it under the same terms as Perl itself.  
#
# Usage: mailblogger.pl [args ...] <message
#
# This is a crude script to post an incoming MIME message to a blog or web
# page of some sort.  It was written to facilitate direct blogging of images
# from an MMS-enabled cell phone.  The following arguments are recognized:
#
#   default_subject=...           Default subject text, if none found.
#   default_text=...              Default message text, if none found.
#
#   post_to=http://cgi/path/      Where to post things to.
#   post_image=NAME               Post found images using named variable.
#   post_thumb=NAME               Post generated thumbnails using named var.
#   post_subject=NAME             Post found subject using named variable.
#   post_from=NAME                Post from-address using named variable.
#   post_text=NAME                Post found text using named variable.
#   post_hidden=NAME=VAL&N=V&...  Additional form fields to fill out.
#   post_html=yes                 Upload HTML formatted text.
#   post_method=query             Use QUERY method, default is POST.
#
#   image_prefix=/path/to/prefix  Path/name prefix for saved images.
#   image_url=http://host/path/   URL prefix for saved images.
#   image_geom=WIDTHxHEIGHT       Scale images to this size (optional).
#   image_post_url=yes            Add image URLs to posted text.
#   image_post_img=yes            Add image IMG tags to posted text.
#
#   thumb_prefix=/path/to/prefix  Path/name prefix for saved thumbnails.
#   thumb_url=http://host/path/   URL prefix for saved thumbnails.
#   thumb_geom=WIDTHxHEIGHT       Generate thumbs of this size (def. 160x160)
#   thumb_post_url=yes            Add thumbnail URLs to posted text.
#   thumb_post_img=yes            Add thunbnail IMG tags to posted text.
#
# This script never loads the entire message into memory (unless it's all
# one big text-part), but does dump its entire contents to disk once.
# 
# ImageMagick's convert utility must be in the path for image scaling to
# work.
#
BEGIN { push @INC, $ENV{"ANOMY"} . "/bin"; };
use strict;
use Anomy::MIMEStream;
use IO::Handle;
use LWP::UserAgent;
use HTTP::Request;
use HTTP::Request::Common qw(:DEFAULT $DYNAMIC_FILE_UPLOAD);


##[ Global variables, configuration ]#########################################

my @attachments = ( );
my @textparts = ( );
my @htmlparts = ( );
my %pics = (
    post_image => undef,
    post_thumb => undef,
    image => { },
    thumb => { },
);
my $postvars = { };

my $msg_text = '';
my $filecounter = 0;
my $workdir = undef;

my $parsers = {
    "DEFAULT"     => \&SaveIt,
    "multipart/*" => \&Anomy::MIMEStream::ParserMultipart,
};

# Defaults...
my $args = 
{
    default_subject => undef,
    default_text    => undef,

    post_to      => undef,
    post_image   => undef,
    post_thumb   => undef,
    post_from    => undef,
    post_text    => undef,
    post_subject => undef,
    post_hidden  => undef,
    post_html    => undef,
    post_method  => undef,

    image_prefix   => undef,
    image_url      => undef,
    image_geom     => undef,
    image_post_url => undef,
    image_post_img => undef,

    thumb_prefix   => undef,
    thumb_url      => undef,
    thumb_geom     => "160x160",
    thumb_post_url => undef,
    thumb_post_img => undef,

    img_rotate => undef,
    testing    => "no",
    temp       => "/tmp",

    # These are variables which enable "custom" code to handle things
    # local to my personal environment.  They're disabled by default and
    # undocumented. :-)
    hacks_for_bre => undef,
};


##[ Main ]####################################################################

# Check args
#
my $arg_re = join('|', keys(%{ $args }));
foreach my $arg (grep(/=/, split(/\n+/, cat($ENV{HOME}."/.mailbloggerrc") || '')), (@ARGV))
{
    if ($arg =~ /^\s*($arg_re)\s*=\s*(.*)$/si)
    {
        print "Set $1 to $2\n" if ($args->{testing} eq "yes");
        $args->{lc($1)} = $2;
    }
    else
    {
        die "Invalid argument: $arg\nStopped";
    }
}

# Create working directory
#
$workdir = CreateWorkdir();

# Parse message header
#
open (NULL, ">/dev/null");
my $message = Anomy::MIMEStream->New(*STDIN, *NULL, $parsers);
$message->ParseHeader();

# Dump attachments to files
#
$message->ParseBody();

# Find our message text...
#
$msg_text = FindMessageText();

# Save possibly scaled images to the specified directories.
#
SaveImages("thumb") if ($args->{"thumb_prefix"});
SaveImages("image") if ($args->{"image_prefix"});

# Post it!
my $ok = PostEverything() if ($args->{"post_to"});

RemoveWorkdir() unless ($args->{testing} eq "yes");

exit(!$ok);


##[ Subroutines ]##############################################################


sub PostEverything
{
    $msg_text = AsHTML($msg_text) if ($args->{post_html} eq "yes");

    # This saves memory...
    #$DYNAMIC_FILE_UPLOAD = 1;

    # Populate the $postvars hash with various things, as necessary.
    sub p { 
        my ($n, $v) = @_;
        $postvars->{$args->{$n}} = $v if ($args->{$n} && (defined $v)); 
    };
    p("post_subject", $message->{"headers"}->{"subject"});
    p("post_from",    $message->{"headers"}->{"from"});
    p("post_text",    $msg_text);
    p("post_thumb",   $pics{post_thumb});
    p("post_image",   $pics{post_image});
    
    foreach my $pair (split/&/, $args->{"post_hidden"})
    {
        my ($name, $val) = split(/=/, $pair, 2);
        $postvars->{$name} = $val;
    }

    # POST hash
    my %post = ( 
        Content => $postvars,
    );
    $post{"Content_Type"} = "form-data" if ($args->{post_thumb} || $args->{post_image});

    # Make the actual request.
    my $ua = new LWP::UserAgent;
    my $req = POST $args->{post_to}, %post;
    my $resp = $ua->request($req);

    if ($args->{testing} eq "yes")
    {
        print $resp->content()       if ($resp->is_success());
        print $resp->error_as_HTML() if ($resp->is_error());
    }
    else
    {
        print STDERR $resp->error_as_HTML() if ($resp->is_error());
        return $resp->is_success();
    }
}

sub AsHTML
{
    my ($data) = @_;

    $data =~ s/&/&amp;/g;
    $data =~ s/</&lt;/g;
    $data =~ s/>/&gt;/g;
    $data =~ s/Image: &lt;(.*?)&gt;/<img src='$1'>\n/g;
    $data =~ s/Image URL: &lt;(.*?)&gt;/
                my $img = $1;
                my ($image, $thumb, $res);
                if (($image = $pics{image}->{$img}) &&
                    ($thumb = $pics{thumb}->{$image->[0]}))
                {
                    $res = "<a href='$img'><img src='$thumb->[2]'><\/a>\n";
                }
                else
                {
                    $res = "<a href='$img'>$img<\/a>\n";
                }
                $_=$res;
              /ge;
    $data =~ s/\n\s*\n/<p>\n/g;

    return $data;
}

sub FindMessageText
{
    my $data = '';
    foreach my $text (@textparts)
    {
        my $t = cat($text);
        $data = $t;
        last if ($data =~ /\S+/);
    }

    if ($args->{"hacks_for_bre"} eq "yes")
    {
        # Remove AVES messages...
        $data =~ s/^.*?https:\/\/aves.(frisk.is|f-prot.com)\/m\S+\s+//s;

        # Kill OgVodafone standard signature
        $data =~ s/^Þetta er tölvupóstur, sendur með Myndskilaboðum.*$//gms;

        # I like using " .. " to seperate paragraphs.
        $data =~ s/ \.\. /\n\n/g;

        # These I use for my diary's access controls
        if ($data =~ s/\s*\.group:(\S+)\.\s*//i)
        {
            $postvars->{"X-Message-Group"} = $1; 
        }

        # Override message subjects
        if ($data =~ s/\s*\.sub\S*:([^:]+):\.\s*//i)
        {
            $postvars->{"Subject"} = $1;
        }
    }

    return $data;
}

sub SaveImages
{
    my ($type) = @_;

    my @cp = ("cp");
    my @convert = ("convert", "-antialias");

    push @cp, "-v" if ($args->{testing} eq "yes");
    push @convert, "-verbose" if ($args->{testing} eq "yes");

    foreach my $att (@attachments)
    {
        next unless ($att =~ /\.(gif|jpe?g|png|bmp)$/i);

        my $target = $att;
        $target =~ s,^.*/,,g;
        $target = $args->{$type."_prefix"}.$target;

        my $rotate = 0;
        if ($msg_text =~ /\s*\.image(\d*)\.\s*/i)
        {
            $rotate = $1 if ($1);
        }

        my $err = undef;
        if (my $geom = $args->{$type."_geom"})
        {
            $target =~ s/(gif|jpe?g|png|bmp)$/jpg/i;
            system(@convert, "-geometry", $geom, "-rotate", $rotate, $att, $target) || ($err = $!);
        }
        elsif ($rotate)
        {
            $target =~ s/(gif|jpe?g|png|bmp)$/jpg/i;
            system(@convert, "-rotate", $rotate, $att, $target) || ($err = $!);
        }
        else
        {
            system(@cp, $att, $target) || ($err = $!); 
        }

        unless ($err)
        {
            my $url = '';
            if (my $urlpre = $args->{$type."_url"})
            {
                $url = $target;
                $url =~ s,^.*/,,g;
                $url = $urlpre.$url;

                if ($args->{$type."_post_img"})
                {
                    $msg_text .= "Image: <$url>\n"
                      unless ($msg_text =~ s/\s*\.image\d*\.\s*/\n\nImage: <$url>\n\n/i);
                }
                elsif ($args->{$type."_post_url"})
                {
                    $msg_text .= "Image URL: <$url>\n"
                      unless ($msg_text =~ s/\s*\.image\d*\.\s*/\n\nImage URL: <$url>\n\n/i);
                }
            }

            my $info = [ $att, $target, $url ];
            $pics{$type}->{$target} = $info;
            $pics{$type}->{$att}    = $info;
            $pics{$type}->{$url}    = $info;

            $pics{"post_$type"} = [ $info->[1] ] unless ($pics{"post_$type"});
        }
    }
}

sub CreateWorkdir
{
    $args->{"temp"} =~ s/\/+$//;

    my $wd = sprintf("%s/mailblogger-%x-%x", $args->{"temp"}, time(), $$);
    mkdir $wd, 0700 || die "mkdir $wd: $!"; 

    print "Created $wd\n" if ($args->{testing} eq "yes");

    # If we're going to be posting images or thumbs, we need to be sure
    # we have names for the scaled versions:
    foreach my $what ("image", "thumb")
    {
        next unless ($args->{"post_".$what});
        next if ($args->{$what."_prefix"});
        $args->{$what."_prefix"} = "$wd/$what-";
    }

    return $wd;
}

sub RemoveWorkdir
{
    system("rm", "-rf", $workdir);
}

sub SaveIt
{
    my $part = shift;
    my $fn = $part->{"mime"}->{"name"} || 
             $part->{"mime"}->{"filename"} || "unnamed";
    $fn =~ s/[^A-Za-z0-9\._-]/_/g;

    my $filename = sprintf("%s/%2.2d.%s", $workdir, $filecounter++, $fn);

    if ($part->{"mime"}->{"disposition"} =~ /^attachment$/i)
    {
        push @attachments, $filename;
    }        
    elsif ($part->{"mime"}->{"type"} =~ /^text\/plain$/i)
    {
        $filename .= ".txt" if ($filename !~ /\.txt$/i);
        push @textparts, $filename;
    }
    elsif ($part->{"mime"}->{"type"} =~ /^text\/html$/i)
    {
        $filename .= ".html" if ($filename !~ /\.html$/i);
        push @htmlparts, $filename;
    }
    else
    {
        push @attachments, $filename;
    }

    open (FILE, ">$filename");
    while (my $l = $part->Read())
    {
        print FILE $l;
    }
    close(FILE);    
}

# Dump the contents of a file...
#
sub cat
{
    my $fn = shift;
    open (FILE, "<$fn") || return undef;
    my $data = join('', <FILE>);
    close(FILE);
    return $data; 
}


# vi:ts=4 expandtab
