#!/opt/local/bin/perl -w
# Copyright © 2008, 2009 Jamie Zawinski <jwz@jwz.org>
#
# Permission to use, copy, modify, distribute, and sell this software and its
# documentation for any purpose is hereby granted without fee, provided that
# the above copyright notice appear in all copies and that both that
# copyright notice and this permission notice appear in supporting
# documentation.  No representations are made about the suitability of this
# software for any purpose.  It is provided "as is" without express or 
# implied warranty.
#
# You can post text and images to LiveJournal by sending email to
# "yourname+password@post.livejournal.com", but when you do that, it hosts
# your images on the LJ image hosting service.  I prefer to host images
# on my own server, so that's what this script does.  It parses the
# mail message, resizes and saves the attached image, and then sends an
# HTML-only email post to LJ that references the image on my server.
#
# When the mail server runs this script, you need to arrange for it to run
# as a user who can create files in $image_dir.  To make this work with
# Postfix:
#
#   /etc/postfix/main.cf:
#     alias_maps     = hash:/etc/aliases, hash:/etc/postfix/aliases-jwz
#     alias_database = hash:/etc/aliases, hash:/etc/postfix/aliases-jwz
#
#   /etc/postfix/aliases-jwz:
#     ljpost: "|/Users/jwz/www/hacks/ljpost.pl PASS --lj LJUSER:LJPASS"
#
#   chown root:wheel /etc/postfix/aliases-jwz*
#   newaliases
#   chown jwz /etc/postfix/aliases-jwz*
#     (this must be done after newaliases!)
#
# PASS is the password that protects *this* script.  LJUSER and LJPASS
# are the user/password pair that Livejournal expects.  Yes, the
# passwords are right there in the aliases file.  If someone hacks
# your machine and reads that file, they can post to LiveJournal as you.
# Quelle horreur.
#
# To post to a Livejournal community, use "LJUSER.COMMUNITY+LJPASS".
#
# To cross-post to Twitter, use "--twit TWITUSER:TWITPASS".
# 
# Created: 27-Apr-2008.

require 5;
use diagnostics;
use strict;

use MIME::Parser;
use MIME::Entity;
use Image::Magick;

my $progname = $0; $progname =~ s@.*/@@g;
my $version = q{ $Revision: 1.16 $ }; $version =~ s/^[^\d]+([\d.]+).*/$1/;

$ENV{PATH} = "/opt/local/bin:$ENV{PATH}";   # for darwinports wget

my $verbose = 0;
my $debug_p = 0;

my $image_max_w   = 800;   # create a thumb if bigger than this.
my $image_max_h   = 800;

my $image_target_w = 480;  # do not exceed these sizes in IMG tag.
my $image_target_h = 500;

my $image_quality = 90;
my $image_dir     = '/Users/jwz/www/images';
my $image_url     = 'http://www.jwz.org/images/';

# If set, this cmd is run on each image to rotate the JPEG data according
# to the EXIF rotation values, so that things post right-side-up.
#
my $rotimg_cmd    = '/Users/jwz/www/hacks/rotimg';

my $default_lj_tags       = 'sf';
my $default_lj_photo_tags = 'photography';

####
$default_lj_tags = 'sxsw';
$default_lj_photo_tags = 'photography, music';



my $upload_images_cmd = "cd $image_dir/../ ; make -s dist-images";

my $sendmail = "/usr/sbin/sendmail -t -oi";

my $twitter_post_url = 'https://twitter.com/statuses/update.xml';



sub url_quote($) {
  my ($u) = @_;
  $u =~ s|([^-a-zA-Z0-9.\@/_\r\n])|sprintf("%%%02X", ord($1))|ge;
  return $u;
}

sub url_unquote($) {
  my ($u) = @_;
  $u =~ s/[+]/ /g;
  $u =~ s/%([a-z0-9]{2})/chr(hex($1))/ige;
  return $u;
}

sub html_quote($) {
  my ($u) = @_;
  $u =~ s/&/&amp;/g;
  $u =~ s/</&lt;/g;
  $u =~ s/>/&gt;/g;
  $u =~ s/\"/&quot;/g;
  return $u;
}

