#!/usr/local/bin/perl

# CVS: $Id: ljpms.pl,v 1.3 2006/11/16 12:19:08 sasha Exp $
# Author: Alexander Nikolaev <sasha_nikolaev@yahoo.com>
# 
#perl2exe_info FileDescription=Utility for Livejournal.com backup and post security level manipulation
#perl2exe_info ProductName=LJPMS
#perl2exe_info ProductVersion=1.3.0.0
#perl2exe_info FileVersion=1.3.0.0
#perl2exe_info LegalCopyright=GPL
#perl2exe_info CompanyName=Alexander Nikolaev, sasha_nikolaev@yahoo.com

#perl2exe_include "utf8.pm"
#perl2exe_include "unicore/lib/gc_sc/Word.pl"
#perl2exe_include "unicore/lib/gc_sc/Digit.pl"
#perl2exe_include "unicore/lib/gc_sc/SpacePer.pl"
#perl2exe_include "unicore/To/Lower.pl"
#perl2exe_include "unicore/lib/gc_sc/Cntrl.pl"
#perl2exe_include "unicore/lib/gc_sc/ASCII.pl"
#perl2exe_include "unicore/To/Fold.pl" 


# cyrillic encodings language pack for XML::Parser:
# http://uucode.com/xml/perl/enc.zip
#
# explicitly include some modules for perl2exe
use SOAP::Transport::HTTP;
use Digest::Perl::MD5;
use XML::SAX;
use XML::NamespaceSupport;
use LWP::UserAgent;
use PerlIO;
use SOAP::Lite;
#use Encode;

use File::Path;
use Digest::MD5 qw(md5_hex);
use Getopt::Std;
use XML::Simple;
use XMLRPC::Lite
	on_fault	=> sub {
		my ($soap, $res) = @_;
		if (ref $res) {
			warn "\n--- LIVEJOURNAL FAULT ---\n", 
				$res->faultcode, ": ",
				$res->faultstring, "\n";
				die "Aborting...\n\n";
		} else {
			warn "\n--- HTTP ERROR ---\n", 
			$soap->transport->status, "\n";
		}
		return new SOAP::SOM;
	}
;


use Data::Dumper;
use Carp;
#use diagnostics;
use strict;

use constant URL		=> 'http://www.livejournal.com/interface/xmlrpc';
use constant LOCALDIR	=> '';
use constant CLIENT		=> 'Perl-ljpms/1.3; sasha_nikolaev@yahoo.com';
use constant MAXTRY		=> 5;
use constant VERSION	=> '$Revision: 1.3 $';

if ($] >= 5.008) {
	require Encode;
	import Encode qw(encode_utf8);
}


# -----------------------------------------------------------

$|=1;
my ($user, $suser, $password, $mode, %modes, %opts, $entry);
my ($security, $allowmask, @server);

%modes = (
		'private'	=> 'private',
		'friends'	=> 'usemask',
		'public'	=> 'public',
		'restore'	=> 1,
		'delete'	=> 'private',
		'backup'	=> 'backup',
		);

getopts('p:s:', \%opts);

