#!/usr/bin/perl

use strict;
use warnings;
use Getopt::Long qw(:config auto_version auto_help);
use Pod::Usage;

=pod

=head1 NAME

 delayer - Squid external ACL helper adding artificial delay to requests

=head1 SYNOPSIS

 delayer [--help] [--debug] [--log file] [--wait msec]

=head1 DESCRIPTION

Squid external acl helper; causes squid to delay responding to HTTP requests.

By carefully crafting the ACLs of a Squid setup it is possible to
selectively delay requests received by a proxy. After the configured amount
of time, it will always return "true".

=head1 OPTIONS

=over 12

=item B<--help> or B<-h>

Print help message to stdout

=item B<--debug> or B<-d>

Emit debugging output to STDERR and ultimately cache.log

=item B<--log /path/to/file> or B<-l /path/to/file>

Emit debugging output to specified file instead of STDERR. Also turns on debugging

=item B<--wait msec> or B<-w msec>

Delay each request by the specified amount of msec.
Unless this option is specified, by default each submitted request
will be delayed by half a second (500 msec).

=back

=head1 CONFIGURATION

To engage it, this snippet of configuration template can be used in squid.conf:

 external_acl_type delayer concurrency=100000 children-max=2 children-startup=1 children-idle=1 cache=10 %URI /path/to/delayer -w 200
 acl delay external delayer
 http_access allow acl1 acl2 acl3 delay !all

It is important that the acl referencing the delayer be the penultimate clause in the
http_access line. It will cause delay to all requests that match all the
preceding acls in the line. The !all clause at the end of the line will make it
so that no traffic is authorized by this ACL, only the delay to evaluate
the delay clause will be inserted before evaluating following http_access lines.
It is also important to place the http_access line carefully in the sequence
of all http_access_lines; it should be near the beginning, but be careful
not to insert unwanted slow acls (especially proxy_auth).

It is possible to customize how delay is calculated for each request by
modifying the "calc_delay" PERL function in the script, documentation on this
is embedded in the source code comments.

=head1 AUTHOR

This software is written by Francesco Chemolli <kinkie@squid-cache.org>

=head1 COPYRIGHT

 * Copyright (C) 1996-2023 The Squid Software Foundation and contributors
 *
 * Squid software is distributed under GPLv2+ license and includes
 * contributions from numerous individuals and organizations.
 * Please see the COPYING and CONTRIBUTORS files for details.

 (C) 2014 Francesco Chemolli <kinkie@squid-cache.org>

 This program is free software. You may redistribute copies of it under the
 terms of the GNU General Public License version 2, or (at your opinion) any
 later version.

=head1 QUESTIONS

Questions on the usage of this program can be sent to the I<Squid Users mailing list <squid-users@lists.squid-cache.org>>

=head1 REPORTING BUGS

Bug reports need to be made in English.
See https://wiki.squid-cache.org/SquidFaq/BugReporting for details of what you need to include with your bug report.

Report bugs or bug fixes using https://bugs.squid-cache.org/

Report serious security bugs to I<Squid Bugs <squid-bugs@lists.squid-cache.org>>

Report ideas for new improvements to the I<Squid Developers mailing list <squid-dev@lists.squid-cache.org>>

=head1 SEE ALSO

squid (8), GPL (7),

The Squid FAQ wiki https://wiki.squid-cache.org/SquidFaq

The Squid Configuration Manual http://www.squid-cache.org/Doc/config/

=cut

use Data::Dumper;
use Time::HiRes qw(gettimeofday tv_interval);

# options handling
my %opts = (); #for getopt
my $debug = 0; #debug
my $logfile = *STDERR; #filehandle to logfile
my $logfilename;
my $delay = 500; #in milliseconds. Configurable with the -w option.
#for custom delay algorithms, you can customize the dispatch_request function

#calculate the delay for the request.
# Gets as input the verbatim full line received from squid
# (channel number and all, as configured in squid.conf) and returns
# a floating point number >= 0 which is the delay to be applied to the request
# in seconds.
# Notice that in order to have efficient data structures, the delay is
# assumed to be monotonously growing. In other words, a long-delay
# item will stall the queue until completed. Supporting generic delays
# requires transforming @queue from a FIFO to a priority queue.
sub calc_delay {
    return $delay;
}

