shift.cgi

   1 #!/usr/bin/perl -w
   2 #!/usr/bin/perl -Tw
   3 # (Text::Template can't do -T, but no user input is used dangerously)
   4 #
   5 # $Id: shift.cgi,v 1.6 2003-07-30 22:16:36 ivan Exp $
   6 #
   7 # Copyright (C) 2000 Adam Gould
   8 # Copyright (C) 2000 Michal Migurski
   9 # Copyright (C) 2000 Ivan Kohler
  10 # All rights reserved.
  11 #
  12 # This program is free software; you can redistribute it and/or modify it under
  13 # the same terms as Perl itself.
  14
  15 ###
  16 # user-servicable parts
  17 ###
  18
  19 $template_file = '/var/www/www.420.am/staff/table.html';
  20 $data_directory = '/var/www/www.420.am/staff/data';
  21 #$mail_smtpserver = 'localhost'; # set blank to disable
  22 $mail_smtpserver = ''; # set blank to disable
  23 $mail_from = 'ivan-misconfigured-shift-from@420.am';
  24 $mail_subject = 'Your shift has been replaced';
  25 @mail_cc = (
  26   'ivan-misconfigured-shift-cc@420.am',
  27   'ivan-misconfigured-shift-cc2@420.am'
  28 );
  29 $mail_footer = <<END;
  30
  31 Sorry, I don't have any more information.  The person who installed the
  32 staff sheet didn't customize this message.
  33
  34 END
  35
  36 ###
  37 # end of user-servicable parts
  38 ###
  39
  40 use strict;
  41 use vars qw( $template_file $data_directory $mail_smtpserver $mail_from
  42              $mail_subject @mail_cc $mail_footer
  43              $cgi $template %shifthash %warning @messages $magic );
  44 use subs qw( form inputbox );
  45 use Fcntl ":flock";
  46 use CGI 2.15;
  47 use CGI::Carp qw(fatalsToBrowser);
  48 use Text::Template;
  49 use Mail::Internet;
  50 use Mail::Header;
  51 use Date::Format;
  52 use HTML::Entities;
  53
  54 $cgi = new CGI;
  55
  56 $template = new Text::Template (
  57   TYPE   => 'FILE',
  58   SOURCE => $template_file,
  59 ) or die "Can't create template for $template_file: $Text::Template::ERROR";
  60
  61 # fill in new data if provided
  62 %warning = ();
  63 @messages = ();
  64 if ( $cgi->param() ) {
  65
  66   # kludge - grep for inputbox("field") in template to find valid form fields
  67   # (DON'T get them from form submission - that's insecure!)
  68   open (TEMPLATE_FILE,"<$template_file")
  69     or die "Can't open template for $template_file: $!";
  70   my @form_fields =
  71     map { /inputbox\s*\(\s*([\'\"])(.*)\1\s*\)/; $2 }
  72       #grep { /inputbox\s*\(\s*([\'\"])(.*)\1\s*\)/ }
  73       grep { /inputbox\s*\(\s*([\'\"])(.*)\1\s*\);?\s*\}/ }
  74         <TEMPLATE_FILE>;
  75   close TEMPLATE_FILE;
  76
  77   #changed fields
  78   #foreach $_ ( @form_fields ) {
  79   #  warn "${_}_old undefined!" unless defined $cgi->param($_. '_old');
  80   #  warn "${_}_new undefined!" unless defined $cgi->param($_. '_new');
  81   #}
  82   my @diff_fields =
  83     grep { $cgi->param($_. '_old') ne $cgi->param($_. '_new') } @form_fields;
  84
  85   if ( @diff_fields ) {
  86
  87     local $SIG{HUP} = 'IGNORE';
  88     local $SIG{INT} = 'IGNORE';
  89     local $SIG{QUIT} = 'IGNORE';
  90     local $SIG{TERM} = 'IGNORE';
  91     local $SIG{TSTP} = 'IGNORE';
  92     local $SIG{PIPE} = 'IGNORE';
  93
  94     #open(LOCKFILE,">>$data_directory/.lock")
  95     open(LOCKFILE,"+<$data_directory/.lock")
  96       or open(LOCKFILE,">>$data_directory/.lock")
  97       or die "Can't open $data_directory/.lock: $!";
  98     flock(LOCKFILE,LOCK_EX); #blocks until we have the lock
  99     seek(LOCKFILE, 0, 0);
 100     print LOCKFILE "$$     \n"; #superfluous
 101
 102     get_data();
 103
 104     foreach my $field ( @diff_fields ) {
 105       $shifthash{$field}='' unless defined $shifthash{$field};
 106       if ( $shifthash{$field} eq $cgi->param($field. '_old') ) {
 107       if ( $cgi->param($field. "_new") =~
 108              /^\s*(\w[\w\s\.\'\-]{0,99}<?\s{0,9}(\w[\w\-\.\+]{0,99}\@(([\w\.\-]{1,99}\.){1,99}\w{1,99}))\s{0,9}>?)\s*$/
 109            || $cgi->param($field. "_new") =~ /^\s*()$/
 110         ) {
 111           my $new = $1;
 112           open(FILE,">$data_directory/.new.$field")
 113             or die "Can't open file $data_directory/$field: $!";
 114           print FILE $new;
 115           close FILE;
 116           rename "$data_directory/.new.$field", "$data_directory/$field";
 117           $warning{$field} = '';
 118           if (
 119             $mail_smtpserver
 120             && $shifthash{$field} =~ /\b(\w[\w\-\.\+]*\@(([\w\.\-]+\.)+\w+))\b/
 121           ) {
 122             my $to = $1;
 123             my $header = Mail::Header->new( [
 124               "From: $mail_from",
 125               "To: $to",
 126               "Cc: ". join(", ", @mail_cc),
 127               "Sender: $mail_from",
 128               "Reply-To: $mail_from",
 129               "Date: ". time2str("%a, %d %b %Y %X %z", time),
 130               "Subject: $mail_subject",
 131             ] );
 132             my $msg = Mail::Internet->new(
 133               'Header' => $header,
 134               'Body'   => [ map "$_\n",
 135                 "Hi,",
 136                 "",
 137                 "The \"$field\" shift you signed up for has been changed to",
 138                 '"'. $new. '"',
 139                 "",
 140                 split("\n", $mail_footer),
 141               ],
 142             );
 143             #send later - don't want to block on smtp while we have the lock
 144             push @messages, $msg;
 145           }
 146         } else {
 147           $warning{$field} =
 148             "WARNING: you tried to sign up for <B>$field</B>, but your entry ".
 149             "<B>\"". $cgi->param($field. '_new').
 150             "</B>\" does not contain a valid email address."
 151           ;
 152         }
 153       } elsif ( $shifthash{$field} eq $cgi->param($field. '_new') ) {
 154         #somebody else made the same change (or you hit reload); no need to warn
 155         $warning{$field} = '';
 156       } else {
 157         $warning{$field} =
 158           "WARNING: you tried to change <B>$field</B> from \"<B>".
 159           $cgi->param($field. '_old').
 160           "</B>\" to \"<B>".
 161           $cgi->param($field. "_new").
 162           "</B>\", but in the meantime someone changed it to: "
 163         ;
 164       }
 165     }
 166
 167     flock(LOCKFILE,LOCK_UN);
 168     close LOCKFILE;
 169
 170   }
 171
 172 }
 173
 174 get_data();
 175
 176 my $text = $template->fill_in()
 177   or die "Can't fill in template for $template_file: $Text::Template::ERROR";
 178
 179 print $cgi->header, $text;
 180
 181 $ENV{SMTPHOSTS} = $mail_smtpserver;
 182 $ENV{MAILADDRESS} = $mail_from;
 183 foreach my $msg ( @messages ) {
 184   $msg->smtpsend;
 185 }
 186
 187 # subroutines
 188
 189 sub get_data {
 190   opendir DATA_DIR, $data_directory
 191     or die "Can't open directory $data_directory: $!";
 192   %shifthash = map {
 193     open(FILE, "<$data_directory/$_")
 194       or die "Can't open file $data_directory/$_: $!";
 195     my $value = scalar(<FILE>) || '';
 196     close FILE;
 197     chomp $value;
 198     ( $_ => $value );
 199   } grep { ! /^\.{1,2}(lock)?$/ } readdir(DATA_DIR);
 200   closedir DATA_DIR;
 201 }
 202
 203 # subroutines for the template
 204
 205 sub form {
 206  $magic = defined $cgi->param('__MAGIC') ? $cgi->param('__MAGIC') : '';
 207  $cgi->delete_all();
 208  $cgi->start_form();
 209 }
 210
 211 sub inputbox {
 212   my $field = shift;
 213   return encode_entities($shifthash{$field}) || "&nbsp;"
 214     if $magic eq 'print';
 215   $shifthash{$field}='' unless defined $shifthash{$field};
 216   $warning{$field}='' unless defined $warning{$field};
 217   #"$field ".
 218   $cgi->hidden(
 219     -name    => $field. '_old',
 220     -default => $shifthash{$field},
 221     -force   => 1,
 222   ).
 223   $warning{$field}.
 224   $cgi->textfield(
 225     -name    => $field. '_new',
 226     -default => $shifthash{$field},
 227     -force   => 1,
 228     -size    => 15,
 229   );
 230 }
 231
 232 sub warnings {
 233   join "<BR>", map {
 234     "$warning{$_}<b>$shifthash{$_}</b>"
 235   } grep {
 236     $warning{$_}
 237   } keys %warning;
 238 }
 239