# set proxy URL for LWP requests
if ($opts{'p'}) {
	$opts{'p'} = 'http://'.$opts{'p'} unless ($opts{'p'} =~ m{^http://});
	@server = (URL, 'proxy' => ['http' => $opts{'p'}]);
} else {
	@server = (URL);
}

exit(usage()) unless @ARGV == 2;
($user, $password) = split(':', $ARGV[0], 2);
$password = md5_hex($password);
$suser = (defined($opts{'s'}) && length($opts{'s'}))? $opts{'s'} : $user;

exit(usage('nopassword')) unless $password;
$mode = lc($ARGV[1]);
exit(usage('invalidmode')) unless (defined $modes{$mode} || $mode =~ /^\d+$/);
exit (usage('noexport')) unless  ($mode eq 'backup') || (-d LOCALDIR . "$suser/export");


# login to server to check login-password information
print "Logging in to server as $user... ";

# $responce is XML::RPC::struct
if (my $res = &rpc('login', { 'clientversion'	=> CLIENT })) {
	print " done.\n";
	print "Hello, " . $res->{'fullname'} . "\n";
	print $res->{'message'} if defined $res->{'message'};
	print "\n";
	
} else {
	exit 1;
}

if ($mode eq 'backup') {
	exit &usage('cantsync') unless &sync_events($suser);
	print "done.\n";
	exit 0;

} elsif ($mode =~ /^\d+$/) {
	$security = 'usemask';
	$allowmask = $mode;

} else {
	$security = $modes{$mode};
	$allowmask = ($security eq 'usemask')? 1 : 0;
}	


my $action;
if ($suser ne $user) { # post to someone else's journal
	exit usage('invalidmode') if ($mode =~ /^(delete|backup|\d+)$/);
	print "posting ${suser}'s backdated entries to ${user}'s journal\n";
	$action = \&post_event;

} elsif ($mode eq 'delete') {
	warn <<EOM;
--------------------  WARNING!!! --------------------------
      The journal of $user will be erased now.
      You will NOT be able to restore it. Never.
Press Ctrl-C in 10 seconds if you don't want this to happen
-----------------------------------------------------------

EOM
	for (1..10) {
		print "$_ ";
		sleep 1;
	}
	print "\nok. deleting $user\'s journal...\n";
	$action = \&delete_event;

} else {
	$action = \&edit_event;
}

# process files
FILES:
foreach my $file (grep(/^\d{4}_\d{2}\.xml$/, &read_dir(LOCALDIR . "$suser/export"))) {
	print "processing $suser/export/$file\n";

	foreach my $entry (&get_entries(LOCALDIR . "$suser/export/$file")) {
		print $entry->{'itemid'} . "\n";

		if ($mode eq 'restore') {
			$security = $entry->{'security'};
			$allowmask = $entry->{'allowmask'};
		}

		last FILES unless &$action($entry);
	}
}

# done processing files, exit.
exit 0;


# ---------------------------------------------
# -------------- subroutines ------------------
# ---------------------------------------------


sub get_entries {
	my ($filename) = @_;
	
	my $xi = XMLin($filename);
	my @data = ();
	if (! defined $xi->{'entry'}) {
		@data = ();
	} elsif (ref $xi->{'entry'} eq 'HASH') {
		@data = ($xi->{'entry'});
	} elsif (ref $xi->{'entry'} eq 'ARRAY') {
		@data = @{$xi->{'entry'}};
	}
	return @data;
}


sub edit_event {
	my ($entry) = @_;

	#print Dumper $entry;

	my $soap_message = &make_message($entry);
	$soap_message->{'itemid'} = ($entry->{'itemid'} >> 8);
	&rpc('editevent', $soap_message);
}


sub post_event {
	my ($entry) = @_;

	my $soap_message = &make_message($entry);
	$soap_message->{'props'}->{'opt_backdated'} = 1;
	&rpc('postevent', $soap_message);
}


sub delete_event {
	my ($entry) = @_;

	&rpc('editevent', 
		{
			'itemid'	=> ($entry->{'itemid'} >> 8),
			'ver'		=> 1,
			'event'		=> '',
			'subject'	=> '',
			'security'	=> $security,
			'allowmask'	=> $allowmask,
		}
	);
}


sub make_message {
	my ($entry) = @_;
	my ($year, $month, $day, $hour, $min) = split(/\D+/, ($entry->{'logtime'} or $entry->{'eventtime'}));
	my $soap_message = {
			'ver'			=> 1,
			'lineendings'	=> "\n",
			
			'event'		=> my_encode($entry->{'event'}),
			'subject'	=> my_encode($entry->{'subject'}),
			'security'	=> $security,
			'allowmask'	=> $allowmask,
			
			'year'		=> $year,
			'mon'		=> $month,
			'day'		=> $day,
			'hour'		=> $hour,
			'min'		=> $min,
	};
	# not exported by export.bml (but now exported by ljpms ;)
	# opt_preformated , opt_nocomments , opt_noemail , opt_screening , picture_keyword
	#
	foreach ('current_music', 'current_mood', 'current_location', 'picture_keyword', 'opt_noemail', 'opt_screening', 'opt_preformatted', 'opt_nocomments') {
		if (defined($entry->{$_})) {
			$soap_message->{'props'}->{$_} = &my_encode($entry->{$_});
		} 
	}
	return $soap_message;
}


sub sync_events {
    my ($user) = @_;

	print "Invalid user name: '$user'\n" && return undef unless $user =~ /^\w+$/;
	my $dirname = LOCALDIR . "$user/export";
	my $syncfile = $dirname . "/last-sync-time.txt";

	mkpath($dirname) unless -d $dirname;
	# read recent data

	my $lastsync = &get_file($syncfile);
	$lastsync = '2001-01-01 00:00:00' unless $lastsync;
    print "syncing meta items since $lastsync\n";
	
	my ($res, $newevents);
	$newevents = 0;
	do {
		print "syncing data...";
		$res = &rpc('syncitems', {
			'lastsync'	=> $lastsync,
			});

		if ($res) {
			print $res->{'count'} . " new item" . (($res->{'count'} == 1)? ".\n" : "s.\n");
			print (($res->{'count'})? "fetching new/modified posts...\n" : "\n");

			my ($res2, $item);

			foreach $item (@{$res->{'syncitems'}}) {
				$lastsync = $item->{'time'} if ($item->{'time'} gt $lastsync);
				# skip comments, todos, etc
				next unless $item->{'item'} =~ /^L-(\d+)$/;
				$newevents++;
				$res2 = &rpc('getevents', {
						'selecttype'	=> 'one',
						'itemid'		=> $1,
						'ver'			=> 1,
						});
				if ($res2) {
					print $item->{'item'} . " ok\n";
					&save_item($res2->{'events'}->[0]);
				} else {
					last;
				}
			}
		}
	} until (!$res || ($res->{'total'} == $res->{'count'}));
	return 1 unless $newevents;

	print "$newevents new entries. rebuilding XML backup... ";
	&put_file($syncfile, \$lastsync);

	# join xml files to imitate export.bml behaviour
	my $localbase = LOCALDIR . "$suser/export";
	my @years = grep { /^\d{4}$/ && -d "$localbase/$_" } &read_dir($localbase);
	foreach my $year (@years) {
		my @months = grep { /^\d{2}/ && -d "$localbase/$year/$_" } &read_dir("$localbase/$year");
		foreach my $month (@months) {
			my $thisdir = "$localbase/$year/$month";
			my @files = grep { /^\d+\.xml$/ && -s "$thisdir/$_" } &read_dir($thisdir);
			my $month_contents = "<?xml version=\"1.0\" encoding='utf-8'?>\n";
			$month_contents .= "<livejournal>\n";
			foreach my $xmlfile (sort @files) {
				$month_contents .= &get_file("$thisdir/$xmlfile") . "\n";
			}
			$month_contents .= "</livejournal>";
			&put_file("$localbase/$year\_$month.xml", \$month_contents);

		}
	}
	print "done. \n";
	1;
}

# write XML file with LJ post using export.bml-compatible scheme
#
sub save_item {
	my ($item) = @_;
	#print Dumper $item;
	my ($year, $month, $day, $tail) = split(/[-\s]/, $item->{'eventtime'});
	mkpath(LOCALDIR . "$suser/export/$year/$month");

	my $itemid = $item->{'itemid'}*256 + $item->{'anum'};
	my $fname = LOCALDIR . "$suser/export/$year/$month/$itemid.xml";
	my $props = $item->{'props'};

	my (@rt, $revtime);
	if (defined $props->{'revtime'}) {
		@rt = localtime($props->{'revtime'});
		$revtime = sprintf('%4d-%02d-%02d %02d:%02d:%02d', $rt[5]+1900, $rt[4]+1, $rt[3], $rt[2], $rt[1], $rt[0]);
	}

	# need to specify 8859-1 encoding because utf gets screwed otherwise
	# this makes things incompatible with 5.6. Anybody cares?
	open my $fh, '>:encoding(iso-8859-1)', $fname or die "open $fname: $!";
	binmode $fh;

	XMLout({
		'entry' => {
			'itemid'	=> $itemid,
			'eventtime'	=> $revtime,
			'logtime'	=> $item->{'eventtime'},
			'security'	=> (defined $item->{'security'})? $item->{'security'} : 'public',
			'allowmask'	=> (defined $item->{'allowmask'})? $item->{'allowmask'} : 0,
			'subject'	=> $item->{'subject'},
			'event'		=> $item->{'event'},
			'taglist'			=> $props->{'taglist'},
			'picture_keyword'	=> $props->{'picture_keyword'},
			'current_music'		=> $props->{'current_music'},
			'current_mood'		=> $props->{'current_mood'},
			'current_location'	=> $props->{'current_location'},
			'opt_noemail'		=> $props->{'opt_noemail'},
			'opt_screening'		=> $props->{'opt_screening'},
			'opt_preformatted'	=> $props->{'opt_preformatted'},
			'opt_nocomments'	=> $props->{'opt_nocomments'},
		}
		},
		'KeepRoot'		=> 1,
		'NoAttr'		=> 1,
		'SuppressEmpty'	=> 1,
		'OutputFile'	=> $fh,
	);
	close $fh;
	1;
}


sub rpc {
	my ($query_name, $query_data) = @_;

	my $res;
	$query_data->{'username'} = $user;
	$query_data->{'hpassword'} = $password;

	#carp Dumper $query_data;

	for (1 .. MAXTRY) {
		$res = XMLRPC::Lite
		->proxy(@server)
		->call('LJ.XMLRPC.' . $query_name, $query_data )
		->result();

		if ($res) {
			#print " ok\n";
			last;

		} elsif ($_ == MAXTRY) {
			print " FAILED!\n";
		}
		sleep 2;
	}
	return $res;
}


sub read_dir {
	my ($dir) = @_;

	my @inside = ();
	return @inside unless -d $dir;
	opendir(DIR, $dir) || croak("can't open $dir directory: $!");
	@inside = readdir(DIR);
	closedir DIR;
	return @inside;
}


sub get_file {
	my ($fname) = @_;
	my ($buffer, $contents);
	return undef unless -f $fname;
	return '' unless -s $fname;
	open DF, "<$fname" or croak("error opening '$fname' for reading: $!");
	binmode DF;
	while (read(DF, $buffer, 4096)) {
		croak("error reading '$fname': $!") unless defined $buffer;
		$contents .= $buffer;
	}
	close DF or croak("error closing '$fname': $!");
	return $contents;
}


sub put_file {
	my ($fname, $contents) = @_;
	open DF, ">$fname" or croak( "error opening '$fname' for writing: $!" );
	binmode DF;
	print(DF $$contents) or croak( "error writing contents to '$fname': $!" );
	close DF or croak( "error closing '$fname': $!" );
}


sub my_encode {
	my ($str) = @_;
	return '' if (ref $str);
	return  ($] >= 5.008)? encode_utf8($str) : $str;
}


sub usage {
	my ($error) = @_;
	$user = 'USER' unless defined $user;
	$suser = 'USER' unless defined $suser;
	my %errmsg = (
		'nopassword' 	=> 'use username:password as a first argument',
		'invalidmode'	=> 'mode is one of: private,friends,public,restore,delete,<usemask>',
		'noexport'		=> LOCALDIR . "$suser/export directory should contain xml files exported by ljsm\n#ERROR: (use ljsm -X -u $suser\:password)",
		'cantsync'		=> "Can't update backup data for $suser. Aborting...",
	);
	if ($error) {
		warn "#ERROR: $errmsg{$error}\n";
		
	} else {
		warn "ljpms - utility for batch modification of LiveJournal posts security level\n";
		warn "usage: $0 [-p proxy] [-s source_user] username:password mode\n";
		warn "-s source_user: post source_user's backdated entries to username's journal\n";
		warn "mode: backup|private|friends|public|restore|delete|<usemask>\n";
		warn "<usemask> is a friendgroup identifyer\n\n";
		warn VERSION . "\n";
	}
	1;
}