GetOptions("debug|d" => \$debug,
    "wait|w=i" => \$delay,
    "log|l=s" => \$logfilename)
    or die("Error in parsing command line arguments");
if (defined $opts{h}) {
    HELP_MESSAGE();
    exit 0;
}
$delay /= 1000.0; # transform msec into sec
if ($logfilename) {
    open ($logfile,">>", "$opts{l}");
    $debug=1;
}

my @p=split(/[\\\/]/,$0);
my $prg_basename=pop @p;
$prg_basename .= "[$$]";
undef @p;
my $reqid=0; #sequence number for requests

# variables initialization for select
my $rvec = '';
vec($rvec,0,1) = 1; #stdin
my ($nfound, $rd, $nread, $req);

#requests queue
my @queue = (); # array of references to hashes, with keys chan, when, req, reqid

# signal handlers
$SIG{HUP} = \&dump_state;

#disable IO buffering
$| = 1;
my $fh=select($logfile); $|=1; select($fh); undef($fh);

# takes a result from a gettimeofday call and turns it into a
# floating-point number suitable for approximate time calculations and select
sub fract_time {
    return $_[0]+$_[1]/1000000;
}

sub dispatch_request {
    my $r = $_[0];
    chomp $r;
    &debug("got request: '$r'");
    my %evt = ();
    my @fields;
    @fields = split (/\s+/, $r);
    $evt{when} = &calc_delay($r)+fract_time(gettimeofday());
    $evt{reqid}=$reqid++;
    $evt{req} = $r;
    $evt{chan} = $fields[0];
    &debug("Dispatching: reqid $evt{reqid}, chan $evt{chan}, when $evt{when}, raw {$evt{req}}");
    push @queue,\%evt;
}

sub next_event {
    my $now = fract_time(gettimeofday());
    if (@queue) {
        my $when = $queue[0]->{when} - $now;
        &debug("Next event is in $when seconds");
        return $when;
    }
    &debug("No events in queue");
    return undef;
}

sub handle_events {
    my $now = fract_time(gettimeofday());
    while ( @queue ) {
        &debug("Queue length is $#queue");
        last if ($queue[0]->{when} > $now);
        my %evt = %{shift @queue};
        &debug("Event: reqid $evt{reqid}, chan $evt{chan}, when $evt{when}, raw {$evt{req}}");
        print $evt{chan} , " OK\n";
    }
}

# main loop
while(1) {
    &debug("selecting");
    $nfound = select($rd = $rvec,undef,undef,&next_event());
    &debug("found $nfound bits set");
    if ($nfound == -1 ) {
        next if ($!{ERESTART} || $!{EAGAIN} || $!{EINTR});
        &debug("error in select: $!");
        exit 1;
    }
    if (vec($rd,0,1)==1) { #got stuff from stdin
        my $d; #data
        $nread = sysread(STDIN,$d,40960); # read 40kb
        # clear the signal-bit, stdin is special
        vec($rd,0,1) = 0;
        if ($nread==0) {
            &debug("nothing read from stdin, exiting");
            exit 0;
        }
        my $i;
        while ($i = index($d,"\n")) { #BUG: assumption of no spill-over
            last if ($i == -1);
            &dispatch_request(substr($d,0,$i));
            $d=substr($d,$i+1);
        }
    }
    &handle_events();
}

my $doc = <<_EOF;
delay-adding external acl helper
authorizes all requests, adding a delay before doing so.
supports multiplexed helper protocol.
Options:
  -h, --help: this help message
  -d, --debug: enable debug output
  -l <file>, --log <file>: log output to named file instead of stderr (implies debug)
  -w <num>, --wait <num> delay each request by this number milliseconds

AUTHOR: Francesco Chemolli <kinkie\@squid-cache.org>
Licensed under the terms of the GNU GPL v2 or later (see source for details)
_EOF
our $VERSION = "1.0";

sub HELP_MESSAGE {
    print STDERR $doc;
}

sub dump_state {
    $SIG{HUP} = \&dump_state;
    print STDERR "Queue:\n",Dumper(\@queue),"\n";
}

sub debug {
    return unless ($debug);
    print $logfile $prg_basename , ": ", @_, "\n";
}