#!/usr/bin/perl -s
#
# $dotat: scripts/imap-to-link-log,v 1.9 2011/06/15 10:01:25 fanf2 Exp $

use warnings;
use strict;

use IPC::Open2;

use vars qw( $d $t );

my $USER = 'XXXXX';
my $PASS = 'XXXXXXXX';
my $SERVER = "imap.hermes.cam.ac.uk";
my $MAILBOX = "to-link-log";

# sockets
my ($sr,$sw);

$| = 1;

my $re2047 = qr/=[?]([^? ]+)[?]([^? ]+)[?]([^? ]+)[?]=/;

sub un2047($$$) {
	my ($charset,$enc,$text) = @_;
	return "=?$charset?$enc?$text?="
	    if $enc !~ /^q$/i
	    or $charset !~ /^utf-8$/i;
	$text =~ s/=([0-9a-f]{2})/chr hex $1/gei;
	$text =~ s/_/ /g;
	$text =~ s/“/"/g;
	$text =~ s/”/"/g;
	$text =~ s/’/\x27/g;
	return $text;
}

sub get () {
	my $l = <$sr>;
	return if not defined $l;
	print "get< $l" if $d;
	return $l;
}

sub put (@) {
	print "put> @_\n" if $d;
	print $sw "@_\r\n";
}

my $cmd_num = 0;

sub raw_cmd (@) {
	put ++$cmd_num, @_;
	my @r;
	for (;;) {
		my $r = get;
		die "connection lost" unless defined $r;
		push @r, $r;
		return @r if $r =~ /^$cmd_num /;
	}
}

sub bugout (@) {
	raw_cmd "LOGOUT";
	die @_;
}

sub cmd (@) {
	my @r = raw_cmd @_;
	my $r = join "", @r;
	return $r if $r[$#r] =~ /^\d+ OK /;
	bugout "failed command @_\nresponse:\n$r";
}

# make s_client properly quiet
open OLDERR, ">&", \*STDERR;
my $pid = eval {
	open STDERR, ">/dev/null" unless $d;
	open2 $sr, $sw,
	   "openssl s_client -quiet -CApath /etc/ssl/certs -verify 0 -connect $SERVER:imaps";
};
open STDERR, ">&", \*OLDERR;
die $@ unless defined $pid;
my $r = get;
die "could not connect to $SERVER" if not defined $r;
die "unwelcoming banner $r" unless $r =~ /^[*] OK /;
cmd "LOGIN $USER $PASS";
cmd "SELECT $MAILBOX";
my $s = cmd "SEARCH ALL";
while ($s =~ s/^([*] SEARCH) (\d+)/$1/m) {
	my $n = $2;
	$r = cmd "FETCH $n BODY[]";
	$r =~ s/^[*] $n FETCH [(](\S+\s+)*BODY[[][]] [{](\d+)[}]\s*//s
	    or bugout "cannot parse fetch response:\n$r";
	my $len = $2;
	my $m = substr $r, 0, $len, "";
	$r =~ /^[)]\r\n/s
	    or bugout "cannot parse fetch response:\n$m$r";
	print $m if $d;
	unless ($m =~ m/^From: Tony Finch <dot\@dotat\.at>\s*$/m) {
		print "skipping: mismatched From:\n" if $d;
		next;
	}
	unless ($m =~ m/^\s+with esmtps?a [(]PLAIN:fanf2[)] /m) {
		print "skipping: mismatched auth\n" if $d;
		next;
	}
	unless ($m =~ m/^Subject: ([^\n]+(\n[ \t]+[^\n]+)*)\n/ms) {
		print "skipping: missing subject\n" if $d;
		next;
	}
	my $text = $1;
	$text =~ s/[ \t\n\r]+/ /sg;
	$text =~ s/^ +//;
	$text =~ s/ +$//;
	$text =~ s/[?]= =[?]/?==?/g;
	$text =~ s/$re2047/un2047($1,$2,$3)/geo;
	if ($text =~ m/$re2047/o) {
		print "skipping: bad RFC 2047 encoding\n" if $d;
		next;
	}
	$m =~ s/=\r\n//g;
	unless ($m =~ m{\r\n\r\n((https?|ftp)://\S+)\r\n}ms) {
		print "skipping: missing link\n" if $d;
		next;
	}
	my $link = $1;
	$link =~ s/=([0-9a-f]{2})/chr hex $1/gei
	    if $m =~ /^Content-Transfer-Encoding: quoted-printable/m;
	print "LINK $link\nTEXT $text\n" if $d or $t;
	if (!$t && 0 != system "/home/fanf2/bin/blog", $link, $text) {
		print "failed to blog $link $text\n" if $d;
		next;
	}
	cmd "STORE $n +FLAGS (\\Deleted)"
	    unless $t;
}
cmd "EXPUNGE";
cmd "LOGOUT";
exit;