tools/traffic_cacheable.pl

#!/usr/bin/perl

#   Licensed to the Apache Software Foundation (ASF) under one
#   or more contributor license agreements.  See the NOTICE file
#   distributed with this work for additional information
#   regarding copyright ownership.  The ASF licenses this file
#   to you under the Apache License, Version 2.0 (the
#   "License"); you may not use this file except in compliance
#   with the License.  You may obtain a copy of the License at
#
#       http://www.apache.org/licenses/LICENSE-2.0
#
#   Unless required by applicable law or agreed to in writing, software
#   distributed under the License is distributed on an "AS IS" BASIS,
#   WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
#   See the License for the specific language governing permissions and
#   limitations under the License.

use strict;
use warnings;
use LWP::UserAgent;
use IO::Socket::SSL;
use Data::Dumper;
use Getopt::Std;

my %histogram = (0 => 0,
                60 => 0,
                3600 => 0,
                86400 => 0,
                604800 => 0,
                2592000 => 0,
                30758400 => 0,
                'inf' => 0,
                'undef' => 0
);

my %histogram_with_heuristic = (0 => 0,
                60 => 0,
                3600 => 0,
                86400 => 0,
                604800 => 0,
                2592000 => 0,
                30758400 => 0,
                'inf' => 0,
                'undef' => 0
);

my %pretty_name = (0 => '0',
                   60 => '1 minute',
                   3600 => '1 hour',
                   86400 => '1 day',
                   604800 => '1 week',
                   2592000 => '1 month',
                   30758400 => '1 year',
                   'inf' => '> 1 year',
                   'undef' => 'undef'
);

my $debug = 0;

#-----------------------------------------------------------------------------
sub addToHistogram($$) {
  my($hist, $value) = @_;

  if (! defined $value) {
    $hist->{undef}++
  } elsif ($value <= 0) {
    $hist->{0}++;
  } elsif ($value <= 60) {
    $hist->{60}++;
  } elsif ($value <= 3600) {
    $hist->{3600}++;
  } elsif ($value <= 86400) {
    $hist->{86400}++;
  } elsif ($value <= 604800) {
    $hist->{604800}++;
  } elsif ($value <= 2592000) {
    $hist->{2592000}++;
  } elsif ($value <= 30758400) {
    $hist->{30758400}++;
  } else {
    $hist->{inf}++;
  }
}

#-----------------------------------------------------------------------------
sub usage() {
  print "USAGE: traffic_cacheable.pl [file]\n";
  print "\t-h\thelp";
  print "\n\ntraffic_cacheable.pl can read from a file or stdin\n";
  exit;
}

