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

=head1 NAME

bric_soap - a command-line client for the Bricolage SOAP interface

=head1 SYNOPSIS

bric_soap module command [options] [ids or filenames or -]

Modules:

  story
  media
  template
  element_type
  category
  media_type
  site
  keyword
  user
  desk
  workflow
  element_type_set  (being removed)
  output_channel
  contrib_type
  dest
  pref

Commands:

  Asset Commands (story, media, template, element_type, category,
                  media_type, site, keyword, user, desk, element_type_set,
                  output_channel, contrib_type, dest, pref):

    list_ids
    export
    create  (not 'pref')
    update
    delete  (not 'pref')

  Workflow Commands:

    publish
    deploy
    checkin
    checkout
    move

Options:

  --help                 - shows this screen

  --man                  - shows the full documentation

  --server               - specifies the Bricolage server URL, defaults to
                           the BRICOLAGE_SERVER environment variable if set,
                           http://localhost otherwise.

  --username             - the Bricolage username, defaults to the
                           BRICOLAGE_USERNAME environment variable if
                           set, 'admin' otherwise

  --password             - the password for the Bricolage user.
                           Default to the BRICOLAGE_PASSWORD
                           environment variable if set.

  --with-related-stories - tell export and publish to include related stories

  --with-related-media   - tell export and publish to include related media

  --all                  - synonym for setting --with-related-stories and
                           --with-related-media

  --desk                 - required desk option for move command; optional for
                           create and update commands

  --workflow             - workflow option for move, create, and update commands

  --search field=value   - specify a search for list_ids, field must
                           be a valid search field for the list_ids()
                           method of the appropriate module.

  --verbose              - print a running description to STDERR.  Add
                           a second --verbose and you'll get debugging
                           output too.  Add a third and you'll see a full
                           XML trace.

  --to-preview           - use to_preview option for workflow publish

  --publish-date         - date and time to publish assets for workflow
                           publish. Use format CCYY-MM-DDThh:mm:ssZ, where
                           the "Z" stands for UTC (GMT).

  --published-only       - for workflow publish, republish the published
                           version rather than the current version; if the
                           asset hasn't been published, don't publish anything

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

  --save-cookie-file	 - specify a file to save cookies to for later use-
			   useful if you do not wish to relogin each time.

  --use-cookie-file      - specify a file in which cookies have been saved
			   during a previous session.  If you use this
			   option no username or password are
			   required.

  --chunks               - perform actions in chunks of this many ids.
                           Currently implemented only for the workflow
                           commands (publish, deploy, checkin,
                           checkout, move) but may be expanded to
                           other commands as needed.  Defaults to 0
                           which means no chunking.

  --continue-on-errors   - normally an error returned by a call to the
                           SOAP interface is fatal and bric_soap stops
                           immediately.  If this flag is set then the
                           errror message is printed but processing
                           continues, if possible.  Currently
                           implemented only for the workflow commands
                           (publish, deploy, checkin, checkout, move)
                           but may be expanded to other commands as
                           needed.


=head1 EXAMPLES

Here are some example command-lines.  The examples assume that you've
set the BRICOLAGE_USERNAME and BRICOLAGE_PASSWORD environment
variables and that your local Bricolage server is running on
http://localhost.  If this is not the case you'll need to add
--username, --password and --server arguments as appropriate.

Output an XML dump of the story with story_id 1024 into the file
1024.xml:

  bric_soap story export 1024 > 1024.xml

Upload that story to the server at some.host.org:

  bric_soap story create --server http://some.host.org 1024.xml

A simpler way to do the above two steps:

  bric_soap story export 1024 \
  | bric_soap story create --server some.host.org -

Copy all stories from the local Bricolage to the server at some.host.org:

  bric_soap story list_ids
  | bric_soap story export - \
  | bric_soap story create --server some.host.org -

Delete all stories (gasp!):

  bric_soap story list_ids | bric_soap story delete -