# Check and print error status from various Image::Magick commands,
# and die if it's not just a warning.
#
sub imagemagick_check_error($) {
  my ($err) = @_;
  return unless $err;
  my ($n) = ($err =~ m/(\d+)/);

  if ($n && $n == 395 && $err =~ m/unable to open module file/) {
    #
    # This error is bullshit: ignore it:
    #
    #    Exception 395: unable to open module file
    #      `/opt/local/lib/ImageMagick-6.3.0/modules-Q16/coders/008d1bed.la':
    #      No such file or directory
    #
    return;
  }

  print STDERR "$progname: $err\n";
  print STDERR "$progname: maybe \$TMPDIR (".
               ($ENV{TMPDIR} || "/tmp") . ") filled up?\n"
    if ($err =~ m/pixel cache/i);

  exit (1) if ($n >= 400);
}


sub save_image($$) {
  my ($name, $data) = @_;

  $name = lc($name);
  $name =~ s/[^-_.a-z\d]/_/gsi;  # map stupid characters to underscores

  my $img = Image::Magick->new;
  $img->BlobToImage ($data);
  my ($fw, $fh) = $img->Get ('width', 'height');
  error ("$name: unparsable") unless ($fw > 0 && $fh > 0);

  my ($w, $h) = ($fw, $fh);

  my $big = $name;

  # Add a numeric suffix before the extension until we have a unique one.
  #
  while (-f "$image_dir/$big") {
    my ($head, $n, $tail) = ($big =~ m@^(.*?)(-\d+)?(\.[^.]+)$@s);
    $n = ($n || 0) - 1;
    $big = "$head$n$tail";
  }
#  error ("$image_dir/$big already exists")
#    if (-f "$image_dir/$big" && !$debug_p);

  if ($debug_p) {
    print STDERR "$progname: not writing $image_dir/$big ($w x $h)\n"
      if ($verbose);
  } else {
    local *OUT;
    umask 022;
    open (OUT, ">$image_dir/$big") || error ("$big: $!");
    print OUT $data                || error ("$big: $!");
    close OUT                      || error ("$big: $!");
    print STDERR "$progname: wrote $image_dir/$big ($w x $h)\n" 
      if ($verbose);
  }

  if (defined ($rotimg_cmd)) {
    my @cmd = ($rotimg_cmd);
    push @cmd, "-v" if $verbose;
    push @cmd, "$image_dir/$big";
    if ($debug_p) {
      print STDERR "$progname: not running " . join(' ', @cmd) . "\n"
        if ($verbose);
    } else {
      print STDERR "$progname: exec: " . join(' ', @cmd) . "\n" if ($verbose);
      system (@cmd);

      # Re-read the file to get its new width/height after possible rotation.
      $img = Image::Magick->new;
      $img->Read ("$image_dir/$big");
      my ($nw, $nh) = $img->Get ('width', 'height');
      if ($nw != $fw || $nh != $fh) {
        print STDERR "$progname: image rotated: ${fw}x$fh => ${nw}x$nh\n"
          if ($verbose);
        ($fw, $fh) = ($nw, $nh);
        ($w, $h)   = ($fw, $fh);
      } elsif ($verbose) {
        print STDERR "$progname: image size unchanged\n";
      }
    }
  }

  my $thumb = $big;

  if ($fw > $image_max_w || $fh > $image_max_h) {

    $thumb =~ s/(\.[^.]+)$/-thumb$1/s;
    error ("$thumb already exists")
      if (-f "$image_dir/$thumb" && !$debug_p);

    my $wscale = $image_target_w / $fw;
    my $hscale = $image_target_h / $fh;
    my $scale = ($wscale < $hscale ? $wscale : $hscale);
    my $status = $img->Scale (width  => int ($fw * $scale),
                              height => int ($fh * $scale));
    imagemagick_check_error ($status);
    $status = $img->Set (quality => $image_quality);
    imagemagick_check_error ($status);

    ($w, $h) = $img->Get ('width', 'height');
    error ("$thumb: resize didn't work") unless ($w > 0 && $h > 0);

    if ($debug_p) {
      print STDERR "$progname: not writing $image_dir/$thumb ($w x $h)\n"
        if ($verbose);
    } else {
      $status = $img->Write (filename => "$image_dir/$thumb");
      imagemagick_check_error ($status);

      print STDERR "$progname: wrote $image_dir/$thumb ($w x $h)\n" 
        if ($verbose);
    }
    undef $img;

  } else {
    #
    # We don't need to create a thumb.  Just (maybe) scale the IMG tag.
    #
    if ($fw > $image_target_w || $fh > $image_target_h) {
      my $wscale = $image_target_w / $fw;
      my $hscale = $image_target_h / $fh;
      my $scale = ($wscale < $hscale ? $wscale : $hscale);
      $w = int ($fw * $scale);
      $h = int ($fh * $scale);
    }
  }

  $big   = $image_url . url_quote($big);
  $thumb = $image_url . url_quote($thumb);

  return ($big, $thumb, $w, $h);
}