#-----------------------------------------------------------------------------
{
  my %opts;
  getopts("h", \%opts);
  usage() if (defined $opts{h});

  my $ua = LWP::UserAgent->new(
    ssl_opts => {
        verify_hostname => 0,
        SSL_verify_mode => IO::Socket::SSL::SSL_VERIFY_NONE,
    },
  );

  my %response_codes;
  my %cache_control_exists;
  my %expires_exists;
  my %last_modified_exists;
  my %pragma_exists;
  my $cc_and_expires_noexist = 0;
  my $cache_headers_noexist = 0;
  my $ats_cache_hit = 0;

  my $count = 0;
  while (my $url = <>) {
    $count++;
    chomp $url;
    my $req = HTTP::Request->new(GET => $url);

    print "Testing url: $url\n" if $debug;
    print STDERR "\rTesting url: $count" if ! $debug;
    my $res = $ua->request($req);
    my $freshness = $res->freshness_lifetime(heuristic_expiry => 0);
    my $freshness_with_heuristic = $res->freshness_lifetime();

    if ($res->is_success) {
      my $cache_control = $res->header('Cache-Control');
      my $expires = $res->header('Expires');
      my $last_modified = $res->header('Last-Modified');
      my $pragma = $res->header('Pragma');
      my $via = $res->header('Via');

      print "\tcode: ", $res->code, "\n" if $debug;
      print "\tCache-Control: ", $cache_control, "\n" if $debug;
      print "\tExpires: ", $expires, "\n" if $debug;
      print "\tcalculated age: ", $res->current_age, "\n" if $debug;
      print "\tfreshness lifetime: ", $freshness, "\n" if $debug;

      $response_codes{$res->code}++;
      if ($res->code == 200) {
        addToHistogram(\%histogram, $freshness);
        addToHistogram(\%histogram_with_heuristic, $freshness_with_heuristic);

        # check cache-control
        if (defined $cache_control) {
          $cache_control_exists{private}++ if $cache_control =~ m|private|i;
          $cache_control_exists{'no-cache'}++ if $cache_control =~ m|no-cache|i;
          $cache_control_exists{'no-store'}++ if $cache_control =~ m|no-store|i;
          $cache_control_exists{'max-age'}++ if $cache_control =~ m|max-age|i;
          $cache_control_exists{'maxage'}++ if $cache_control =~ m|maxage|i;
        } else {
          $cache_control_exists{undef}++;
        }

        # check expires
        if (defined $expires) {
          $expires_exists{defined}++;
        } else {
          $expires_exists{undef}++;
        }

        # check last-modified
        if (defined $last_modified) {
          $last_modified_exists{defined}++;
        } else {
          $last_modified_exists{undef}++;
        }

        # check pragma
        if (defined $pragma) {
          $pragma_exists{defined}++;
        } else {
          $pragma_exists{undef}++;
        }

        # check via
        if (defined $via) {
          my @items = split(/,/, $via);
          my $last = pop(@items);
          #print "$last\n";
          if (my($codes) = $last =~ m|\[([\w\s]+)\]|) {
            #print "$codes\n";
            $ats_cache_hit++ if ($codes =~ m|^c[HR]|);
          }
        }

        $cc_and_expires_noexist++ if (! defined $cache_control && ! defined $expires);
        $cache_headers_noexist++ if (! defined $cache_control && ! defined $expires && ! defined $last_modified);
      }
    }
    #last if $count == 5;
  }
  print "\n" if ! $debug;
  print "\n";

  print "Total Tested: $count\n";
  print "Response Codes:\n";
  foreach my $key (sort keys %response_codes) {
    printf("\t%s: %d (%.2f%%)\n", $key, $response_codes{$key}, $response_codes{$key} / $count * 100);
  }

  print "Freshness:\n";
  foreach my $key (0, 60, 3600, 86400, 604800, 2592000, 30758400, 'inf', 'undef') {
    printf("\t%s: %d (%.2f%%)\n", $pretty_name{$key}, $histogram{$key}, $histogram{$key} / $count * 100);
  }

  print "Freshness with Heuristic using Last-Modified (RFC 7234 4.2.2):\n";
  foreach my $key (0, 60, 3600, 86400, 604800, 2592000, 30758400, 'inf', 'undef') {
    printf("\t%s: %d (%.2f%%)\n", $pretty_name{$key}, $histogram_with_heuristic{$key}, $histogram_with_heuristic{$key} / $count * 100);
  }

  print "Headers:\n";
  print "\tCache-Control:\n";
  foreach my $key (sort keys %cache_control_exists) {
    printf("\t\t%s: %d (%.2f%%)\n", $key, $cache_control_exists{$key}, $cache_control_exists{$key} / $count * 100);
  }

  print "\tExpires:\n";
  foreach my $key (sort keys %expires_exists) {
    printf("\t\t%s: %d (%.2f%%)\n", $key, $expires_exists{$key}, $expires_exists{$key} / $count * 100);
  }

  print "\tLast-Modified:\n";
  foreach my $key (sort keys %last_modified_exists) {
    printf("\t\t%s: %d (%.2f%%)\n", $key, $last_modified_exists{$key}, $last_modified_exists{$key} / $count * 100);
  }

  print "\tPragma:\n";
  foreach my $key (sort keys %pragma_exists) {
    printf("\t\t%s: %d (%.2f%%)\n", $key, $pragma_exists{$key}, $pragma_exists{$key} / $count * 100);
  }

  print "Extra:\n";
  printf("\t%s: %d (%.2f%%)\n", 'Cache-Control / Expires not set', $cc_and_expires_noexist, $cc_and_expires_noexist / $count * 100);
  printf("\t%s: %d (%.2f%%)\n", 'Cache-Control / Expires / Last-Modified not set', $cache_headers_noexist, $cache_headers_noexist / $count * 100);
  printf("\t%s: %d (%.2f%%)\n", 'ATS Cache Hit (via header)', $ats_cache_hit, $ats_cache_hit / $count * 100);
}