Publish all unpublished stories:

  bric_soap story list_ids --search publish_status=0
  | bric_soap workflow publish -

Publish all unpublished stories at a future time:

  bric_soap story list_ids --search publish_status=0
  | bric_soap workflow publish --publish-date 2005-01-01T00:00:00Z -

Publish all unpublished stories, in chunks of 5 to avoid timeouts

  bric_soap story list_ids --search publish_status=0
  | bric_soap workflow publish --chunks 5 -

Republish all published stories.  This is useful when a template
change needs to be reflected across a site.  The C<sort -k2 -t_ -n> is a
crude way to make sure that newer stories overwrite older ones.

  bric_soap story list_ids --search publish_status=1 \
  | sort -k2 -t_ -n
  | bric_soap workflow publish -

Copy the story titled "Annoying Ad Turns Man Pro-Whaling" to the
server at some.host.org along with any related media and related
stories.  Then publish the story along with any related stories or
media.

  bric_soap story list_ids \
     --search "title=Annoying Ad Turns Man Pro-Whaling" \
  | bric_soap story export --all - \
  | bric_soap story create --server http://some.host.org - \
  | bric_soap workflow publish --server some.host.org -

=head1 ID PARAMETERS

Commands that take ids for parameters (delete, export, publish, etc.)
always accept fully qualified ids:

  bric_soap workflow publish story_1024 media_1028

Conveniently, this is the format produced by commands that output ids.

Some commands also accept unqualified ids when their meaning is
obvious:

  bric_soap story export 1024

If you try to use an unqualified id parameter with a command that
requires qualified ids you will receive an error message.

=head1 BASH COMPLETION

There is bash tab-completion for bric_soap. See F<contrib/bash_completion>.

=head1 AUTHOR

Sam Tregar <stregar@about-inc.com>

=head1 SEE ALSO

L<Bric::SOAP>

=cut

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

# predeclare to get prototype support
sub _foreach_chunks (&@);

BEGIN {
    our $module;
    our $command;
    our %search;
    our $with_related_stories = 0;
    our $with_related_media   = 0;
    our $to_preview           = 0;
    our $publish_date;
    our $published_only       = 0;
    our $timeout              = 30;
    our $chunks               = 0;
    our $continue             = 0;
    our $username               = $ENV{BRICOLAGE_USERNAME} || 'admin';
    our $password               = $ENV{BRICOLAGE_PASSWORD} || '';
    our $server                 = $ENV{BRICOLAGE_SERVER} || 'http://localhost';
    our $use_cookie;
    our $save_cookie;
    our $verbose;
    our $desk;
    our $workflow;
    our ($help, $man);
    GetOptions("help"                   => \$help,
	       "man"                    => \$man,
	       "verbose+"               => \$verbose,
	       "username=s"             => \$username,
	       "password:s"             => \$password,
	       "server=s"               => \$server,
	       "search=s"               => \%search,
	       "with-related-stories"   => \$with_related_stories,
	       "with-related-media"     => \$with_related_media,
	       "all"                    => sub { $with_related_stories = 1;
						 $with_related_media   = 1; },
	       "to-preview"             => \$to_preview,
	       "publish-date=s"         => \$publish_date,
               "published-only"         => \$published_only,
	       "desk=s"                 => \$desk,
	       "workflow=s"             => \$workflow,
               "timeout=s"              => \$timeout,
	       "save-cookie-file=s"     => \$save_cookie,
	       "use-cookie-file=s"      => \$use_cookie,
               "chunks=s",              => \$chunks,
               "continue-on-errors"     => \$continue,
	      ) or  pod2usage(2);

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

    if (!$use_cookie && $password eq '') {
        {
            $password = read_password('Password: ');
            redo unless $password;
        }
    }
}
our ($module, $command, %search, $with_related_stories, $with_related_media,
     $to_preview, $publish_date, $published_only, $username, $password, $server,
     $verbose, $desk, $workflow, $timeout, $use_cookie, $save_cookie, $chunks,
     $continue);

