memcron 0.6.3-Bret

#!/usr/bin/env perl
our $VERSION = "0.6.3-Bret";

#////////////////////////////////////////////////////////////////////////////////////
#
#   memCron - DreamHost PS Memory Manager
#
#   Author     : Yaosan Yeo
#   Version    : 0.6
#   Date       : 22 March 2010
#   URL        : http://memcron.com/
#
#   History  :
#   0.6.2-chris [2010.06.30] - updated sendmail path from /usr/bin/sendmail to |/usr/sbin/sendmail
#                                 |-> neet to place \ before @ in the email address (ex: me\@us.com)
#                            + added random number to unique id
#   0.6.1-ben [2010.03.22] - Added support for HTTP::MHTTP module
#                          + Added a message log in ./logs/memcron.log, new config item $log_level
#                (0 = no log, 3 = default, 5 = debugging)
#   0.6 [2010.03.22] - Added: Various improvements contributed by memCron's user, Ben and Bret: (thanks guys!)
#                      + Replaced most external calls with built-ins
#                      + Removed dependency on Mail::SendMail
#                      + Replaced LWP (slow and bloated) with system call to curl
#                      + Get memory sizes from /proc/meminfo
#                      + Simplified memory collecting
#                      + Get current size from API rather than OS
#                      + New options to disable updates, alerts
#                      + Include mem target, cache used in csv
#                      + Better error handling on memory resize
#                    - Changed: Z-score function is now internal
#
#   0.4.1 [2009.08.10 ] - Fixed: Memory calculation due to the 2x increase of swap memory by DreamHost
#
#   0.4 [2009.06.28] - Added: New parameter "$max_memory" and "$min_memory" to limit the memory range that memCron should operate within
#                    - Added: New parameter "$mem_threshold" to set a memory threshold, which when exceeded, will send out notification to $email
#                    - Added: 4 new subroutines - round(), get_mem_size(), get_mem_size(), get_mem_target() to simplify the code structure
#                    - Added: Base and swap memory size to function output
#                    - Added: Resize information to function output
#                    - Changed: "$debug" parameter moved from config.cfg to this file
#                    - Removed: "$username" parameter, now DreamHost API only needs API key for authentication
#                    - Fixed: Memory target are now computed more correctly during downsize
#
#   0.3 [2009.05.27] - Added: New parameter "$downsize_resistance" to prevent rapid fluctuations from causing multiple resizes within short period of time
#                    - Changed: 0.3 to 0.7 ratio between "$mem_mean" and "$mem_used instead" of 0.5 to 0.5 when calculating "$mem_free_tolerance"
#                    - Changed: More descriptive error message when log file cannot be opened
#                    - Fixed: "$unix_time" and "$cpu_load" will now be reevaluated until it is defined to ensure data point is always logged (removed in 0.5)
#                    - Fixed: Memory target calculations now correctly accounts max and swap memory, which is capped at 4000 MB and 450MB respectively
#
#   0.2 [2009.05.03] - Fixed: Account for "$num_data" in z-score calculation to ensure number of memory changes is minimized to within daily limits
#                    - Changed: "$use_api" is changed to "$debug", which if set disables all log outputs and API calls
#
#   0.1 [2009.04.30] - Initial release
#
#////////////////////////////////////////////////////////////////////////////////////
#
# Copyright 2009 (c) Yaosan Yao - http://www.memcron.com/
#
# Portions of this product originally from psmanager:                     #
# Copyright 2009 (C) Otto de Voogd - http://www.7is7.com/                 #
#                                                                         #
# This program is free software; you can redistribute it and/or modify    #
# it under the terms of the GNU General Public License as published by    #
# the Free Software Foundation; version 3 of the License.                 #
#                                                                         #
# This program is distributed in the hope that it will be useful,         #
# but WITHOUT ANY WARRANTY; without even the implied warranty of          #
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the           #
# GNU General Public License for more details.                            #
#                                                                         #
# See license: http://www.gnu.org/licenses/gpl.html                       #
#////////////////////////////////////////////////////////////////////////////////////

use strict;
use warnings;
no warnings 'uninitialized';

use File::Basename;
use Time::Local;
use Sys::Hostname;

