helpers/external_acl/delayer/ext_delayer_acl.pl.in

   1 #!@PERL@
   2 =pod
   3
   4 =head1 NAME
   5
   6 delayer - Squid external acl helper adding artificial delay to requests
   7
   8 =head1 SYNOPSIS
   9
  10 delayer [--help] [--debug] [--log file] [--wait msec]
  11
  12 =head1 OPTIONS
  13
  14 =over 8
  15
  16 =item B<--help> or B<-h>
  17
  18 Print help message to stdout
  19
  20 =item B<--debug> or B<-d>
  21
  22 Emit debugging output to STDERR and ultimately cache.log
  23
  24 =item B<--log /path/to/file> or B<-l /path/to/file>
  25
  26 Emit debugging output to specified file instead of STDERR. Also turns on debugging
  27
  28 =item B<--wait msec> or B<-w msec>
  29
  30 Delay each request by the specified amount of msec.
  31 Unless this option is specified, by default each submitted request
  32 will be delayed by half a second (500 msec).
  33
  34 =back
  35
  36 =head1 DESCRIPTION
  37
  38 Squid external acl helper; causes squid to delay responding to HTTP requests.
  39
  40 By carefully crafting the ACLs of a Squid setup it is possible to
  41 selectively delay requests received by a proxy. After the configured amount
  42 of time, it will always return "true".
  43
  44 =head1 CONFIGURATION
  45
  46 To engage it, this snippet of configuration template can be used in squid.conf:
  47
  48  external_acl_type delayer concurrency=100000 children-max=2 children-startup=1 children-idle=1 cache=10 %URI /path/to/delayer -w 200
  49  acl delay external delayer
  50  http_access allow acl1 acl2 acl3 delay !all
  51
  52 It is important that the acl referencing the delayer be the penultimate clause in the
  53 http_access line. It will cause delay to all requests that match all the
  54 preceding acls in the line. The !all clause at the end of the line will make it
  55 so that no traffic is authorized by this ACL, only the delay to evaluate
  56 the delay clause will be inserted before evaluating following http_access lines.
  57 It is also important to place the http_access line carefully in the sequence
  58 of all http_access_lines; it should be near the beginning, but be careful
  59 not to insert unwanted slow acls (especially proxy_auth).
  60
  61 It is possible to customize how delay is calculated for each request by
  62 modifying the "calc_delay" PERL function in the script, documentation on this
  63 is embedded in the source code comments.
  64
  65 =head1 AUTHOR
  66
  67 This software is written by Francesco Chemolli <kinkie@squid-cache.org>
  68
  69 =head1 COPYRIGHT
  70
  71 (C) 2014 Francesco Chemolli <kinkie@squid-cache.org>
  72
  73 This program is free software. You may redistribute copies of it under the
  74 terms of the GNU General Public License version 2, or (at your opinion) any
  75 later version.
  76
  77 =head1 QUESTIONS
  78
  79 Questions on this code are best addressed on the Squid-users mailing list
  80 <squid-users@squid-cache.org>
  81
  82 =head1 REPORTING BUGS
  83
  84 Bug reports need to be made in English.
  85 See http://wiki.squid-cache.org/SquidFaq/BugReporting for details of what you
  86 need to include with your bug report.
  87 Report bugs or bug fixes using http://bugs.squid-cache.org/
  88
  89 =head1 SEE ALSO
  90
  91 B<squid>(8), B<GPL>(7), B<Squid Wiki> http://wiki.squid-cache.org/ ,
  92 B<Squid Configuration Manual> http://www.squid-cache.org/Doc/config/
  93
  94 =cut
  95
  96 use strict;
  97 use warnings;
  98 use Getopt::Long qw(:config auto_version auto_help);
  99 use Data::Dumper;
 100 use Time::HiRes qw(gettimeofday tv_interval);
 101
 102 # options handling
 103 my %opts = (); #for getopt
 104 my $debug = 0; #debug
 105 my $logfile = *STDERR; #filehandle to logfile
 106 my $logfilename;
 107 my $delay = 500; #in milliseconds. Configurable with the -w option.
 108 #for custom delay algorithms, you can customize the dispatch_request function
 109
 110 #calculate the delay for the request.
 111 # Gets as input the verbatim full line received from squid
 112 # (channel number and all, as configured in squid.conf) and returns
 113 # a floating point number >= 0 which is the delay to be applied to the request
 114 # in seconds.
 115 # Notice that in order to have efficient data structures, the delay is
 116 # assumed to be monotonously growing. In other words, a long-delay
 117 # item will stall the queue until completed. Supporting generic delays
 118 # requires transforming @queue from a FIFO to a priority queue.
 119 sub calc_delay {
 120   return $delay;
 121 }
 122
 123 GetOptions("debug|d" => \$debug,
 124            "wait|w=i" => \$delay,
 125            "log|l=s" => \$logfilename)
 126 or die("Error in parsing command line arguments");
 127 if (defined $opts{h}) {
 128   HELP_MESSAGE();
 129   exit 0;
 130 }
 131 $delay /= 1000.0; # transform msec into sec
 132 if ($logfilename) {
 133   open ($logfile,">>", "$opts{l}");
 134   $debug=1;
 135 }
 136
 137 my @p=split(/[\\\/]/,$0);
 138 my $prg_basename=pop @p;
 139 $prg_basename .= "[$$]";
 140 undef @p;
 141 my $reqid=0; #sequence number for requests
 142
 143 # variables initialization for select
 144 my $rvec = '';
 145 vec($rvec,0,1) = 1; #stdin
 146 my ($nfound, $rd, $nread, $req);
 147
 148 #requests queue
 149 my @queue = (); # array of references to hashes, with keys chan, when, req, reqid
 150
 151 # signal handlers
 152 $SIG{HUP} = \&dump_state;
 153
 154 #disable IO buffering
 155 $| = 1;
 156 my $fh=select($logfile); $|=1; select($fh); undef($fh);
 157
 158 # takes a result from a gettimeofday call and turns it into a
 159 # floating-point number suitable for approximate time calculations and select
 160 sub fract_time {
 161   return $_[0]+$_[1]/1000000;
 162 }
 163
 164 sub dispatch_request {
 165   my $r = $_[0];
 166   chomp $r;
 167   &debug("got request: '$r'");
 168   my %evt = ();
 169   my @fields;
 170   @fields = split (/\s+/, $r);
 171   $evt{when} = &calc_delay($r)+fract_time(gettimeofday());
 172   $evt{reqid}=$reqid++;
 173   $evt{req} = $r;
 174   $evt{chan} = $fields[0];
 175   &debug("Dispatching: reqid $evt{reqid}, chan $evt{chan}, when $evt{when}, raw {$evt{req}}");
 176   push @queue,\%evt;
 177 }
 178
 179 sub next_event {
 180   my $now = fract_time(gettimeofday());
 181   if (@queue) {
 182     my $when = $queue[0]->{when} - $now;
 183     &debug("Next event is in $when seconds");
 184     return $when;
 185   }
 186   &debug("No events in queue");
 187   return undef;
 188 }
 189
 190 sub handle_events {
 191   my $now = fract_time(gettimeofday());
 192   while ( @queue ) {
 193     &debug("Queue length is $#queue");
 194     last if ($queue[0]->{when} > $now);
 195     my %evt = %{shift @queue};
 196     &debug("Event: reqid $evt{reqid}, chan $evt{chan}, when $evt{when}, raw {$evt{req}}");
 197     print $evt{chan} , " OK\n";
 198   }
 199 }
 200
 201 # main loop
 202 while(1) {
 203   &debug("selecting");
 204   $nfound = select($rd = $rvec,undef,undef,&next_event());
 205   &debug("found $nfound bits set");
 206   if ($nfound == -1 ) {
 207     next if ($!{ERESTART} || $!{EAGAIN} || $!{EINTR});
 208     &debug("error in select: $!");
 209     exit 1;
 210   }
 211   if (vec($rd,0,1)==1) { #got stuff from stdin
 212     my $d; #data
 213     $nread = sysread(STDIN,$d,40960); # read 40kb
 214     # clear the signal-bit, stdin is special
 215     vec($rd,0,1) = 0;
 216     if ($nread==0) {
 217       &debug("nothing read from stdin, exiting");
 218       exit 0;
 219     }
 220     my $i;
 221     while ($i = index($d,"\n")) { #BUG: assumption of no spill-over
 222       last if ($i == -1);
 223       &dispatch_request(substr($d,0,$i));
 224       $d=substr($d,$i+1);
 225     }
 226   }
 227   &handle_events();
 228 }
 229
 230 my $doc = <<_EOF;
 231 delay-adding external acl helper
 232 authorizes all requests, adding a delay before doing so.
 233 supports multiplexed helper protocol.
 234 Options:
 235   -h, --help: this help message
 236   -d, --debug: enable debug output
 237   -l <file>, --log <file>: log output to named file instead of stderr (implies debug)
 238   -w <num>, --wait <num> delay each request by this number milliseconds
 239
 240 AUTHOR: Francesco Chemolli <kinkie\@squid-cache.org>
 241 Licensed under the terms of the GNU GPL v2 or later (see source for details)
 242 _EOF
 243 our $VERSION = "1.0";
 244
 245 sub HELP_MESSAGE {
 246   print STDERR $doc;
 247 }
 248
 249 sub dump_state {
 250   $SIG{HUP} = \&dump_state;
 251   print STDERR "Queue:\n",Dumper(\@queue),"\n";
 252 }
 253
 254 sub debug {
 255   return unless ($debug);
 256   print $logfile $prg_basename , ": ", @_, "\n";
 257 }