#!/usr/bin/env perl
#
# mailmanage - reconfigure Mailman mailing lists
#
# $Id$

use warnings;
use strict;

use Getopt::Std;
use LWP::Simple;
use WWW::Mailman;
use JSON;

my %opt;
getopts( 'ah?l:mp:s:t:u:v', \%opt )
 or oomph('error parsing the command line, try -h for help');

my ($me) = $0 =~ m#([^/\\]+)$#;

my $default_server = 'listserver.tue.nl';

HELP_MESSAGE() if grep { /^[h?]/ } keys %opt;

sub HELP_MESSAGE
{
  print STDERR <<ZZ;

Usage:

  $me [-s server] [-m | -u user] [-p password] [-t sep] [-v] [-a] -l list [setting [setting2 [...]]]

to show settings, or a setting, or change a setting,
for the specified Mailman mailing list,
or list the subscribers, or download the archive into a single mbox.

Arguments:

   setting setting2 ...

     A whitespace-separated list of setting specifications;
     each setting specification is the name of a setting,
     optionally followed by an equals sign and a value, e.g.

       real_name
       real_name=OPENCOSS
       default_member_moderation=0

If no setting is specified, print the list of settings and their values
in JSON format, grouped by the 'section' (form) they are in.

Note that this is a mixture of read-write, read-only,
and write-only settings, and that when setting a setting, you only
need to specify its name, not the section it is in.

If at least one setting is specified, for each setting:

  if it is just an setting name, print the name and value as a JSON pair;
  if it also specifies a value, attempt to set the setting to the value.

Order is insignificant: a request to set a setting is always executed
before a request to show its value.

Abort on failure (e.g. when a nonexistent setting is specified).

Options:

  -l list(s)

     The name(s) of the mailing list(s, separated by a comma).
     This option is required!

  -s server

    The hostname of the mailman server, with optionally

      - the protocol prefix
      - the path to the Mailman installation.

    For instance:

      listserver.example.org
      listserver.example.org/mailman
      https://lists.sourceforge.net/lists

    However, the last example doesn't work because the underlying
    library requires the presence of a 'mailman' component in the path.

    Defaults to the value of \$MAILMAN_SERVER, or $default_server.

  -a

    Output the complete archive of messages in mbox format
    (if it can be pieced together from links on the archives page).

  -m

    Print the list of members (subscribers).
    Cannot be used together with -u.

  -u user

    When specified, act on the subscription settings for this user.
    Defaults to the value of \$MAILMAN_USER, if set.

    If not specified, act on the configuration settings for the list.
    Note that these are completely different.

    The value must be an email address.  For instance:

      jdoe\@example.com

  -p password

    The list moderator's password.
    Defaults to the value of \$MAILMAN_PASSWORD.

  -t sep

    Some options have newline-separated values;
    this option lets you specify an alternative separator.

  -v

    Verbose: print some information on what is going on.

ZZ
  exit(0);
}

sub oops
{
  warn join( ' ', "$me:", @_ ), "\n";
}

sub oomph
{
  oops(@_);
  die "$me: aborting - try $me -h for help\n";
}

sub ehm
{
  $opt{v} and oops(@_);
}

$opt{u} && $opt{m}
 and oomph('-m and -u do not go together, try -h for help');

$opt{a} && $opt{m}
 and oomph('-a and -m do not go together, try -h for help');

