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     or die "cannot tie " . $config->{aliases} . ": $!";
  81   $tie->flock;
  82   my @list_aliases = ($name, "${name}-request");
  83
  84   for my $list_alias (@list_aliases) {
  85     if(grep { /^${list_alias}:/ } @aliases) {
  86       croak "${list_alias} already in $config->{aliases}";
  87     }
  88     push @aliases,
  89       qq(${list_alias}: "|$Bin msg -c $config->{config_file}"\n);
  90   }
  91
  92   $self->store($path->stringify);
  93 }
  94
  95 sub delete {
  96   my ($self) = @_;
  97   my $config = Promulger::Config->config;
  98   my $name = $self->listname;
  99
 100   my $tie = tie my @aliases, 'Tie::File', $config->{aliases};
 101   $tie->flock;
 102
 103   my @list_aliases = ($name, "${name}-request");
 104   @aliases = grep {
 105     $_ !~ /^$list_aliases[0]:/ &&
 106     $_ !~ /^$list_aliases[1]:/
 107   } @aliases;
 108
 109   unlink find_path_for($self->listname)->stringify;
 110 }
 111
 112 sub find_path_for {
 113   my ($proto) = @_;
 114   my $path = file(Promulger::Config->config->{list_home}, $proto . ".list");
 115   return $path;
 116 }
 117
 118 sub store {
 119   my ($self, $path) = @_;
 120   my $dumped = 'do { my '. Dumper($self) . '; $VAR1; }';
 121   write_file($path, $dumped);
 122 }
 123
 124 sub load {
 125   my ($class, $path) = @_;
 126   return do $path;
 127 }
 128
 129 sub get_lists {
 130   my ($self) = @_;
 131   my $config = Promulger::Config->config;
 132   my @lists = map { $_->basename}
 133               grep { -f } dir($config->{list_home})->children;
 134   s/\.list//g for @lists;
 135   return @lists;
 136 }
 137
 138 'http://mitpress.mit.edu/sicp/';