#!/usr/bin/perl -w
use strict;

=head1 NAME

bric_dev_sync - copies dev resources (Elements and Templates) between servers

=head1 SYNOPSIS

bric_dev_sync [options] source_url target_url [target_url, ...]

Arguments:

  source_url        - the url for the source server
                      (example: http://localhost or just localhost)

  target_url        - the url for the target server(s)
                      (example: http://bric.bar.com or just bar.com)

Options:

  --help            - shows this screen

  --man             - shows the full documentation

  --verbose         - print a running dialogue of operations.  Repeat
                      up to three times of successively larger amounts
                      of debugging information.

  --source-username - the Bricolage username to use on the source
                      server.  Defaults to the BRICOLAGE_USERNAME
                      environment variable if set.

  --source-password - the password to use on the source server.
                      Default to the BRICOLAGE_PASSWORD environment
                      variable if set.

  --target-username - the Bricolage username to use on the target
                      server(s).  Defaults to the BRICOLAGE_USERNAME
                      environment variable if set.

  --target-password - the password to use on the target server(s).
                      Default to the BRICOLAGE_PASSWORD environment
                      variable if set.

  --category        - set to a particular category path to only copy
                      templates in this category.

  --template        - set to the name of a template to copy.  Also
                      accepts SQL match variables to specify groups
                      of templates (ex. "%.pl", "story.%").

  --element         - set to the name of an element to copy.  Also
                      copies templates for just this element unless
                      --no-templates is set.

  --template-id     - set to the ID of a single template to copy.

  --element-id      - set to the ID of a single element to copy.
  
  --site            - the name of a site to copy.

  --with-sub        - also selects sub-elements of the selected element.
                      Useful in combination with --element or
                      --element-id.

  --copy-categories - copy categories from source to target.  Off by
                      default.  You will need this option to copy
                      templates from a category on the source that
                      does not exist in the target.

  --no-elements     - only copies templates.  This may cause failure if
                      the source contains templates for elements that
                      do not exist on the target.

  --no-templates    - only copy elements.

  --no-deploy       - by default templates are deployed after being
                      copied.

  --yes             - don't ask questions, assume the answer is yes and
                      proceed.

  --dry-run         - don't actually perform potentially destructive
                      operations (delete, update, create, deploy).
                      Combine with --verbose for maximum utility.

  --timeout         - specify the HTTP timeout for SOAP requests in
                      seconds.  Defaults to 30.

=head1 DESCRIPTION

This program allows you to copy development resources (elements and
templates) from a source server to one or more target servers.  There
are two main use cases for this program:

=over 4

=item *

Copying development resources from a development machine into
production.

=item *

Copying development resources from a development machine to a private
development environment and back again after changes are made.

=back

For more general resource copying functionality, see the bric_soap
client.

=head1 EXAMPLES

Simply copy all elements and templates from the server called "prod"
to localhost:

  bric_dev_sync http://prod http://localhost

Like the above, but with categories copied also:

  bric_dev_sync --copy-categories prod localhost

Update prod with changes to the "Article" element and all sub-elements
and associated templates:

  bric_dev_sync --element Article --with-sub localhost prod

Update prod with changes with changes to all .pl templates:

  bric_dev_sync --no-elements --template '%.pl' localhost prod

Distribute changes to elements and templates from localhost out to
prod1, prod2 and prod3 machines:

  bric_dev_sync localhost prod1 prod2 prod3

=head1 AUTHOR

Sam Tregar <stregar@about-inc.com>

=head1 SEE ALSO

L<Bric::SOAP|Bric::SOAP>

L<Bric::SOAP::Element|Bric::SOAP::Element>

L<Bric::SOAP::Template|Bric::SOAP::Template>

=cut

use Getopt::Long;
use Pod::Usage;
use Term::ReadPassword;

BEGIN {
    # get parameters from command line.  do this during compile so
    # $VERBOSE can effect use options and such.  also so errors get
    # detected as quick as possible - people are waiting out there!
    our ($source_url, @targ_urls);
    our $source_username        = $ENV{BRICOLAGE_USERNAME};
    our $source_password        = $ENV{BRICOLAGE_PASSWORD};
    our $target_username        = $ENV{BRICOLAGE_USERNAME};
    our $target_password        = $ENV{BRICOLAGE_PASSWORD};
    our $VERBOSE                = 0;
    our $copy_categories        = 0;
    our $with_sub               = 0;
    our $no_elements            = 0;
    our $no_templates           = 0;
    our $no_deploy              = 0;
    our $yes                    = 0;
    our $dry_run                = 0;
    our $timeout                = 30;
    our ($category, $template_name, $element_name, $template_id, $element_id, $site);
    our ($help, $man);
    GetOptions("help"                   => \$help,
	       "man"                    => \$man,
	       "verbose+"               => \$VERBOSE,
	       "source-username=s"      => \$source_username,
	       "source-password=s"      => \$source_password,
	       "target-username=s"      => \$target_username,
	       "target-password=s"      => \$target_password,
	       "category=s"             => \$category,
	       "element=s"              => \$element_name,
	       "template=s"             => \$template_name,
	       "element-id=s"           => \$element_id,
	       "template-id=s"          => \$template_id,
	       "site=s"                 => \$site,
	       "copy-categories"        => \$copy_categories,
	       "with-sub"               => \$with_sub,
	       "no-elements"            => \$no_elements,
	       "no-templates"           => \$no_templates,
	       "no-deploy"              => \$no_deploy,
	       "yes"                    => \$yes,
	       "dry-run"                => \$dry_run,
               "timeout=s"              => \$timeout,
	      ) or  pod2usage(2);

    pod2usage(1)             if $help;
    pod2usage(-verbose => 2) if $man;

    if ($source_password eq '') {
        {
            $source_password = read_password('Source server password: ');
            redo unless $source_password;
        }
    }

    if ($target_password eq '') {
        {
            $target_password = read_password('Target server password: ');
            redo unless $target_password;
        }
    }
        
    # check required options
    pod2usage("Missing required --source-username option ".
	      "and BRICOLAGE_USERNAME environment variable unset.")
	unless defined $source_username;
    pod2usage("Missing required --source-password option ".
	      "and BRICOLAGE_PASSWORD environment variable unset.")
	unless defined $source_password;
    pod2usage("Missing required --target-username option ".
	      "and BRICOLAGE_USERNAME environment variable unset.")
	unless defined $target_username;
    pod2usage("Missing required --target-password option ".
	      "and BRICOLAGE_PASSWORD environment variable unset.")
	unless defined $target_password;

    # get source and targets
    $source_url = shift @ARGV;
    pod2usage("Missing required source URL and target URL parameters")
	unless defined $source_url;
    @targ_urls = @ARGV;
    pod2usage("Missing required target URL parameters")
	unless @targ_urls;
};

our $VERBOSE;
use SOAP::Lite ($VERBOSE > 2 ? (trace => [qw(debug)]) : ());
import SOAP::Data 'name';
use HTTP::Cookies;
require Data::Dumper if $VERBOSE;

main();

# main is where it's at
sub main {
    # connect and login to SOAP servers
    soap_connect();

    # get elements and templates from source
    get_source_assets();

    # dump a big pile of asset data if triple-verbosed
    if ($VERBOSE > 2) {
	our (%elements, %templates);
	print STDERR Data::Dumper->Dump([ \%elements, \%templates],
					[qw(elements    templates)]);
    }

    # sync assets from source to targets
    sync_assets();

    print "bric_dev_sync success.\n";
    exit 0;
}

# syncs source assets from source to targets
sub sync_assets {
    our (%elements, %templates, %categories, $copy_categories);
    sync_categories() if $copy_categories and keys %categories;
    sync_elements()   if keys %elements;
    sync_templates()  if keys %templates;
}

# copies categories from source to target as needed
sub sync_categories {
    our (%categories, @targ);

    # loop over targs, filling in holes in the category tree
    foreach my $soap (@targ) {
	my $doc = "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\n<assets>";
	my $found = 0;

	my ($id, $asset);
	while (($id, $asset) = each %categories) {
	    my ($path) = $asset =~ m!<path>(.*?)</path>!s;
	    my ($exists) = call_list_ids($soap, 'Category',
					 path => $path);
	    unless (defined $exists) {
		$doc .= $asset;
		$found = 1;
	    }
	}
	$doc .= '</assets>';

	if ($found) {
	    print STDERR "Asset document for Element update:\n$doc\n"
		if $VERBOSE > 2;

	    print "\nAbout to create the following categories at ",
		$soap->proxy->endpoint, ":\n",
		    join("\n", map { "\t$_" } $doc =~ m!<path>(.*?)</path>!sg),
			"\n";

	    if (ask_yesno("Are you sure? [yes] ")) {
		print "\nCreating categories...\n";
    		call_create($soap, 'Category', $doc);
	    } else {
		print "Aborting...\n";
		exit 1;
	    }
	}
    }
}

# copies and updates elements from source to targets
sub sync_elements {
    our (%elements, @targ);

    # find an update_ids list for each targ and tweak doc to match
    foreach my $soap (@targ) {
	my $doc = "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\n<assets>";
	my @update_ids;

	# loop through elements finding update targets and
	# fixing-up $this
	my ($id, $asset);
	while (($id, $asset) = each %elements) {
	    my ($name) = $asset =~ m!<name>(.*?)</name>!s;
	    my ($update_id) = call_list_ids($soap, 'ElementType', name => $name);

	    # found a match on targ
	    if ($update_id) {
		push(@update_ids, $update_id);
		# substitute in the update id
		$asset =~ s/id=["']\d+["']/id="$update_id"/;
	    } else {
		# hide id to avoid crosstalk
		$asset =~ s/id=["']\d+["']/id="0"/;
	    }

	    # collect assets
	    $doc .= $asset;
	}
	$doc .= "</assets>\n";

	print STDERR "Asset document for Element update:\n$doc\n"
	    if $VERBOSE > 2;

	# make update call
	print "\nAbout to update/create the following elements at ",
	    $soap->proxy->endpoint, ":\n",
		join("\n", map { "\t$_" } 
		     sort map { $_ =~ m!<name>(.*?)</name>!s }
		     values %elements), "\n";

	if (ask_yesno("Are you sure? [yes] ")) {
	    print "\nUpdating and creating elements...\n";
	    call_update($soap, 'ElementType', 'element_type_id', $doc, @update_ids);
	} else {
	    print "Aborting...\n";
	    exit 1;
	}
    }
}

# create and updates templates from source to targets
sub sync_templates {
    our (%templates, @targ, $no_deploy);

    # find an update_ids list for each targ and tweak doc to match
    foreach my $soap (@targ) {
	my $doc = "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\n<assets>";
	my @update_ids;
	my @ids;

	# loop through templates finding update targets and
	# fixing-up $this
	my ($id, $asset);
	while (($id, $asset) = each %templates) {
	    my ($file_name) = $asset =~ m!<file_name>(.*?)</file_name>!s;
	    my ($oc) = $asset =~ m!<output_channel>(.*?)</output_channel>!s;
	    my ($update_id) = call_list_ids($soap, 'Template', 
					    file_name => $file_name,
					    output_channel => $oc);

	    # found a match on targ
	    if ($update_id) {
		push(@update_ids, $update_id);
		# substitute in the update id
		$asset =~ s/id=["']\d+["']/id="$update_id"/;
	    } else {
		# hide id to avoid crosstalk
		$asset =~ s/id=["']\d+["']/id="0"/;
	    }

	    # collect assets
	    $doc .= $asset;
	}
	$doc .= "</assets>\n";

	print STDERR "Asset document for Template update:\n$doc\n"
	    if $VERBOSE > 2;

	# make sure
	print "\nAbout to update/create the following templates at ",
	    $soap->proxy->endpoint, ":\n",
		join("\n", map { "\t$_" }
		     sort $doc =~ m!<file_name>(.*?)</file_name>!sg ), "\n";

	if (ask_yesno("Are you sure? [yes] ")) {
	    print "\nUpdating and creating templates...\n";
	    # make update call
	    @ids = call_update($soap, 'Template', 'template_id', $doc, @update_ids);
	} else {
	    print "Aborting...\n";
	    exit 1;
	}

	call_deploy($soap, @ids) unless $no_deploy;
    }
}

#
# source data juggling functions
#

# gets the source element and template set
sub get_source_assets {
    our ($no_elements, $no_templates, $template_id, $element_id,
	 $copy_categories);

    if ($copy_categories) {
	print "Gathering source categories...\n";
	get_source_categories();
    }

    unless($no_elements) {
	print "Gathering source elements...\n";
	get_source_elements();
    }

    unless($no_templates) {
	print "Gathering source templates...\n";
	get_source_templates();
    }
 }

# get elements from source based on criteria in options
sub get_source_elements {
    our ($source, $element_name, $element_id, $with_sub);
    our %elements;

    # get elements ids
    my @element_ids;
    if ($element_id) {
	$element_ids[0] = $element_id;
    } elsif ($element_name) {
	@element_ids = call_list_ids($source, 'ElementType',
				     name => $element_name);
    } else {
	@element_ids = call_list_ids($source, 'ElementType');
    }

    print STDERR "Received element ids from source: (",
	join(',', @element_ids), ")\n"
	    if $VERBOSE > 1;

    # get asset documents for source elements into %elements
    get_documents($source, 'ElementType', 'element_type_id', \%elements, @element_ids);

    # add sub-elements if --with-sub
    if ($with_sub) {
	# get starting list of documents to look through
	my @docs = values %elements;
	while (@docs) {
	    # find subelements in doc
	    my $doc = shift @docs;
	    while($doc =~ m!<subelement>(.*?)</subelement>!sg) {
		my $sub_name = $1;

		# find id for subelement
		my ($sub_id) = call_list_ids($source, 'ElementType',
					     name => $sub_name);

		# if new, load document
		unless (exists $elements{$sub_id}) {
		    push(@element_ids, $sub_id);
		    get_documents($source, 'ElementType', 'element_type_id', \%elements, $sub_id);
		    push(@docs, $elements{$sub_id});
		}
	    }
	}

	print STDERR "Element id list after --with-sub processing: (",
	    join(',', @element_ids), ")\n"
		if $VERBOSE > 1;
    }

    die "No elements found on source server matching specified criteria.\n"
	unless @element_ids;
}

# gets source templates
sub get_source_templates {
    our ($source, $category, $template_name, $template_id, $element_name,
	 $with_sub);
    our (%elements, %templates);

    # get elements ids
    my @template_ids;
    if ($template_id) {
	# already have an id
	$template_ids[0] = $template_id;
    } else {
	my @search;
	push(@search, name => $template_name)
	    if $template_name;
	push(@search, category => $category)
	    if $category;
	push(@search, element => $element_name)
	    if $element_name;

	# get templates by criteria, or all if no search setup
	@template_ids = call_list_ids($source, 'Template', @search);
    }

    print STDERR "Received template_ids from source: (",
	join(',', @template_ids), ")\n"
	    if $VERBOSE > 1;

    # get asset documents for source elements into %elements
    get_documents($source, 'Template', 'template_id', \%templates, @template_ids);

    # get templates for all found elements if with-sub is set
    if ($with_sub) {
	foreach my $id (keys %elements) {
	    my ($sub_name) = $elements{$id} =~ m!<name>(.*?)</name>!s;

	    # find templates ids for this element
	    my @sub_ids = call_list_ids($source, 'Template',
					element => $sub_name);

	    # look for new ids and load documents
	    foreach my $sub_id (@sub_ids) {
		unless (exists $templates{$sub_id}) {
		    push(@template_ids, $sub_id);
		    get_documents($source, 'Template', 'template_id', \%templates, $sub_id);
		}
	    }
	}

	print STDERR "Template id list after --with-sub processing: (",
	    join(',', @template_ids), ")\n"
		if $VERBOSE > 1;
    }

    die "No templates found on source server matching specified criteria.\n"
	unless @template_ids;
}

# get source categories
sub get_source_categories {
    our ($source, %categories);

    # get all category ids
    my @category_ids = call_list_ids($source, 'Category');

    print STDERR "Received category ids from source: (",
	join(',', @category_ids), ")\n"
	    if $VERBOSE > 1;

    # get asset documents for source categories into %categories
    get_documents($source, 'Category', 'category_id', \%categories, @category_ids);
}

#
# SOAP interfacial functions
#

# get a list of ids from a specified module using search provided
sub call_list_ids {
    my ($soap, $module) = (shift, shift);
    our $site;

    # switch to module
    $soap->uri('http://bricolage.sourceforge.net/Bric/SOAP/' . $module);

    # build search parameters
    my @search;
    while (@_) {
	my ($k, $v) = (shift, shift);
	push(@search, name($k, $v));
    }
    push(@search, name("site", $site)) if $site;

    print STDERR "Calling Bric::SOAP::$module->list_ids(",
	join(', ', map { $_->name . " => \"" . $_->value . "\"" } @search),
	    ") on ", $soap->proxy->endpoint, "\n"
		if $VERBOSE;

    # run list_ids
    my $response = $soap->list_ids(@search);

    # check fault
    _print_fault($response) if $response->fault;

    # return result list
    my $list = $response->result;
    return sort { $a <=> $b } @$list if $list;
    return ();
}

# calls update on chosen SOAP module, returns list of ids
sub call_update {
    my ($soap, $module, $type, $document) = (shift, shift, shift, shift);
    our $dry_run;

    # switch to module
    $soap->uri('http://bricolage.sourceforge.net/Bric/SOAP/' . $module);

    print STDERR "Calling Bric::SOAP::$module->update(",
	length($document) . " bytes, ", join(', ', @_), ") on ",
	    $soap->proxy->endpoint, "\n"
		if $VERBOSE;

    # run create
    unless ($dry_run) {
	my $response = $soap->update(name(document =>
					  $document)->type('base64'),
				     name(update_ids =>
					  [ map { name($type, $_) } @_ ]));

	# check fault
	_print_fault($response) if $response->fault;

	# return result list
	my $list = $response->result;
	return @$list if $list;
	return ();
    }
}


# calls create on chosen SOAP module, returns list of ids
sub call_create {
    my ($soap, $module, $document) = (shift, shift, shift);
    our $dry_run;

    # switch to module
    $soap->uri('http://bricolage.sourceforge.net/Bric/SOAP/' . $module);

    print STDERR "Calling Bric::SOAP::$module->create(",
	length($document) . " bytes) on ",  $soap->proxy->endpoint, "\n"
	    if $VERBOSE;

    # run create
    unless ($dry_run) {
	my $response = $soap->create(name(document =>
					  $document)->type('base64'));

	# check fault
	_print_fault($response) if $response->fault;

	# return result list
	my $list = $response->result;
	return @$list if $list;
	return ();
    }
}


# delete specified ids
sub call_delete {
    my ($soap, $module, $type) = (shift, shift, shift);
    our $dry_run;
    return unless @_;

    # switch to module
    $soap->uri('http://bricolage.sourceforge.net/Bric/SOAP/' . $module);

    # loop over ids exporting
    print STDERR "Calling Bric::SOAP::$module->delete(",
	join (', ', @_), ") on ",
	    $soap->proxy->endpoint, "\n" if $VERBOSE;

    unless ($dry_run) {
	my $response = $soap->delete(name("${type}s" =>
					  [ map { name($type, $_) } @_ ]),
				     $module eq 'ElementType' ?
				     name(force => 1)     :
				     ());
	_print_fault($response) if $response->fault;
    }
}

# deploy specified ids
sub call_deploy {
    my $soap = shift;
    my $module = 'Workflow';
    my $type = 'template_id';
    our $dry_run;
    return unless @_;

    # switch to module
    $soap->uri('http://bricolage.sourceforge.net/Bric/SOAP/' . $module);

    # loop over ids exporting
    print STDERR "Calling Bric::SOAP::$module->deploy(",
	join (', ', @_), ") on ",
	    $soap->proxy->endpoint, "\n" if $VERBOSE;

    unless ($dry_run) {
	my $response = $soap->deploy(name("deploy_ids" =>
					  [ map { name($type, $_) } @_ ]));
	_print_fault($response) if $response->fault;
    }
}

# gets asset documents from source and places them in %$hash by id
sub get_documents {
    my ($soap, $module, $type, $hash) = (shift, shift, shift, shift);

    # switch to module
    $soap->uri('http://bricolage.sourceforge.net/Bric/SOAP/' . $module);

    # loop over ids exporting
    foreach my $id (@_) {
	print STDERR "Calling Bric::SOAP::$module->export($type => $id) on ",
	    $soap->proxy->endpoint, "\n" if $VERBOSE;

	my $response = $soap->export(name($type, $id));
	_print_fault($response) if $response->fault;
	$hash->{$id} = $response->result;

	# strip off assets element and xml declaration
	$hash->{$id} =~ s!<\?xml[^>]+>\s*<assets[^>]*>\s*(.*)</assets>!$1!s;
    }
}

#
# startup dance routines
#

# connect source and target soap handles
sub soap_connect {
    our ($source_url, $source_username, $source_password);
    our (@targ_urls,  $target_username, $target_password);
    our ($source, @targ);

    # connect to source
    $source = soap_connect_to($source_url, $source_username, $source_password);

    # connect to targets
    foreach (@targ_urls) {
	push @targ, soap_connect_to($_, $target_username, $target_password);
    }
}

# connects to a specific SOAP server given url, username and password
sub soap_connect_to {
    my ($url, $username, $password) = @_;
    our $timeout;

    # fixup url if missing http://
    $url = "http://$url" unless $url =~ m!^https?://!;

    # setup soap object to login with
    my $soap = new SOAP::Lite
	uri      => 'http://bricolage.sourceforge.net/Bric/SOAP/Auth',
        readable => $VERBOSE >= 2 ? 1 : 0;
    $soap->proxy($url . '/soap',
		 cookie_jar => HTTP::Cookies->new(ignore_discard => 1),
		 timeout => $timeout,
		);

    # login
    print STDERR "Logging in to $url as $username...\n" if $VERBOSE;
    my $response = $soap->login(name(username => $username),
				name(password => $password));
    die "Login to $url as $username failed.\n" if $response->fault;
    print STDERR "Login to $url success.\n" if $VERBOSE;

    return $soap;
}

#
# UI functions
#

# asks the user a yes/no question.  returns 1 for yes, 0 for no.
sub ask_yesno {
    my $question = shift;
    our $yes;
    my $tries = 1;
    local $| = 1;
    while (1) {
	print $question;
	if ($yes) { print "\n"; return 1 }
	my $answer = <STDIN>;
	chomp($answer);
	return 0 if $answer and $answer =~ /^no?$/i;
	return 1 if not length $answer or $answer =~ /^y(?:es)?$/i;
	print "Please answer \"yes\" or \"no\".\n";
	print "And quit screwing around.\n" if ++$tries > 3;
    }
}

# prints out fault message
sub _print_fault {
    my $r = shift;
    if ($r->faultstring eq 'Application error' and
	ref $r->faultdetail and ref $r->faultdetail eq 'HASH'    ) {
	# this is a bric exception, the interesting stuff is in detail
	die "Call to Bric::SOAP failed : \n" .
	    join("\n", values %{$r->faultdetail});
    } else {
	die "Call to Bric::SOAP failed : \n" .
	    $r->faultstring;
    }
}