Enforces a quota on binary builds uploaded to a server.

webtools/tinderbox3/client/tbox_build_quota.pl

@@ -0,0 +1,145 @@
+#!/usr/bin/perl -w -I.
+use strict;
+
+use Getopt::Long;
+use Date::Format;
+
+our $VERSION = "1.0";
+my %args;
+GetOptions(\%args, "url:s", "quota:i", "start:i", "end:i");
+if (!defined($args{quota}) || !defined($args{start}) || !defined($args{end}) ||
+    @ARGV != 1) {
+  print <<EOM;
+
+Usage: tbox_build_quota.pl --quota=<megabytes quota> --start=<hours ago> --end=<hours ago> build_dirs_file
+
+This script deletes builds selectively.  It attempts to keep an evenly spaced
+number of builds sitting around for a given period that still fits within the
+criteria.  It will try to order the builds such that the number of builds per
+directory for a particular period of time is even.  (This is meant to ensure
+that, for example, we try and keep at least one build per platform per day.)
+
+--url: the toplevel url to the tinderbox server (the dir containing
+       showbuilds.pl)
+--quota: max number of megabytes (Mb) to use for the time period.
+--start: the start of the range in hours (for example, 72).  0 for forever.
+--end: the end of the range in hours (for example, 24).  0 for current.
+build_dirs_file: the series of build directories to clean up.  Format:
+
+<pattern> <url>
+<pattern> <url>
+...
+
+  <pattern>: a glob pattern to match a set of files (~/public_html/builds/*)
+  <url>: the url the build will point to.  %s will be replaced with the build's
+         filename and the url will be sent to the server to notify it that the
+         build has been removed.  (http://jkeiser.no-ip.com/~jkeiser/builds/%s)
+
+EOM
+  exit(0);
+}
+
+my %build_dir_urls;
+my @build_dirs;
+open CONFIG, $ARGV[0] or die "Could not open $ARGV[0]!";
+while (<CONFIG>) {
+  my ($build_dir, $build_url) = split /\s+/;
+  push @build_dirs, $build_dir;
+  $build_dir_urls{$build_dir} = $build_url;
+}
+close CONFIG;
+
+# Round time up to nearest hour so we have less variability in this process
+my $current_time = time;
+if ($current_time % (60*60)) {
+  $current_time += 60*60 - ($current_time % (60*60));
+}
+
+my $start_seconds = $current_time - $args{start}*60*60;
+my $end_seconds = $current_time - $args{end}*60*60;
+
+# Gather the list of builds
+my $total_size = 0;
+my %builds;
+foreach my $build_dir (@build_dirs) {
+  my @unsorted_build_list;
+  foreach my $build (glob($build_dir)) {
+    # Make sure this build is in the range we're dealing with
+    my @build_stat = stat($build);
+    die "No build stat for $build ($build_dir)" if !@build_stat;
+    if (($args{start} == 0 || $build_stat[9] >= $start_seconds) &&
+        $build_stat[9] <= $end_seconds) {
+      push @unsorted_build_list, { build => $build, size => $build_stat[7], mtime => $build_stat[9] };
+      $total_size += $build_stat[7];
+    }
+  }
+
+  @{$builds{$build_dir}} = sort { $a->{mtime} <=> $b->{mtime} } @unsorted_build_list;
+}
+
+# Start deleting builds until we reach quota
+while ($total_size > ($args{quota}*1024*1024)) {
+  my $build_dir_to_delete;
+  my $build_to_delete;
+  # First try and find the most useless build: the one that is closest to its
+  # two siblings.
+  my $min_space = -1;
+  foreach my $build_dir (keys %builds) {
+    next if @{$builds{$build_dir}} < 3;
+    for (my $i = 1; $i < @{$builds{$build_dir}} - 1; $i++) {
+      my $space = $builds{$build_dir}[$i+1]{mtime} - $builds{$build_dir}[$i-1]{mtime};
+      if ($min_space == -1 || $space < $min_space) {
+        $min_space = $space;
+        $build_dir_to_delete = $build_dir;
+        $build_to_delete = $i;
+      }
+    }
+  }
+  # If that failed, all build_dirs must have 2 or less builds.  Find one that
+  # has 2 builds and lop off the last one.
+  if (!defined($build_dir_to_delete)) {
+    foreach my $build_dir (keys %builds) {
+      if (@{$builds{$build_dir}} == 2) {
+        $build_dir_to_delete = $build_dir;
+        $build_to_delete = 1;
+        last;
+      }
+    }
+  }
+  # If that failed, all build_dirs must have 1 build.  Lop off the build on the
+  # first such one we find.
+  if (!defined($build_dir_to_delete)) {
+    foreach my $build_dir (keys %builds) {
+      if (@{$builds{$build_dir}} == 1) {
+        $build_dir_to_delete = $build_dir;
+        $build_to_delete = 0;
+        last;
+      }
+    }
+  }
+  if (!defined($build_dir_to_delete)) {
+    die "Eek!  No more builds left to delete!  You just can't be satisfied, can you?  $total_size left out of " . ($args{quota}*1024*1024);
+  }
+
+  $total_size -= $builds{$build_dir_to_delete}[$build_to_delete]{size};
+  delete_build(\%builds, $args{url}, $build_dir_urls{$build_dir_to_delete}, $build_dir_to_delete, $build_to_delete);
+}
+
+use LWP::UserAgent;
+use HTTP::Request::Common;
+
+sub delete_build {
+  my ($builds, $tbox_url, $build_url, $build_dir, $build_num) = @_;
+  $builds->{$build_dir}[$build_num]{build} =~ /([^\/]*)$/;
+  my $build = $1;
+  $build_url =~ s/\%s/$build/g;
+  print "Deleting ", $builds->{$build_dir}[$build_num]{build}, "\n";
+  if ($tbox_url) {
+    my $ua = new LWP::UserAgent;
+    $ua->agent("TinderboxBuildQuota/" . $::VERSION);
+    my $res = $ua->request(POST "$tbox_url/xml/build_deleted.pl", [ url => $build_url ]);
+    die "Could not delete $tbox_url due to connection failure\n" if !$res->is_success();
+  }
+  splice @{$builds->{$build_dir}}, $build_num, 1;
+  system("rm", "-f", $builds->{$build_dir}[$build_num]{build});
+}