lib/Promulger/List.pm

   1 package Promulger::List;
   2 use Moo;
   3 use autodie;
   4
   5 use autodie ':all';
   6 use Carp;
   7 use Path::Class;
   8 use Fcntl ':flock';
   9 use Tie::File;
  10 use File::Slurp qw/read_file write_file/;
  11 use Data::Dumper;
  12 use Try::Tiny;
  13 use FindBin qw($Bin);
  14 $Data::Dumper::Purity = 1;
  15
  16 use Promulger::Config;
  17
  18 has listname => (
  19   is       => 'ro',
  20   isa      => sub { $_[0] =~ /^\w+$/ or die "listname must be a string" },
  21   required => 1,
  22 );
  23
  24 has active => (
  25   is       => 'rw',
  26   isa      => sub { ($_[0] == 0 || $_[0] == 1) or die "active must be 0 or 1" },
  27   required => 1,
  28   default  => sub { 1 },
  29 );
  30
  31 has subscribers => (
  32   is       => 'rw',
  33   isa      => sub { ref $_[0] eq 'HASH' or die "subscribers must be a hashref" },
  34   required => 1,
  35   default  => sub { {} },
  36 );
  37
  38 sub resolve {
  39   my ($self, $proto) = @_;
  40   $proto =~ s/-request$//;
  41   $proto =~ s/^owner-//;
  42   my $path = find_path_for($proto);
  43   my $maybe_list;
  44   try {
  45     $maybe_list = __PACKAGE__->load($path->stringify);
  46   } catch {
  47     die "oh noes: $_";
  48   };
  49   return $maybe_list;
  50 }
  51
  52 sub subscribe {
  53   my ($self, $new) = @_;
  54   return if $self->subscribers->{$new};
  55   $self->subscribers->{$new} = 1;
  56   $self->store(find_path_for($self->listname)->stringify);
  57   return 1;
  58 }
  59
  60 sub unsubscribe {
  61   my ($self, $ex) = @_;
  62   return unless exists $self->subscribers->{$ex};
  63   delete $self->subscribers->{$ex};
  64   $self->store(find_path_for($self->listname)->stringify);
  65   return 1;
  66 }
  67
  68 # XXX implement ACLs and other shinies -- apeiron, 2010-03-13
  69 sub accept_posts_from {
  70   my ($self, $sender) = @_;
  71   return grep { $sender eq $_ } keys %{$self->subscribers};
  72 }
  73
  74 sub setup {
  75   my ($self) = @_;
  76   my $config = Promulger::Config->config;
  77   my $name = $self->listname;
  78   croak "${name} already a known list" if $self->resolve($name);
  79   my $path = find_path_for($name);
  80
  81   my $tie = tie my @aliases, 'Tie::File', $config->{aliases}
  82     or die "cannot tie " . $config->{aliases} . ": $!";
  83   $tie->flock;
  84   my @list_aliases = ($name, "${name}-request");
  85
  86   # XXX add a flag to determine whether to write the aliases file or no
  87   # -- apeiron, 2012-07-18
  88   for my $list_alias (@list_aliases) {
  89     if(grep { /^${list_alias}:/ } @aliases) {
  90       croak "${list_alias} already in $config->{aliases}";
  91     }
  92     push @aliases,
  93       qq(${list_alias}: "|$Bin msg -c $config->{config_file}"\n),
  94       qq(${list_alias}-owner: "|$Bin msgbounce -c $config->{config_file}"\n);
  95   }
  96
  97   $self->store($path->stringify);
  98 }
  99
 100 sub delete {
 101   my ($self) = @_;
 102   my $config = Promulger::Config->config;
 103   my $name = $self->listname;
 104
 105   my $tie = tie my @aliases, 'Tie::File', $config->{aliases};
 106   $tie->flock;
 107
 108   my @list_aliases = ($name, "${name}-request");
 109   @aliases = grep {
 110     $_ !~ /^$list_aliases[0]:/ &&
 111     $_ !~ /^$list_aliases[1]:/
 112   } @aliases;
 113
 114   unlink find_path_for($self->listname)->stringify;
 115 }
 116
 117 sub find_path_for {
 118   my ($proto) = @_;
 119   my $path = file(Promulger::Config->config->{list_home}, $proto . ".list");
 120   return $path;
 121 }
 122
 123 sub store {
 124   my ($self, $path) = @_;
 125   my $dumped = 'do { my '. Dumper($self) . '; $VAR1; }';
 126   write_file($path, $dumped);
 127 }
 128
 129 sub load {
 130   my ($class, $path) = @_;
 131   return do $path;
 132 }
 133
 134 sub get_lists {
 135   my ($self) = @_;
 136   my $config = Promulger::Config->config;
 137   my @lists = map { $_->basename}
 138               grep { -f } dir($config->{list_home})->children;
 139   s/\.list//g for @lists;
 140   return @lists;
 141 }
 142
 143 'http://mitpress.mit.edu/sicp/';