sub trim_signature($) {
  my ($s) = @_;

  if ($s =~ s@<span id="signature".*?</span>@@si) {
    $s =~ s@\s*(<(p|br)>\s*)+$@@si;
  } else {
    $s =~ s/(^|\n)-- *\n.*$//s;
    $s = '' if ($s =~ m/^\s+$/s);
  }
  return $s;
}


sub html_to_text($) {
  my ($html) = @_;
  my $txt = $html;
  $txt =~ s/\s+/ /g;
  $txt =~ s@\s*</?\s*P\b[^<>]*>\s*@\n\n@gsi;   # <P>
  $txt =~ s@\s*</?\s*BR\b[^<>]*>\s*@\n@gsi;    # <BR>
  $txt =~ s@\s*</?\s*DIV\b[^<>]*>\s*@\n@gsi;   # <DIV>

  $txt =~ s@\s*<IMG[^<>]*?SRC=["']?([^<>"']+)[^<>]*>\s*@ $1 @gsi;  # <IMG SRC
# $txt =~ s@\s*<A[^<>]*?HREF=["']?([^<>"']+)[^<>]*>\s*@ $1 @gsi;   # <A HREF

  $txt =~ s@<[^<>]*>@@gs;  # all other tags

  $txt =~ s@&lt;@<@gs;
  $txt =~ s@&gt;@>@gs;
  $txt =~ s@&quot;@"@g;
  $txt =~ s@&amp;@&@gs;

  $txt =~ s/\s+/ /gsi;
  $txt =~ s/^\s+|\s+$//gsi;

  return $txt;
}


# Run the URL through http://tinyurl.com/ and return the shortened one.
#
sub tinyurlify($) {
  my ($url) = @_;
  return $url if ($url =~ m@^http://tinyurl@s);
  my $url2 = `wget -qO- 'http://tinyurl.com/api-create.php?url=$url'`;
  print STDERR "tinyurl: $url\n     ==> $url2\n" if ($verbose);
  return $url unless $url2;
  return $url2 if (length($url2) < length($url));
  return $url;
}

# Run URLs in the text through http://tinyurl.com/ until the text is less
# than 140 characters.  Only shrink URLs until the text is short enough;
# leave remaining URLs un-shrunk as soon as the text is short enough.
#
sub shorten_urls($) {
  my ($txt) = @_;

  my $max_length = 140;

  return $txt if (length($txt) <= $max_length);

  my @chunks = split(m@(\bhttp://[^\s<>]+[A-Za-z\d/])@s, $txt);
  foreach my $chunk (@chunks) {
    next unless ($chunk =~ m@^http://@s);
    $chunk = tinyurlify ($chunk);

    $txt = join ('', @chunks);
    last if (length($txt) <= $max_length);
  }

  return $txt;
}


sub ljpost($$$$) {
  my ($lj, $from, $subj, $html) = @_;

  if ($html !~ m/^lj-tags:/mi) {
    my $t = $default_lj_tags;
    if ($html =~ m/<IMG/si) {
      $t .= ", " if $t;
      $t .= $default_lj_photo_tags;
    }
    $html = "lj-tags: $t\n\n" . $html;
  }

#  $html = "lj-security: private\n" . $html;

  my ($uid, $pass) = ($lj =~ m/^([^:]+):(.*)$/s);
  error ("unparsable lj auth: $lj") unless $pass;

  my $to = "${uid}+${pass}\@post.livejournal.com";
  my $msg = MIME::Entity->build (Type    =>"text/html",
                                 From    => $from,
                                 To      => $to,
                                 Subject => $subj,
                                 Data    => $html);

  if ($debug_p) {
    print STDERR ("#" x 72) . "\nResultant message:\n" . ("#" x 72) . "\n";
    $msg->print(\*STDERR);
    print "\n";
  } else {
    local *MAIL;
    open MAIL, "| $sendmail" || error ("sendmail: $!");
    $msg->print(\*MAIL);
    close MAIL;
  }
}


sub twit($$$) {
  my ($twit, $subj, $html) = @_;

  my ($uid, $pass) = ($twit =~ m/^([^:]+):(.*)$/s);
  error ("unparsable twitter auth: $twit") unless $pass;

  my $txt = html_to_text ($html);
  $subj =~ s/^\s+|\s+$//s;
  if ($subj) {
    $subj .= "." unless ($subj =~ m/[^\sA-Z\d]\s*$/si);
    $txt = "$subj $txt";
    $txt =~ s/\.\.\.+\s+\.+/.../g;  # conv "subj... ...body" to "subj... body"
  }

  $txt = shorten_urls ($txt);

  # Last resort: if the text is still too long, and there is a URL at the
  # end, truncate before the URL instead of after.
  #
  1 while (length($txt) >= 140 &&$txt =~ s/^(.*).(\shttp:[^\s]+)\s*$/$1$2/s);

  my @cmd = ('wget',
             '-q',
             '--no-check-certificate',
             '--user', "$uid",
             '--password', "$pass",
             '--post-data', "status=$txt",
             $twitter_post_url);

  if ($debug_p) {
    print STDERR ("#" x 72) . "\n";
    print STDERR join("\n  ", @cmd) . "\n";
  } else {
    system (@cmd);
  }
}


# Recursively processes the MIME::Entity, handling multipart entities.
# Returns the resultant (flattened) html output, and a list of images.
#
sub process_part($$@);
sub process_part($$@) {
  my ($part, $html, @imgs) = @_;
  my $type = lc($part->effective_type);
  my $body = $part->bodyhandle;

  if ($type eq 'text/plain') {
    $body = trim_signature ($body->as_string());
    $body =~ s/[ \t]+$//gm;
    $body = html_quote($body) . "\n\n";
    $body =~ s/\n\n+/\n\n<P>/gs;
    $body .= "\n";
    $html .= $body;

  } elsif ($type eq 'text/html') {
    $body = trim_signature ($body->as_string());
    $html .= $body. '<P>';

  } elsif ($type =~ m@^image/@) {
    push @imgs, $part;

  } elsif ($type eq 'multipart/mixed') {
    #
    # Append all the textual sub-parts together; save the images.
    #
    foreach my $subpart ($part->parts) {
      ($html, @imgs) = process_part ($subpart, $html, @imgs);
    }

  } elsif ($type eq 'multipart/alternative') {
    #
    # multipart/alternative types are sorted from least to most preferred.
    # Take the last one in the list that is plain-text, html, or an image.
    # Ignore all others.
    #
    my $prev = undef;
    foreach my $subpart ($part->parts) {
      my $subtype = lc($subpart->effective_type);
      if ($subtype eq 'text/plain' ||
          $subtype eq 'text/html'  ||
          $subtype =~ m@^image/@) {
        $prev = $subpart;
      }
    }
    error ("no known subtypes in $type") unless $prev;
    ($html, @imgs) = process_part ($prev, $html, @imgs);

  } else {
    error ("unknown type $type");
  }

  return ($html, @imgs);
}


sub post($$$) {
  my ($pass, $lj, $twit) = @_;

  my $ent;
  {
    my $parser = new MIME::Parser;
    $parser->ignore_errors(1);
    $parser->tmp_to_core(1);
    $parser->output_to_core(1);
    eval { $ent = $parser->parse(\*STDIN); };
    my $err = ($@ || $parser->last_error);
    $parser->filer->purge;
    error ("parse failed: $err") if ($err);
  }

  if ($debug_p > 1) {
    print STDERR ("#" x 72) . "\nSource message:\n" . ("#" x 72) . "\n";
    $ent->print(\*STDERR);
    print STDERR "\n" . ("#" x 72) . "\n";
  }

  my $head = $ent->head;
  my $from = $head->get('From');
  my $to = $head->get('To');
  my $dto = $head->get('Delivered-To');
  my $subj = $head->get('Subject') || '';
  my ($topass) = ($to  =~ m/^[^\+@]+\+([^\+@]+)\@/s);
     ($topass) = ($dto =~ m/^[^\+@]+\+([^\+@]+)\@/s)
       if ($dto && !defined($topass));
  error ("no posting password provided: $to") unless defined($topass);
  error ("password mismatch") unless ($pass eq $topass);

  # Sadly, sending photos with SMS to this address causes the URL on
  # Sprint's site to reveal my phone number.  Avoid mistakenly sending
  # an SMS instead of an email by just refusing messages from Sprint's
  # gateway.
  #
  error ("no SMS to this address!")
    if ($from =~ m/sprintpcs\.com/);

  my $html = '';
  my @imgs = ();

  my @parts = $ent->parts();
  push @parts, $ent if ($#parts == -1);  # not a MIME message

  foreach my $part (@parts) {
    ($html, @imgs) = process_part ($part, $html, @imgs);
  }

  my $img_txt = '';
  foreach my $img (@imgs) {
    my $name = $img->head->recommended_filename;
    my ($big, $thumb, $w, $h) = 
      save_image ($name, $img->bodyhandle->as_string());
    $img_txt .= ("<A HREF=\"$big\">" .
                 "<IMG SRC=\"$thumb\" WIDTH=$w HEIGHT=$h" .
                 " BORDER=1 HSPACE=2 VSPACE=2>" .
                 "</A>\n");
  }

  $html =~ s/^\s*(<(P|BR)>\s*)*//si;
  $html =~ s/\s*(<(P|BR)>\s*)*$//si;

  if ($img_txt) {
    if ($html) {
      $html = ("<DIV STYLE=\"width:" . ($image_target_w+8) . "px\">" .
               $html . "<P>" . $img_txt .
               "</DIV>");
    } else {
      $html = $img_txt;
    }

    $html = "<DIV ALIGN=CENTER>$html</DIV>\n";

    system ($upload_images_cmd)
      if (defined($upload_images_cmd) && !$debug_p);
  }

  # Trim newlines since LJ preformats that shit.
  $html =~ s/\s+/ /gsi;
  $html =~ s@\s+(</?(DIV|P))@$1@gsi;
  $html =~ s/\s+$/\n/si;

  # Make lines short.
  $html =~ s@(<(A|IMG))( (HREF|SRC)=[^\s<>]+)\s@$1\n$3\n @gsi;
  $html =~ s@(<(A|IMG))( (HREF|SRC)=[^\s<>]+)@$1\n$3@gsi;

  ljpost ($lj, $from, $subj, $html)
    if ($lj);
  twit ($twit, $subj, $html)
    if ($twit);
}


sub error($) {
  my ($err) = @_;
  print STDERR "$progname: $err\n";
  exit 1;
}

sub usage() {
  print STDERR "usage: $progname [--verbose] [--debug] pass " .
    "[--livejournal user:pass] [--twitter user:pass]\n";
  exit 1;
}

sub main() {
  my ($pass, $lj, $twit);

  while ($#ARGV >= 0) {
    $_ = shift @ARGV;
    if (m/^--?verbose$/) { $verbose++; }
    elsif (m/^-v+$/) { $verbose += length($_)-1; }
    elsif (m/^--?debug$/) { $debug_p++; }
    elsif (m/^--?(lj|livejournal)$/) { $lj = shift @ARGV; }
    elsif (m/^--?twit(ter)?$/) { $twit = shift @ARGV; }
    elsif (m/^-./) { usage; }
    elsif (!defined($pass)) { $pass = $_; }
    else { usage; }
  }

  if ($debug_p > 1) {
    my $f = "/tmp/ljpost.log";
    unlink $f;
    print STDERR "$progname: logging to $f\n";
    open (STDOUT, ">$f") || error ("$f: $!");
    *STDERR = *STDOUT;
  }

  usage unless (defined ($pass) && (defined($lj) || defined($twit)));
  post ($pass, $lj, $twit);
}

main();
exit 0;