my @lists = grep { /\S/ } split( /,/, ( $opt{l} // $ENV{MAILMAN_LISTS} // '' ) )
 or oomph('supply a list name with -l, or try -h for help');

$opt{a} && @ARGV
 and oomph('-a does not take any settings, try -h for help');

$opt{m} && @ARGV
 and oomph('-m does not take any settings, try -h for help');

# quick hack - loses the order!
my %settings_with_values =
 map { my @p = split /=/; @p == 2 ? @p : ( @p, undef ) } grep { /=/ } @ARGV;
# (support undef values)
my @settings_wo_values = grep { !/=/ } @ARGV;

if ( $opt{t} )
{
  # (replace separator in values)
  s/$opt{t}/\n/g for values(%settings_with_values);
}

my $server = $opt{s} // $ENV{MAILMAN_SERVER} // $default_server;
$server =~ s#/+$##;

my $hostpart = $server;

if ( $hostpart !~ m#^\w+://# )
{
  $hostpart = 'https://' . $server;
}

if ( $hostpart !~ m#/# )
{
  $hostpart .= '/mailman';
}

sub returns_content
{
  # a LWP::Simple->head() must return content
  grep { defined && $_ gt 0 } head( $_[0] );
}

returns_content($hostpart)
 or $hostpart =~ s#^https:#http:#;

returns_content($hostpart)
 or oomph('cannot read main page from server');

($server) = $hostpart =~ m#.*//([^/]+)#;
$server
 or oomph('cannot determine the server, seems empty');
( $server !~ m#/# && $server =~ /\./ )
 or oomph( 'cannot determine the server, this seems wrong:', $server );

my $email    = $opt{u} // $ENV{MAILMAN_USER};
my $password = $opt{p} // $ENV{MAILMAN_PASSWORD};

foreach my $list (@lists)
{
  main($list);
}

exit(0);

sub main
{
  my ($list) = @_;

  my $mm = WWW::Mailman->new(
    uri         => "$hostpart/listinfo/$list",
    cookie_file => "$ENV{HOME}/.mailmanrc"
  ) or oomph("cannot create Mailman interface to $hostpart");

  my $mech = $mm->robot;

  $mm->moderator_password($password) if defined $password;
  my $uri = $mm->uri();

  if ( !successful_response( eval { $mech->get($uri) } ) )
  {
    my $prev_uri = $uri;
    $uri =~ s#mailman/##;
    successful_response( eval { $mech->get($uri) } )
     or oomph("cannot connect to Mailman interface at $uri or $prev_uri");
  }
  # will *succeed* for nonexistent lists on an existing Mailman installation

  ehm( 'on listinfo page:', $mm->uri() );

  #my $address = sprintf( '%s@%s', $list, $server );
  #ehm("looking for link to $address");
  #$mech->find_link( text => $address, url => 'mailto:' . $address )
  # not good enough for nl-pm@amsterdam.pm.org
  $mech->find_link( text_regex => qr/^$list\@/, url => qr/^mailto:$list\@/ )
   or oomph( 'listinfo page not recognized, list may not exist:', $list );

  if ( defined $opt{a} )
  {
    # try to follow the link to the archives
    my @archive_links =
     grep { $_->text =~ /archives/i && $_->text !~ /searchable/i }
     $mech->links()
     or oomph('cannot find or follow link to mailing list archive page');

    successful_response( $mech->get( shift(@archive_links) ) )
     or oomph('cannot find or follow link to mailing list archive page');

    #ehm('on archive page:', $mm->uri());
    # still produces the listinfo URL
    ehm( 'on archive page:', $mech->uri() );

    # do we need to log in?

    if ( my $form = $mech->current_form() )
    {
      if (
        $form->action() eq $mech->uri()    # acts to the current URL
        && $form->find_input('^username')
        && $form->find_input('^password')
       )
      {
        # looks like the login form
        defined($email) && defined($password)
         or oomph('supply a username and password, use -h to find out how');
        $mech->set_fields( 'username' => $email, 'password' => $password );
        successful_response( $mech->submit() )
         or oomph('did not manage to log in to the mailing list archive');
      }
    }

    my $total_length;

    binmode( STDOUT, ':utf8' );
    # guessing; seems to work for prom-users, which, without this,
    # causes 'Wide character in print' warnings

    if ( my @links = grep { $_->url() =~ /(\.txt)$/ } $mech->links() )
    {
      # assume these are links to ungzipped full message archives
      ehm( 'outputting', scalar(@links), 'mboxes' );

      foreach my $link ( reverse @links )
      {
        if ( successful_response( eval { $mech->get( $link->url() ) } ) )
        {
          my $text = $mech->content;
          $total_length += length($text);
          print $text;
        }
      }
    }

    if (
      my @links =
      grep { $_->url() =~ /(\.gz|downloadmbox)$/ } $mech->links()
     )
    {
      # assume these are links to gzipped full message archives;
      # this will also cover the SMART Archiver's interface on listserver.tue.nl
      # which offers a 'Download this overview as one gzipped mbox' link
      # (which always produces a gzipped empty document, unfortunately)
      # and the per-month gzipped archives as offered on e.g.
      # the Mailman-Users archives
      #   (at https://mail.python.org/pipermail/mailman-users/)
      # and the freeciv-dev archives
      #   (at https://mail.gna.org/public/freeciv-dev/)

      ehm( 'gunzipping and outputting', scalar(@links), 'mboxes' );

      eval { require IO::Uncompress::Gunzip }
       or oomph('whoops, -a is broken: cannot load IO::Uncompress::Gunzip');

      foreach my $link ( reverse @links )
      {
        if ( successful_response( eval { $mech->get( $link->url() ) } ) )
        {
          my $gzipped = $mech->content;
          my $gunzipped;
          IO::Uncompress::Gunzip::gunzip( \$gzipped, \$gunzipped );
          $total_length += length($gunzipped);
          print $gunzipped;
        }
      }
    }

    if ($total_length)
    {
      # yiha, we found an archive
    }
    elsif ( $mech->content =~ /archives\s+are\s+currently\s+empty/ )
    {
      oops('warning: message archive claimed to be empty on the archives page');
    }
    else
    {
      oops('warning: no message archive(s) found on the archives page');
    }

    exit(0);
  }

  if ( defined $opt{m} )
  {
    ehm('printing list of subscribers');
    print map { "$_\n" } $mm->roster();
    exit(0);
  }

  if ( defined $email )
  {
    $mm->email($email);

    ehm("processing settings for subscriber $email for list $list ...");

    my %result = (
      'address' => process_section( 'address', sub { $mm->address(@_) } ),
      #'changepw' => process_section( 'changepw', sub { $mm->changepw(@_) } ),
      #'options' =>  process_section( 'options',  sub { $mm->options(@_) } ),
      #'unsub' =>  process_section( 'unsub',  sub { $mm->unsub(@_) } )
    );
    # this isn't quite right yet: each section contains *all* sessings!

    if ( !@ARGV )
    {
      print_as_json( \%result );
    }
  }
  else
  {
    ehm("processing settings for admin for list $list ...");
    my @sections =
     qw( general passwords language nondigest digest bounce archive gateway autoreply contentfilter topics members/list members/add members/remove nondigest privacy/subscribing privacy/sender privacy/recipient privacy/spam );
    #my @sections = qw( members/list );
    #my @sections = qw( privacy/sender );

    my %result = map {
      $_ => process_section( $_, sub { $mm->admin( $_, @_ ) } )
    } @sections;

    if ( !@ARGV )
    {
      print_as_json( \%result );
    }
  }
}

sub successful_response
{
  my ($response) = @_;
  defined($response) && $response->is_success;
}

sub process_section
{
  my ( $section, $accessor ) = @_;

  ehm("processing settings in section $section ...");

  if ( !@ARGV )
  {
    # return all settings
    return &$accessor();
  }

  # we must show or set the settings

  # attempt to set the ones with values that exist in this section
  if (%settings_with_values)
  {
    my $existing_settings = &$accessor();

    if (
      my @to_set =
      grep { exists $existing_settings->{$_} } keys %settings_with_values
     )
    {
      # set them in one POST!  (this doesn't appear to work ...)
      @to_set = sort keys %settings_with_values;
      ehm( 'setting:', $_, 'to:', $settings_with_values{$_} ) for @to_set;
      &$accessor( { map { $_ => $settings_with_values{$_} } @to_set } );
    }
  }

  # show the ones without values that exist in this section
  if (@settings_wo_values)
  {
    my $existing_settings = &$accessor();

    if (
      my @to_show =
      grep { exists $existing_settings->{$_} } @settings_wo_values
     )
    {
      ehm( 'showing:', @to_show );
      print_as_json(
        { $section => { map { $_ => $existing_settings->{$_} } @to_show } } );
    }
  }
}

sub print_as_json
{
  my $struct = $opt{t} ? using_separator( $_[0] ) : $_[0];
  print to_json( $struct, { utf8 => 1, pretty => 1 } );
}

sub using_separator
{
  my $value = $_[0];
  my $ref   = ref($value);

  if ( $ref eq 'ARRAY' )
  {
    [ map { using_separator($_) } @$value ];
  }
  elsif ( $ref eq 'HASH' )
  {
    my %result =
     map { using_separator($_) => using_separator( $value->{$_} ) }
     keys %$value;
    \%result;
  }
  elsif ( $ref eq '' )
  {
    $value =~ s/\n/$opt{t}/g;
    $value;
  }
  else
  {
    oomph("don't know how to substitute separator in $value");
  }
}