#!/usr/bin/perl
# $File: //depot/ebx/ebx $ $Author: autrijus $
# $Revision: #61 $ $Change: 1480 $ $DateTime: 2001/07/23 01:13:40 $

$VERSION  = '0.84';
$REVISION = "rev$1\[\@$2\]"
    if ('$Revision: #61 $ $Change: 1480 $' =~ /(\d+)[^\d]+(\d+)/);

=head1 NAME

ebx - Elixir BBS Exchange Suite

=head1 SYNOPSIS

    % ebx sync [-lgdfh] [-m <maxmsg>] [-o [logfile]] ]
               [-u <user>] [<boards>...]
    % ebx <set|del|list>pass [-r] [-l] [-d] [-u <user>]
    % ebx <set|list>board [<boards>...]

=head1 DESCRIPTION

This script synchronizes your local BBS's storage via the BBSCOM
settings configured within.

=head1 COMMANDS

    sync		perform synchronization

    setpass		add login/password pairs
    delpass		delete login/password pairs
    listpass		list current keyring

    setboard		set up boards for mirroring
    listboard		list board settings

=head1 OPTIONS

    -d			enable debugging messages
    -f			enable per-site forking
    -g			skip passring check, use guest for all sites
    -l			enable per-site locking
    -S			force sending of duplicate articles
    -F			force fetching of duplicate articles
    -R			refresh message id, do nothing else
    -P			preserve remote user id and headers
    -m <maxmsg>		set maximal number of message to keep track
    -o [logfile]	output to log stdout instead of log files
    -u <user>		specify the owner of gpg keyring
    -a			recursively sync archive. *EXPERIMENTAL*
    <synclist>...	process specified boards or source

=head1 ENVIRONMENT

The following environment variables are understood by ebx:

=over

=item EBX_BACKEND

The local BBS's backend. Defaults to MELIX.

=item EBX_BBSROOT

The local BBS's location. Defaults to /home/melix or /home/bbs.

=item EBX_USER

The owner to C<.ebx.keyring>, the private keyring used to store
encrypted ebx passwords. Defaults to USER.

=item EBX_HOME

The home directory of EBX_USER, defaults to HOME.

=back

=cut

use strict;
use warnings;
use open IN => ':raw', OUT => ':raw';
use Term::ReadKey;

BEGIN { ReadMode('noecho') }
END   { ReadMode('restore') }

use File::Spec;
use IO::Handle;
use MIME::Base64;
use Compress::Zlib;
use Getopt::Std;
use Storable qw/nfreeze thaw/;

use OurNet::BBS '1.55';
use OurNet::BBSApp::Sync;

$|++;

no strict 'refs';
*{'::DESTROY'} = sub {};

local $SIG{__DIE__};
local $SIG{__WARN__};

if ($^O eq 'MSWin32' and eval 'use Win32; 1') {
    $SIG{__DIE__} = sub {
        Win32::MsgBox(
            $_[0], 
            $_[0] =~ /^\n/ ? &Win32::MB_ICONINFORMATION
                           : &Win32::MB_ICONERROR,
            "EBX v$main::VERSION-$main::REVISION",
        ) unless $^S or $_[0] =~ /DESTROY/;
    };

    $SIG{__WARN__} = sub {
        Win32::MsgBox(
            $_[0], 
            $_[0] =~ /\n$/ ? &Win32::MB_ICONEXCLAMATION
                           : &Win32::MB_ICONINFORMATION,
            "EBX v$main::VERSION-$main::REVISION",
        ) unless $^S or $_[0] =~ /DESTROY/;
    };
}    

my %args;
my $action = shift(@ARGV) if
    @ARGV and substr($ARGV[0], 0, 1) ne '-';

getopts('m:o:u:dfglhaSFRP', \%args);

$action ||= shift(@ARGV) || '';