#////////////////////////////////////////////////// get configurations

my $hostname = hostname;
my $unix_time = time();


# settings from config file
our (
    $key,                 $ps,                  $cron_interval,
    $max_memory,          $min_memory,          $mem_threshold,
    $disable_updates,     $alert_on_change,     $alert_on_error,
    $email,               $mem_free_confidence, $mem_free_to_used_ratio,
    $force_downsize_ratio,
    $downsize_resistance, $num_data,            $num_data_csv,
    $use_mhttp,           $debug,               $log_level
);

$force_downsize_ratio=0.20;

my $dir = dirname($0);
do "$dir/config.cfg";

$debug ||= $ARGV[0] eq '-d';
if (!defined $log_level) { $log_level = $debug ? 5 : 3 }

## try to use the MHTTP if it's available, set $use_mhttp=0 in config to avoid this.
if ($use_mhttp || !defined($use_mhttp)) {
    eval {
        require "HTTP/MHTTP.pm";
        import HTTP::MHTTP;
    };
    $use_mhttp = !$@;
}

# Logs
my $log_dir = "$dir/logs";
my $log_csv = "$log_dir/$hostname.csv";
my $log_memory = "$log_dir/$hostname.log";
my $log_downsize = "$log_dir/$hostname-downsize.log";
my $log_message = "$log_dir/memcron.log";

startup();
local $SIG{__DIE__} = sub {
    if ($^S) {
        die @_;
    } else {
        FATAL("$_[0]");
        cleanup(-1);
    }
};

# DreamHost PS limit
my $daily_change_limit = 30;
my $runs_per_day       = 1440 / $cron_interval;

# DreamHost PS defaults
if ( $max_memory > 4000 ) { $max_memory = 4000; }
if ( $min_memory < 300 )  { $min_memory = 300; }

# Statistics values
my $SAMPLES = $debug ? 1 : 60;
my $mem_used_zscore = abs( normsinv( ( $daily_change_limit * $num_data / $runs_per_day ) / $runs_per_day ) );    #1.89;
my $mem_free_zscore = abs( normsinv( $mem_free_confidence ) );    #3.09;

#////////////////////////////////////////////////// main program starts

my ( $mem_total, $mem_used, $mem_free, $mem_cached, $cpu_load );

#my $list_ps = call_api('list_ps');
#
#if ( $list_ps->{status} ) {
#   for (@{$list_ps->{data}}){
#       next if $_->{ps} ne $hostname;
#       $mem_total = $_->{memory_mb};
#       last;
#   }
#   if (!$mem_total) {
#       die "Dreamhost PS $hostname not found!";
#   }
#} else {
#   die "$list_ps->{error}";
#}

#my $mem = meminfo();

#foreach ( 1 .. $SAMPLES ) {
#   $cpu_load += ( cpu_load() )[1];
#   $mem = meminfo();
#   $mem_used += $mem->{MemTotal} - $mem->{MemFree} + $mem->{SwapTotal} - $mem->{SwapFree};
#   $mem_cached += $mem->{Cached};
#   sleep 1 if !$debug;
#}
my $firstpass=1;
foreach ( 1 .. $SAMPLES ) {
    my $mu=0;
    my $mc=0;
    sleep 1 if !$firstpass;
    $firstpass=0;
    $cpu_load += ( cpu_load() )[1];
    ($mem_total,$mu,$mem_free,$mc) = split /\t/, &getMemoryInfo($mem_total,$mu,$mem_free,$mc);
    $mem_used+=$mu;
    $mem_cached+=$mc;
}

$mem_used = round( $mem_used / $SAMPLES );
$mem_cached = round( $mem_cached / $SAMPLES );
#$mem_used -= $mem_cached;
$cpu_load = round( $cpu_load / $SAMPLES, 2 );
$mem_free = $mem_total - $mem_used;

write_log( $log_memory, $mem_used, $num_data );


#////////////// calculate the amount of memory to be reserved based on past data

my @data = read_log( $log_memory );

# construct a short list to be used when downsizing
my @shortlist = @data[ ( scalar(@data) - $downsize_resistance ) .. ( scalar(@data) - 1 ) ];