use SOAP::Lite ($verbose > 2 ? (trace => [qw(debug)]) : ()),
  on_fault => \&_handle_fault;
import SOAP::Data 'name';
use HTTP::Cookies;

# jump table for module commands
our %jump = (
    story => {
        class => 'Story',
    },
    media => {
        class => 'Media',
    },
    template => {
        class => 'Template',
    },
    element_type => {
        class => 'ElementType',
    },
    category => {
        class => 'Category',
    },
    media_type => {
        class => 'MediaType',
    },
    site => {
        class => 'Site',
    },
    keyword => {
        class => 'Keyword',
    },
    user => {
        class => 'User',
    },
    desk => {
        class => 'Desk',
    },
    workflow => {
        publish  => \&publish,
        deploy   => \&deploy,
        checkin  => \&checkin,
        checkout => \&checkout,
        move     => \&move,
        class    => 'Workflow',
    },
    element_type_set => {
        class => 'ATType',
    },
    output_channel => {
        class => 'OutputChannel',
    },
    contrib_type => {
        class => 'ContribType',
    },
    dest => {
        class => 'Destination',
    },
    pref => {
        class => 'Preference',
    },
);
foreach my $mod (keys %jump) {
    # Every module has "asset commands"
    $jump{$mod}{list_ids} = \&list_ids;
    $jump{$mod}{export}   = \&export;
    $jump{$mod}{create}   = \&create;
    $jump{$mod}{update}   = \&update;
    $jump{$mod}{delete}   = \&delete;
}

# get module and verify
$module = shift @ARGV;

# Just a bit of backwards compatibility.
$module = 'element_type' if $module eq 'element';

pod2usage("Missing required module and command parameters.")
    unless $module;
pod2usage("Unknown module \"$module\".")
    unless exists $jump{$module};

# get command and verify
$command = shift @ARGV;
pod2usage("Missing required command parameter.")
    unless $command;
$command = lc $command;
pod2usage("Unsupported $module command \"$command\".")
    unless exists $jump{$module}{$command};

# make sure we have what we need to login
my @options = $use_cookie ? ("server") : ("username","password","server");
foreach my $opt (@options) {
    no strict 'refs';
    pod2usage("Missing required $opt option.")
	unless $$opt;
}

# make sure chunking isn't requested for a non-chunk-supporting command
die "The --chunks option only works with the Workflow publish command.\n"
  if $chunks and $module ne 'workflow' and $command ne 'publish';

# make sure published-only option is only given for workflow publish
die "The --published-only option only works with the Workflow publish command.\n"
  if $published_only and $module ne 'workflow' and $command ne 'publish';

# setup soap object to login with
my $soap = new SOAP::Lite
    uri      => 'http://bricolage.sourceforge.net/Bric/SOAP/Auth',
    readable => $verbose > 2 || 0;
$server = "http://$server" unless $server =~ m!^https?://!;
my $cookie_string;

if  ($save_cookie) {
    $cookie_string = $save_cookie;
} elsif ($use_cookie) {
    $cookie_string = $use_cookie;
}

$soap->proxy($server . '/soap',
	     cookie_jar => HTTP::Cookies->new(ignore_discard => 1,
                                              file => $cookie_string,
                                              autosave=>1),
             timeout    => $timeout,
            );

# login
if (!$use_cookie) {
    print STDERR "$module $command: Authenticating to Bricolage...\n"
      if $verbose;
    my $response = $soap->login(name(username => $username),
                                name(password => $password));
    die "Login failed.\n" if $response->fault;
    print STDERR "$module $command: Login success.\n" if $verbose;
} else {
     print STDERR "$module $command: Attempting to use cookie file $use_cookie\n"
       if $verbose;
}

# switch to requested module
$soap->uri('http://bricolage.sourceforge.net/Bric/SOAP/' . $jump{$module}->{class});
print STDERR "$module $command: Switched to $module module.\n" if $verbose;