if ($args{h}) {
    if ($^O eq 'MSWin32') {
        require Pod::Text;

	my $source = $0;
	$source  =~ s/\.exe$//i;
	open(my $fh, $source) or die "cannot open $source for reading.\n";
	use open IN => ':raw', OUT => ':crlf';

	open my $fhout, '>', "$ENV{TEMP}/ebx.txt"
	    or die "cannot open $ENV{TEMP}/ebx.txt for writing.\n";
	
	*STDOUT = $fhout;

	Pod::Text->new(
	    sentence => 0, width => 78
	)->parse_from_filehandle($fh);

	close $fh;
	close $fhout;

	exec("$ENV{TEMP}/ebx.txt");
    }
    else {
	ReadMode('restore');
	exec('perldoc', $0);
    }
}

my $bbs      = init_bbs();
my $logfh    = IO::Handle->new();
my $tmp_path = File::Spec->tmpdir();
my $maxmsg   = $args{m} || 128;
my $user     = $args{u} || $ENV{EBX_USER} || $ENV{USER} ||
    (($^O eq 'MSWin32') ? $ENV{USERNAME} : getpwent());
my $passphrase;

$OurNet::BBS::DEBUG = $OurNet::BBS::DEBUG = 1 if $args{d};

my @actions  = qw/sync setpass delpass listpass setboard listboard/;

if (index(" @actions ", " $action ") > -1) {
    no strict 'refs'; &{$action};
}
else {
    my $actions = join('|', @actions);

    die << ".";

Elixir BBS Exchange Suite v$main::VERSION-$main::REVISION

Usage: $0 <$actions> [options]
Type '$0 -h' to see available options.

Copyright 2001 by Chia-Liang Kao <clkao\@clkao.org>,
                  Autrijus Tang <autrijus\@autrijus.org>.

This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.

See <http://www.perl.com/perl/misc/Artistic.html>.

.
}

# ===================================================================
# The BOARD command family section
# ===================================================================

sub listboard {
    foreach my $board (sort { $a cmp $b } keys %{$bbs->{boards}}) {
	my $bm    = $bbs->{boards}{$board}{bm};
        next if @ARGV and index(" @ARGV ", " $board ") == -1
                      and index(" @ARGV ", ' @'.substr($bm, 2).' ') == -1;
	my $title = $bbs->{boards}{$board}{title};
	print "$board\t$title\t$bm\n";
    }
}

sub setboard {
    @ARGV = split(/[\s\t]+/, input("enter board(s) to setup mirror: "))
        unless @ARGV;

    die "no board(s) specified for setup.\n" unless @ARGV;

    foreach my $board (@ARGV) {
	# XXX: is the function below desirable?
	if (exists $bbs->{boards}{$board}) {
=begin comment
	    my $inp = input("board exists. continue? [y/N/c(lear)]: ");
	    next if $inp =~ /[Nn]/;
	    if ($inp =~ /[Cc]/) {
		my $artgrp = $bbs->{boards}{$board}{articles};
		foreach my $key (keys(%{$artgrp})) {
		    delete $artgrp->{$key};
		};
		warn "board <$board> cleared.\n";
	    }
=cut
	}
	elsif ($^O eq 'MSWin32') {
	    my $path = find_bbs(
		'c:/cygwin/home/melix', 'c:/program files/melix/home/melix'
	    );
	    
	    system("$path/bin/sh.exe", '/home/melix/bin/stop.sh')
	        if defined $path;
	}

	modify_board(
	    $board,
	    get_addr(
		input("enter backend for $board [BBSAgent]: ") || 'BBSAgent',
		input("enter remote site: "),
	    ),
	    input("enter remote board [$board]: ") || $board,
	    input("enter local title [$board]: ") || $board,
	    (input("do you want postback? [Y/n]: ") !~ /[Nn]/),
	    input("sync after which article? [0]: "),
	);
    }

    warn "boards(s) successfully set.\n";
}


sub get_addr {
    my ($backend, $site) = @_;
    return (@_, $site) unless $backend eq 'BBSAgent';

    foreach my $path (@INC) {
        foreach my $bbsfile (
	    "$path/OurNet/BBSAgent/$site",
	    "$path/OurNet/BBSAgent/$site.bbs",
	    "$path/$site", "$path/$site.bbs",
	) {
	    open _, $bbsfile or next; scalar <_>;
	    my $port = scalar <_>; chomp($port);
	    $port =~ s/:23$//;
	    return (@_, $port);
	}
    }

    die "cannot find bbsfile for $site\n";
}