# make sure we have enough data points before proceeding
if ( scalar(@data) < round( $num_data * 0.1 ) ) {
    WARN("need more data points");
    cleanup();
}

my ( $mem_stattotal, $mem_mean, $mem_median, $mem_stdev ) = stats(@data);

$mem_mean = round($mem_mean);
$mem_stdev = round( $mem_stdev, 2 );

my $mem_used_tolerance = round( $mem_used_zscore * $mem_stdev );
my $mem_free_tolerance = round( $mem_free_zscore * $mem_stdev );

unless ( $mem_free_tolerance > ( $mem_mean * 0.3 + $mem_used * 0.7 ) * $mem_free_to_used_ratio ) {
    $mem_free_tolerance = round( ( $mem_mean * 0.3 + $mem_used * 0.7 ) * $mem_free_to_used_ratio );
}

#////////////// calculate the memory required

my $mem_required = $mem_used + $mem_free_tolerance;
my $mem_target   = get_mem_target($mem_required);
my $set = ( abs( $mem_total - $mem_target ) > $mem_used_tolerance );

#////////////// resize resistance
my $downsize_count = 0;
if ( $set ) {
    WARN("resize required $mem_target ($mem_total)");
    if ( $mem_target < $mem_total ) {
        $downsize_count = read_status( $log_downsize ) || 0;
        $downsize_count++;

        if ( $downsize_count >= $downsize_resistance ) {
            $downsize_count = 0;
            $mem_required = round( ( stats(@shortlist) )[1] ) + $mem_free_tolerance;
            $mem_target = get_mem_target($mem_required);
        } else {
            $set = 0;
        }
    }
}

write_status( $log_downsize, $downsize_count );

#////////////// set memory using DreamHost API, output result

my $sendmail;
my $subject;
my $message = <<"MESSAGE";
Total: $mem_total   Used: $mem_used Free: $mem_free
Mean: $mem_mean Stdev: $mem_stdev   Load: $cpu_load
Tolerance: $mem_used_tolerance  Tolerance (free): $mem_free_tolerance

Target: $mem_target
MESSAGE

$set = 0 if $mem_target == $mem_total || $debug || $disable_updates;

if ($set) {
    $message .= "\nMemory was resized from $mem_total MB to $mem_target MB!\n";

    # check against memory threshold, send notification email if it is exceeded
    if ( $mem_threshold && $mem_target > $mem_threshold ) {
        print "\n*** Warning! Threshold exceeded! ***\n";
        $subject = "Memory threshold exceeded for $hostname";
        $sendmail = 1 unless $debug;
    }

    my $set_response;
    my $with_force=0;
    if ( ($force_downsize_ratio) && ($mem_target < $mem_total) && ((($mem_total-$mem_target)/$mem_total) >= $force_downsize_ratio)) {
        #If we'll save more than 25%, then force the resize.
        $set_response = call_api('set_size', {size => $mem_target,force => 'yes'});
        $with_force=1;
    } else {
        $set_response = call_api('set_size', size => $mem_target);
    }
    if ( $set_response->{status} ) {
        $subject = "Resized $hostname from $mem_total MB to $mem_target MB";
        if ($with_force) { $subject.=", with force"; }
        $sendmail = 1 if $alert_on_change;
    } else {
        $subject = "Unable to set memory size for $hostname";
        $message .= $set_response->{error};
        $sendmail = 1 if $alert_on_error;
    }

    $message .= "\n";

    # send notification if necessary
    if ( $sendmail && $email ) {
        my $top = `top -b -n 1`;
    chomp($top);
        email_notice( $email, $subject, <<"MESSAGE" );

$message
-----

List of running processes:

$top

MESSAGE

    } else {
        $message .= "\nNo need to adjust memory" . ( ($downsize_count) ? " yet! ($downsize_count/$downsize_resistance)" : "!" ) . "\n";
    }
}
print $message;
print "\n-----\n";

#////////////// write memory usage and cpu load to csv file

my $log_line = join( ",",
    $unix_time,          $mem_total,          $mem_used,
    $cpu_load,           $mem_mean,           $mem_stdev,
    $mem_used_tolerance, $mem_free_tolerance, $downsize_count,
    $mem_target,         $mem_cached
);