# execute command
$jump{$module}{$command}->();


#
# Command subroutines
#


sub list_ids {
    if ($verbose) {
        my $class = $jump{$module}->{class};
        print STDERR "$module $command: Calling Bric::SOAP::$class->$command ",
          "with search: (", join(', ', map { "$_ => $search{$_}" } keys %search), ")\n";
    }
    my $response = $soap->list_ids(map { name($_ => $search{$_}) }
                                   keys %search);
    my $list = $response->result;
    foreach (@$list) {
        print $module, "_", $_, "\n";
    }
}

sub export {
    # collect ids
    my @ids = _read_ids($module . "_id");

    my @opts;
    push @opts, name($module . '_ids', \@ids);
    push @opts, name(export_related_stories => 1) if $with_related_stories;
    push @opts, name(export_related_media   => 1) if $with_related_media;

    print $soap->export(@opts)->result;
}

sub delete {
    # collect ids
    my @ids = _read_ids($module . "_id");
    $soap->delete(name($module . '_ids', \@ids));
}

sub create {
    my @opts;
    push @opts, name(workflow => $workflow) if defined $workflow;
    push @opts, name(desk => $desk) if defined $desk;

    # work through documents
    foreach (@ARGV) {
	my $document;
	if ($_ eq '-') {
	    print STDERR "$module $command: Reading document from STDIN...\n"
		if $verbose;
	    $document = join('', <STDIN>);
	} else {
	    print STDERR "$module $command: Reading document \"$_\"...\n"
		if $verbose;
	    open(DOC, $_) or die "Unable to open document \"$_\" : $!\n";
	    $document = join('', <DOC>);
	    close(DOC);
	}

        if ($verbose) {
            my $class = $jump{$module}->{class};
            print STDERR "$module $command: Calling Bric::SOAP::$class->$command " .
              "with document:  ", length($document), " bytes\n";
        }

	# print out response ids
	_print_ids($soap->create(name(document => $document)->type('base64'), @opts));
    }
}



