lib/Promulger/List.pm

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