write_log($log_csv, $log_line, $num_data_csv);
cleanup();


#////////////// subroutines

sub cpu_load {
    open( LOAD, "/proc/loadavg" ) or die "Unable to open /proc/loadavg";
    my @l = split /\s+/, <LOAD>;
    close(LOAD);
    return @l;
}

sub meminfo {
    while (1) {
        open( MEM, "/proc/meminfo" ) or die "Unable to open /proc/meminfo";
        my %mem = map { (/(\w+):\s*(\d+)/) } <MEM>;
        close(MEM);
        ## kB to MB
        for ( values %mem ) { $_ = int( $_ / 1024 ) }
        ## sanity check MemTotal and retry if it's not valid
        return \%mem if $mem{MemTotal} >= 300 && $mem{MemTotal} <= 4000;
    }
}

sub getMemoryInfo {
    my ($tot_mem_avail,$tot_mem_used,$tot_mem_free,$tot_mem_cach) = @_;

    my $lines_read = 0;
    my $free_output = `free -m`;

    my $mem_avail;
    my $mem_used;
    my $mem_free;
    my $mem_cach;
    my $swap_avail;
    my $swap_used;
    my $swap_free;

    foreach my $line (split /\n/, $free_output) {
        $line =~ s/ +/ /g;
        my @linepart = split / /, $line;
        if ($line =~ /^Mem:/i) {
            $lines_read++;
            $mem_avail = $linepart[1];
            $mem_cach = $linepart[5] + $linepart[6];
            $mem_used = $linepart[2] - $mem_cach;
            $mem_free = $linepart[3] + $mem_cach;
        }
        if ($line =~ /^Swap:/i) {
            $lines_read++;
            $swap_avail = $linepart[1];
            $swap_used = $linepart[2];
            $swap_free = $linepart[3];
        }
    }
    if ($lines_read!=2) {
        &printError(9,"Could not retrieve memory information!");
        #die "Script terminated!\n";
    }
    # Occasionally excessively high memory values are returned
    # by 'free', hence we check that the values make some sense.
    if ( $mem_avail + $swap_avail < 16 * $max_memory ) {
    $tot_mem_avail = $mem_avail + $swap_avail;
        if (
            ($mem_used + $swap_used >= 0) &&
            ($mem_used + $swap_used <= $tot_mem_avail) &&
            ($mem_used + $swap_used > $tot_mem_used)
        ) {
            $tot_mem_used = $mem_used + $swap_used;
            $tot_mem_free = $mem_free + $swap_free;
            $tot_mem_cach = $mem_cach;
        }
    }
    return "$tot_mem_avail\t$tot_mem_used\t$tot_mem_free\t$tot_mem_cach";
}

sub email_notice {
    my ($to, $subject, $message) = @_;

    my $date = date_time_string();
    open( MAIL, "|/usr/sbin/sendmail -t" ) or die "Unable to open sendmail: $!";
    print MAIL <<"MESSAGE";
To: $to
From: memCron on $hostname <noreply\@memcron.com>
Date: $date
Subject: $subject

$message

-----------------------------------
memCron $VERSION at $date
-----------------------------------
MESSAGE

    close(MAIL);
}


## initialize message log, etc...
sub startup {
    if ( $log_level && !$debug ) {
        open(LOGINFO, ">>$log_message") or die "Cannot open  system log $log_message!";
    }
    INFO("memcron $VERSION started (pid: $$)");
}

sub cleanup {
    INFO("memcron $VERSION complete");
    if ( $log_level && !$debug ) {
        close(LOGINFO);
    }
    exit $_[0]||0;
}

sub log_message {
    my $ts = '['.date_time_string(time).']';
    my $indent;
    for ( split/\n/, $_[0]) {
        if ($debug) {
            print "$ts $indent$_\n";
        } else {
            print LOGINFO "$ts $indent$_\n";
        }
        $indent = "|";
    }
}

sub FATAL { &log_message if $log_level >= 1 }
sub ERROR { &log_message if $log_level >= 2 }
sub WARN  { &log_message if $log_level >= 3 }
sub INFO  { &log_message if $log_level >= 4 }
sub DEBUG { &log_message if $log_level >= 5 }