sub modify_board {
    my ($lbrd, $back, $site, $addr, $rbrd, $ltit, $pbac, $rsen) = @_;

    $pbac = $pbac ? 0 : '';
    $rsen ||= 0;

    $bbs->{boards}{$lbrd} = {
	title => (index($ltit, 2, 1) eq ' ' ? $ltit : "   $ltit"),
	bm    => "# $site",
    };

    my $brd = $bbs->{boards}{$lbrd};
    my $arv = $brd->{archives};

    (($#{$arv} > 0) ? $arv->[1] : $arv->{''}) = {
	header => {
	    From    => "SYSOP (EBX v$main::VERSION-$main::REVISION)",
	    Subject => '#',
	    Board   => $lbrd,
	    Date    => (scalar localtime),
	},
	body        => << ".",
# remote: $addr
# backend: $back
# source: $site
# board: $rbrd
# rseen: $rsen
# lseen: $pbac
# lmsgid:
__XMSGID__
.
    };
}

# ===================================================================
# The PASS command family section
# ===================================================================

# create login/pass pair
sub setpass {
    my ($passring, $keyring) = get_keyring();
    die "usage: $0 setpass [<sites>...]\n" unless @ARGV;

    foreach my $site (@ARGV) {
	my $login = input("enter login name for <$site>: ");
	my $pass  = input("enter password for <$login\@$site>: ", 1);

	$keyring->{$site} = "$login:$pass";
    }

    $passring->save_keyring($keyring);
    warn "password(s) successfully set.\n";
}

# list all login/pass pairs
sub listpass {
    my $keyring = get_keyring();

    print "passring list for $user:\n";

    while (my ($site, $info) = each(%$keyring)) {
	$info =~ s/:.*$//;
	printf "%-18s %s\n", "[$site]", $info;
    }
}

# delete login/pass pair
sub delpass {
    my ($passring, $keyring) = get_keyring();
    die "usage: $0 delpass [<sites>...]\n" unless @ARGV;

    foreach my $site (@ARGV) {
	unless (exists $keyring->{$site}) {
	    warn "site $site does not exist\n";
	    next;
	}

	delete $keyring->{$site};
    }

    $passring->save_keyring($keyring);
    warn "password(s) successfully deleted.\n";
}

# ===================================================================
# The SYNC command family section
# ===================================================================

# perform synchronization.
sub sync {
    my %remote  = sync_init();
    my $keyring = get_keyring() unless $args{g};

    foreach my $entry (keys(%remote)) {
	$logfh->fdopen(
	    ($args{o} ? make_logfile($entry) : fileno(STDOUT)), 'w'
	) unless (($logfh->fileno || -1) == fileno(STDOUT));

	next if ($args{f} and fork());

	my $lockfile = make_lockfile($entry) or next;

	$logfh->print("synchronizing $entry\n");

	my ($backend, $rhost) = split('::', $entry, 2);
	my @rhost = $rhost;

	if ($backend eq 'OurNet') {
	    @rhost = split(':', $rhost[0]);
	    push @rhost, '' unless $rhost[1];
	    push @rhost, $user;
	}

	my $rbbs = eval { OurNet::BBS->new(
	    $backend, @rhost, get_login($keyring, $rhost, $backend)
	) };

	if ($@) {
	    warn $@;
	    exit if $args{f};
	    next;
	}

	foreach my $site (@{$remote{$entry}}) {
	    sync_start($rbbs, $site, $entry)
	    # and sync_start($rbbs, $site, $entry); # XXX broken
	}

	unlink($lockfile) if -e $lockfile;
	exit if $args{f};
    }

    return unless $args{f};
    while (wait() != -1) { };
}

# starts synchronization.
sub sync_start {
    my ($rbbs, $site, $entry) = @_;
    my $restart;
    my $param  = $site->{param};
    my $lbrdag = $site->{lbrdag};
    my $lbrdac = $site->{lbrdac};
    my $rbrd   = eval { $rbbs->{boards} };

    if (!$rbrd or $@) { $logfh->print("cannot login ($@)"); return; }

    $logfh->print("=> ${entry}::$site->{param}{board}\n");

    $rbrd = eval { $rbrd->{$param->{board}} };

    if ($@) { $logfh->print("cannot access board ($@)"); return; }

    my $sync = OurNet::BBSApp::Sync->new({
	artgrp     => $lbrdag,
	rartgrp    => $rbrd->{articles},
	param      => $param,
	backend    => $param->{backend},
	logfh      => $logfh,
	msgidkeep  => $args{m},
	force_send => $args{S},
	force_fetch=> $args{F},
	force_none => $args{R},
	recursive  => $args{a},
	clobber	   => !(defined($args{P})),
    });

    $sync->do_fetch;

    if ($args{a}) {
	# sync archive!
	$sync->{param}   = {
	    %{$param}, rseen => 0, lseen => undef, force_fetch => 1,
	};
	$sync->{artgrp}  = $lbrdac,
	$sync->{rartgrp} = $rbrd->{archives},
	$sync->do_fetch;
	$sync->{param}   = $param;
    }

    $restart = $sync->do_send() unless ($args{g});

    update_config($site->{config}, $site->{param});

    $lbrdag->purge();
    $rbrd->purge();

    return $restart;
}

# initialize synchronization
sub sync_init {
    my %remote;
    my %synclist = map { $_ => 1 } @ARGV;
    my $boards = $bbs->{boards};
    my @sync = (index("@ARGV", '@') > -1) 
	? grep { exists $boards->{$_} } @ARGV
	: keys(%$boards);

    print "scheduled for sync:";

    foreach my $name (sort { uc($a) cmp uc($b) } @sync) {
	my $brd = $boards->{$name};
	my $arv = $brd->{archives};

	while (my (undef, $art) = each(%{$brd->{archives}})) {
	    next if ref($art) =~ /Group/;
	    next unless $art->{title} =~ m/^\#/;

	    my %param = %{read_config($art)};

	    next if %synclist and !$synclist{$name}
		and !$synclist{'@'.($param{source} || '')};

	    next unless $param{source} and $param{board}
		and (length($param{rseen}) or length($param{lseen}));

	    print " $name";

	    $param{backend} ||= 'BBSAgent';

	    my $key = "$param{backend}::$param{source}";

	    push @{$remote{$key}}, {
		lbrdag => $brd->{articles},
		lbrdac => $brd->{archives},
		param  => \%param,
		config => $art,
	    };
	}

	$boards->purge();
    }

    die " ...nothing scheduled for sync, stopping.\n" unless (%remote);

    print "\n";
    return %remote;
}

# ===================================================================
# Utility functions
# ===================================================================

# get login name from keyring.
sub get_login {
    my ($keyring, $rhost, $backend) = @_;

    if (exists $keyring->{$rhost}) {
	my ($login, $pass) = split(/:/, $keyring->{$rhost}, 2);
	$pass ||= $passphrase if $backend eq 'OurNet';
	return ($login, $pass);
    }
    elsif ($backend eq 'BBSAgent') {
	print "no login info in keyring found for $rhost: using guest\n"
	    unless $args{g};

        return 'guest';
    } elsif ($backend eq 'OurNet') {
	return ($user, $passphrase);
    }
}


sub get_keyring {
    require OurNet::BBSApp::PassRing;

    my $passring = OurNet::BBSApp::PassRing->new(
	($ENV{EBX_HOME} || $ENV{HOME} || '.').'/.ebx.keyring', $user
    );

    my $keyring;

    for (1..3) {
	$passphrase = input("enter passphrase for $user: ", 1);
	$keyring = eval {$passring->get_keyring($passphrase)};
	warn "can't get keyring; check passphrase and try again ($@).\n" if $@;
	last unless $@;
    }

    die "failed too many times, giving up.\n" if $@;

    return wantarray ? ($passring, $keyring) : $keyring;
}

sub read_config {
    my $art    = shift;
    my $xmsgid = 0;
    my $msgid  = '';
    my %param;

    foreach my $line (split("\n", ($art->{body} || ''))) {
	if ($xmsgid == 1) {
	    $msgid .= $line;
	}
	elsif ($line eq '__XMSGID__') {
	    $xmsgid = 1;
	}
	elsif ($line =~ m/^\# (\w+):\s*(.*)$/) {
	    $param{$1} = $2;
	}
    }

    if ($msgid) {
	$param{msgids} = thaw(uncompress(decode_base64($msgid)));
	if ($param{msgids} and $param{msgids}[0] and
	    substr($param{msgids}[0], 0, 1) ne '<'
	) {
	    # transition script
	    foreach my $msgid (@{$param{msgids}}) {
		next unless defined $msgid;
		$msgid = "<$msgid>" if substr($msgid, 0, 1) ne '<';
	    }
	}
    }

    return \%param;
}

sub update_config {
    my ($art, $param) = @_;

    $param->{msgids} = [@{$param->{msgids}}[-(($maxmsg) * 2) .. -1]]
	if $#{$param->{msgids}} > ($maxmsg) * 2;

    my $newmsg = encode_base64(compress(nfreeze($param->{msgids})));
    my @lines  = grep {!m/^# /} split("\n", $art->{body});
    my $body   = join("\n", ((map {
	"# $_: ".(defined $param->{$_} ? $param->{$_} : '')
    } qw/remote backend source board rseen lseen lmsgid/), @lines));

    $body =~ s/__X?MSGID__[\x00-\xff]*$/__XMSGID__\012$newmsg/;
    $art->{body} = $body;

    $logfh->print("[BoardSync] $param->{board}: configuration updated.\n");
}

sub make_lockfile {
    my $lockfile = "ebx-$_[0].lock";
    $lockfile =~ s{/|::}{-}g;

    return $lockfile unless $args{l};

    open LOCK, ">$tmp_path/$lockfile" or return;
    print LOCK $$;
    close LOCK;

    return $lockfile;
}

sub make_logfile {
    my $entry   = shift;
    my $logfile = $args{o} || "$tmp_path/sync.$entry.log";

    chmod 0666, $logfile;
    open LOG, ">$logfile" or die "cannot write logfile: $!";

    return fileno(LOG);
}

sub input {
    my ($prompt, $silent) = @_;

    ReadMode($silent ? 'noecho' : 'normal');

    print $prompt;
    my $input = <STDIN>;
    chomp $input;
    print "\n" if $silent;

    return $input;
}

sub init_bbs {
    my ($bbs, $backend, $bbsroot);

    $backend = $ENV{EBX_BACKEND} || 'MELIX';
    $bbsroot = $ENV{EBX_BBSROOT} || (
	($^O eq 'MSWin32') ? find_bbs(
	    'c:/cygwin/home/melix', 'c:/program files/melix/home/melix'
	) : find_bbs('/home/melix', '/home/bbs')
    );

    local $@;
    $bbs = eval { OurNet::BBS->new($backend, $bbsroot, 2997, 350) };

    if ($@) {
	$bbs = OurNet::BBS->new($backend, $bbsroot);
	warn "warning: tying up shared memory (2997, 350) failed.\n";
    }

    return $bbs;
}

sub find_bbs {
    local $@;
    
    if ($^O eq 'MSWin32' and eval 'use Win32::TieRegistry; 1') {
    	no warnings 'once';
        my $Registry = $Win32::TieRegistry::Registry;

	my $binary_path = (
	    $Registry->{'HKEY_LOCAL_MACHINE\Software\Elixir\melix\\'}->{''} ||
            $Registry->{'HKEY_LOCAL_MACHINE\Software\Cygnus Solutions\\'.
                        'Cygwin\mounts v2\/\native'}
        );
        
        unshift(@_, "$binary_path/home/melix") if defined $binary_path;
    }

    foreach my $path (@_, '.') {
	return $path if -d $path and -e "$path/.BRD";
    }

    die "cannot find Melix BBS's .BRD file in path: (@_).\n"
}

1;

__END__

=head1 AUTHORS

Chia-Liang Kao E<lt>clkao@clkao.org>,
Autrijus Tang E<lt>autrijus@autrijus.org>

=head1 COPYRIGHT

Copyright 2001 by Chia-Liang Kao E<lt>clkao@clkao.org>,
		  Autrijus Tang E<lt>autrijus@autrijus.org>.

This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.

See L<http://www.perl.com/perl/misc/Artistic.html>

=cut