sub update {
    my @opts;
    push @opts, name(workflow => $workflow) if defined $workflow;
    push @opts, name(desk => $desk) if defined $desk;

    # work through documents
    foreach (@ARGV) {
	my $document;
	if ($_ eq '-') {
	    print STDERR "$module $command: Reading document from STDIN...\n"
		if $verbose;
	    $document = join('', <STDIN>);
	} else {
	    print STDERR "$module $command: Reading document \"$_\"...\n"
		if $verbose;
	    open(DOC, $_) or die "Unable to open document \"$_\" : $!\n";
	    $document = join('', <DOC>);
	    close(DOC);
	}

	my @update_ids = grep { /\d/ } $document =~ /<$module.*?id=(["'])(\d+)\1/g
        or die "No $module ids found in update document.\n";
        if ($verbose) {
            print STDERR "$module $command: Found ids for update: ",
              join(', ', @update_ids), "\n";

            my $class = $jump{$module}->{class};
            print STDERR "$module $command: Calling Bric::SOAP::$class->$command",
              " with document:  ", length($document), " bytes\n";
        }

	my $response = $soap->update(name(document =>
                                          $document)->type('base64'),
                                     name(update_ids =>
                                          [ map
                                            { name("$module\_id" => $_) }
                                            @update_ids ]),
                                     @opts);
	# print out ids
	_print_ids($response);
    }
}

sub publish {
    my @opts;
    push @opts, name(publish_related_stories  => 1) if $with_related_stories;
    push @opts, name(publish_related_media    => 1) if $with_related_media;
    push @opts, name(to_preview               => 1) if $to_preview;
    push @opts, name(publish_date => $publish_date) if $publish_date;
    push @opts, name(published_only           => 1) if $published_only;

    # publish by chunks
    _foreach_chunks {
        _print_ids($soap->publish(name(publish_ids => \@_), @opts));
    } (_read_ids());
}

sub deploy {
    # deploy by chunks
    _foreach_chunks {
        _print_ids($soap->deploy(name(deploy_ids => \@_)));
    } (_read_ids());
}

sub checkin {
    # checkin by chunks
    _foreach_chunks {
        _print_ids($soap->checkin(name(checkin_ids => \@_)));
    } (_read_ids());
}

sub checkout {
    # checkout by chunks
    _foreach_chunks {
        _print_ids($soap->checkout(name(checkout_ids => \@_)));
    } (_read_ids());
}

sub move {
    die "$module $command requires a desk option.\n"
	unless defined $desk;
    my @opts = (name(desk => $desk));
    push @opts, name(workflow => $workflow) if defined $workflow;

    # move by chunks
    _foreach_chunks {
        _print_ids($soap->move(name(move_ids => \@_), @opts));
    } (_read_ids());
}

#
# utility functions
#

# reads in ids off the command and/or STDIN if commandline contains
# "-".  Constructs SOAP::Data named objects defaulting to
# $default_type if not specified.
sub _read_ids {
  my ($default_type) = @_;
  my @ids;
  while (defined($_ = shift @ARGV)) {
      if ($_ eq '-') {
	  print STDERR "$module $command: Reading ids from STDIN...\n"
	      if $verbose;
	  push @ARGV, map { chomp; $_ } <STDIN>;
	  next;
      }

      # plain integers use default if available
      if (/^\d+$/) {
	  die "$module $command requires named ids ".
	      "(story_1024, for example).\n"
		  unless $default_type;
	  push @ids, name($default_type, $_);
      } elsif (/^([a-zA-Z_]+)_(\d+)$/) {
	  my ($name, $id) = ($1, $2);
	  push @ids, name(lc $name . "_id", $id);
      } else {
	  die "$module $command : found malformed id : \"$_\".\n";
      }
  }

  die "\nNo ids found for $module $command.\n".
    "(did you forget a '-' argument to read ids from STDIN?)\n"
      unless @ids;

  if ($verbose) {
      my $class = $jump{$module}->{class};
      print STDERR "$module $command: Calling $class->$command with ids: ",
        join(', ', map { $_->name . " => " . $_->value } @ids) , "\n";
  }

  return @ids;
}

# performs a given action in chunks increments
sub _foreach_chunks (&@) {
    my $code = shift;
    our $chunks;

    if ($chunks == 0) {
        $code->(@_);
    } else {
        # step through indexes $chunks at a time
        my ($start, $end);
        for ($start = 0; $start <= $#_; $start = $end + 1) {
            $end = $start + $chunks - 1;
            $end = $#_ if $end > $#_;
            $code->(@_[$start .. $end]);
	}
    }
}

# prints out ids from a SOAP response
sub _print_ids {
    my $response = shift;
    # print out ids with types
    my ($count, $data);
    for($count = 1; 
	$data = $response->dataof("/Envelope/Body/[1]/[1]/[$count]");
	$count++) {
	my $name = $data->name;
	$name =~ s/_id$//;
	print $name, "_", $data->value, "\n";
    }
}

# handle faults from SOAP::Lite's on_fault event
sub _handle_fault {
    my ($soap, $r) = @_;

    # print out the error as appropriate
    if (ref $r) {
        my $class = $jump{$module}->{class};
        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
            print STDERR "Call to Bric::SOAP::$class->$command failed:\n\n",
              join("\n", values %{$r->faultdetail}), $/, $/;
        } else {
            print STDERR "Call to Bric::SOAP::$class->$command failed:\n\n",
              $r->faultstring, $/, $/;
        }
        print STDERR "Check the Apache error log for more detail.\n";
    } else {
        print STDERR "TRANSPORT ERROR: ", $soap->transport->status, "\n";
        print STDERR "Check the Apache error log for more information.\n";
    }

    # exit unless continueing on errors
    exit 1 unless $continue;

    # return an empty object to keep things humming along
    return SOAP::SOM->new();
}