sub write_log {
    my ($file, $line, $truncate) = @_;
    if ($debug) {
        print "$file:\t$line\n";
        return;
    }
    open(LOG, ">>$file") or die "Cannot open $file!";
    print LOG $line,"\n";
    close(LOG);
    if ($truncate) {
        truncate_log( $file, $truncate );
    }
}

sub read_log {
    my ($file) = @_;
    if ( ! -e $file ) { return () };
    open(LOG, $file);
    my @lines;
    while (<LOG>) {
        chomp;
        push @lines, $_;
    }
    close LOG;
    return @lines;
}

sub truncate_log {
    my ($file, $lines) = @_;
    return unless -e $file;
    system("tail -n $lines $file > $file.temp");
    system("mv -f $file.temp $file");
}

# single value status files
sub write_status {
    my ($file, $value) = @_;
    if ($debug) {
        print "$file:\t$value\n";
        return;
    }
    open(LOG, ">$file") or die "Cannot open $file!";
    print LOG $value,"\n";
    close(LOG);
}

sub read_status {
    my ($file) = @_;
    return unless -e $file;
    open(LOG, $file);
    my $value = <LOG>;
    close LOG;
    chomp $value;
    return $value;
}

# wraps call to DreamHost API so we can catch errors in a uniform way
sub call_api {
    my ( $command, %params ) = @_;
    ## references globals: ($hostname, $time and $key)

    DEBUG("calling api $command");
    my $url = 'https://panel.dreamhost.com/api/';
    my %p = (
        key       => $key,
        cmd       => 'dreamhost_ps-' . $command,
        unique_id => $unix_time . rand() . $$,
        format    => 'perl',
        ps        => $hostname,
        %params
    );
    my $post = join(' ', map( "-d $_=$p{$_}", keys %p ) );
    my $response = eval {
        if ( $use_mhttp ) {
            DEBUG("using mhttp");
            $post = join('&', map("$_=$p{$_}", keys %p ));
            http_set_protocol(1);
            switch_debug(0);
            http_add_headers(
                    'User-Agent' => "memcron/$VERSION",
                    'Connection' => "Keep-Alive",
                    'Host' => 'panel.dreamhost.com',
                    'Content-Type' => 'application/x-www-form-urlencoded',
                );
            http_body($post);
            if (http_call('POST', $url)) {
                if (http_status() == 200) {
                    return http_response();
                } else {
                    die  http_reason() . "\n";
                }
            } else {
                die "Unable to connect to API\n"
            }
        } else {
            DEBUG("using system curl");
            $post = join(' ', map( "-d $_=$p{$_}", keys %p ) );
            return `curl -s $post $url`;
        }
    };

    my ( $r, $error );
    if ($@) {
        $error = "Error: \n" . $@;
    } elsif ( !$response ) {
        $error = "No response\n";
    } elsif ( $response !~ /^\$result/ ) {
        $error = "Unknown response format:\n" . $response;
    }

    my $result;
    if ( !$error ) {
        eval "$response";
        if ( $result->{result} eq 'error' ) {
            $error = "Error calling $command: $result->{data}\n";
        } elsif ( $result->{result} ne 'success' ) {
            $error = "Unknown API response:\n\n$response\n";
        }
    }

    return $error ? { status => 0, error => $error } : { status => 1, data => $result->{data} };
}

sub round {
    my ( $val, $places ) = @_;
    $places ||= 0;
    return sprintf( "%.${places}f", $val || 0 );
}

sub get_mem_target {
    my $mem_target = shift;

    # handle max and min memory limit
    if ( $mem_target < $min_memory ) {
        DEBUG("need $mem_target, using min_memory($min_memory)");
        $mem_target = $min_memory;
    } elsif ( $mem_target > $max_memory ) {
        WARN("need $mem_target, using max_memory($max_memory)");
        $mem_target = $max_memory;
    }

    return ( round($mem_target) );
}

