pjs/webtools/tinderbox3/client/tbox_build_quota.pl

#!/usr/bin/perl -w -I.
# ***** BEGIN LICENSE BLOCK *****
# Version: MPL 1.1
#
# The contents of this file are subject to the Mozilla Public License Version
# 1.1 (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.mozilla.org/MPL/
#
# Software distributed under the License is distributed on an "AS IS" basis,
# WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
# for the specific language governing rights and limitations under the
# License.
#
# The Original Code is Tinderbox 3.
#
# The Initial Developer of the Original Code is
# John Keiser (john@johnkeiser.com).
# Portions created by the Initial Developer are Copyright (C) 2004
# the Initial Developer. All Rights Reserved.
#
# Contributor(s):
#
# ***** END LICENSE BLOCK *****

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});
}