sub stats {
    my $total = 0;
    foreach my $v (@_) { $total += $v; }

    my $average = $total / @_;
    my $median = @_ % 2
        ? $_[ ( @_ - 1 ) / 2 ]
        : ( $_[ @_ / 2 - 1 ] + $_[ @_ / 2 ] ) / 2;

    my $sqtotal = 0;
    foreach my $v (@_) {
        $sqtotal += ( $average - $v )**2;
    }
    my $stdev = ( $sqtotal / @_ )**0.5;

    return ( $total, $average, $median, $stdev );
}

sub date_time_string {
    # convert a time() value to a date-time string according to RFC 822

    my $time = $_[0] || time();    # default to now if no argument

    my @months = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);
    my @wdays  = qw(Sun Mon Tue Wed Thu Fri Sat);

    my ( $sec, $min, $hour, $mday, $mon, $year, $wday, $yday, $isdst ) = localtime($time);

    my $TZ = $ENV{TZ};
    if ( $TZ eq "" ) {
        # offset in hours
        my $offset = sprintf "%.1f", ( timegm(localtime) - time ) / 3600;
        my $minutes = sprintf "%02d", abs( $offset - int($offset) ) * 60;
        $TZ = sprintf( "%+03d", int($offset) ) . $minutes;
    }

    return join( " ",
        ( $wdays[$wday] . ',' ),
        $mday, $months[$mon],
        $year + 1900,
        sprintf( "%02d:%02d:%02d", $hour, $min, $sec ), $TZ );
}

sub normsinv {
    #
    # This function returns an approximation of the inverse cumulative
    # standard normal distribution function.  I.e., given P, it returns
    # an approximation to the X satisfying P = Pr{Z <= X} where Z is a
    # random variable from the standard normal distribution.
    #
    # The algorithm uses a minimax approximation by rational functions
    # and the result has a relative error whose absolute value is less
    # than 1.15e-9.
    #
    # Author:      Peter J. Acklam
    # Time-stamp:  2000-07-19 18:26:14
    # E-mail:      pjacklam@online.no
    # WWW URL:     http://home.online.no/~pjacklam

    my $p = shift;
    die "input argument must be in (0,1)\n" unless 0 < $p && $p < 1;

    # Coefficients in rational approximations.
    my @a = (-3.969683028665376e+01,  2.209460984245205e+02,
             -2.759285104469687e+02,  1.383577518672690e+02,
             -3.066479806614716e+01,  2.506628277459239e+00);
    my @b = (-5.447609879822406e+01,  1.615858368580409e+02,
             -1.556989798598866e+02,  6.680131188771972e+01,
             -1.328068155288572e+01 );
    my @c = (-7.784894002430293e-03, -3.223964580411365e-01,
             -2.400758277161838e+00, -2.549732539343734e+00,
              4.374664141464968e+00,  2.938163982698783e+00);
    my @d = ( 7.784695709041462e-03,  3.224671290700398e-01,
              2.445134137142996e+00,  3.754408661907416e+00);

    # Define break-points.
    my $plow  = 0.02425;
    my $phigh = 1 - $plow;

    # Rational approximation for lower region:
    if ( $p < $plow ) {
       my $q  = sqrt(-2*log($p));
       return ((((($c[0]*$q+$c[1])*$q+$c[2])*$q+$c[3])*$q+$c[4])*$q+$c[5]) /
               (((($d[0]*$q+$d[1])*$q+$d[2])*$q+$d[3])*$q+1);
    }

    # Rational approximation for upper region:
    if ( $phigh < $p ) {
       my $q  = sqrt(-2*log(1-$p));
       return -((((($c[0]*$q+$c[1])*$q+$c[2])*$q+$c[3])*$q+$c[4])*$q+$c[5]) /
                (((($d[0]*$q+$d[1])*$q+$d[2])*$q+$d[3])*$q+1);
    }

    # Rational approximation for central region:
    my $q = $p - 0.5;
    my $r = $q*$q;
    return ((((($a[0]*$r+$a[1])*$r+$a[2])*$r+$a[3])*$r+$a[4])*$r+$a[5])*$q /
           ((((($b[0]*$r+$b[1])*$r+$b[2])*$r+$b[3])*$r+$b[4])*$r+1);
}