config/chroot_local-includes/usr/local/sbin/htpdate

   1 #!/usr/bin/perl
   2 #
   3 # htpdate time poller version 0.9.3
   4 # Copyright (C) 2005 Eddy Vervest
   5 # Copyright (C) 2010-2011 Tails developers <tails@boum.org>
   6 #
   7 # This program is free software; you can redistribute it and/or
   8 # modify it under the terms of the GNU General Public License
   9 # as published by the Free Software Foundation; either version 2
  10 # of the License, or (at your option) any later version.
  11 # http://www.gnu.org/copyleft/gpl.html
  12
  13 use strict;
  14 use warnings;
  15
  16 use version; our $VERSION = qv('0.9.3');
  17
  18 use Carp;
  19 use Cwd;
  20 use Data::Dumper;
  21 use DateTime;
  22 use DateTime::Format::DateParse;
  23 use English qw( -no_match_vars );
  24 use File::Path qw(rmtree);
  25 use File::Spec::Functions;
  26 use File::Temp qw/tempdir/;
  27 use Getopt::Long::Descriptive;
  28 use List::Util qw( shuffle );
  29 use open qw{:utf8 :std};
  30 use POSIX qw( WIFEXITED );
  31 use threads;
  32 use Try::Tiny;
  33
  34 my $datecommand = '/bin/date';  # "date" command to set time
  35 my $dateparam   = '-s';         # "date" parameter to set time
  36 my $maxadjust   = 0;            # maximum time step in seconds (0 means no max.)
  37 my $minadjust   = 1;            # minimum time step in seconds
  38 my (
  39     $debug, $useragent, $log, $quiet, $set_date,
  40     $done_file, $res_file, $usage, $opt, $runas,
  41     $allowed_per_pool_failure_ratio, $proxy, @pools,
  42 );
  43
  44 sub done {
  45     if (defined $done_file) {
  46         $> = 0 if $runas;
  47         open my $f, '>', $done_file or
  48             print STDERR "Couldn't write done file: $done_file\n";
  49         close $f;
  50         $> = getpwnam($runas) if $runas;
  51     }
  52 }
  53
  54 $SIG{__DIE__} = sub {
  55     # Avoid the "done" file to be created by an catched exception.
  56     # When a eval block is being run, e.g. for exception catching, $^S is true.
  57     # It is false otherwise.
  58     done unless $^S;
  59     die(@_);
  60 };
  61
  62 sub message {
  63     my @msg = @_;
  64
  65     if ($log) {
  66         open my $h, '>>', $log or die "Cannot open log file $log: $!";
  67         print $h "@msg\n";
  68         close $h;
  69     }
  70     else {
  71         print "@msg\n" unless $quiet;
  72     }
  73 }
  74
  75 sub debug {
  76     message(@_) if $debug;
  77 }
  78
  79 sub error {
  80     debug(@_);
  81     croak @_;
  82 }
  83
  84 sub parseCommandLine () {
  85     # specify valid switches
  86     ($opt, $usage) = describe_options(
  87         'htpdate %o',
  88         [ 'debug|d', "debug", { default => 0 } ],
  89         [ 'help', "print usage message and exit" ],
  90         [ 'quiet|q', "quiet", { default => 0 } ],
  91         [ 'user|u:s', "userid to run as" ],
  92         [ 'dont_set_date|x', "do not set the time (only show)", { default => 0 } ],
  93         [ 'user_agent|a:s', "http user agent to use", { default => "htpdate/$VERSION" } ],
  94         [ 'log_file|l:s', "log to this file rather than to STDOUT" ],
  95         [ 'done_file|D:s', "create this file after quitting in any way" ],
  96         [ 'success_file|T:s', "create this file after setting time successfully" ],
  97         [ 'pal_pool=s@', "distrusted hostnames" ],
  98         [ 'neutral_pool=s@', "neutral hostnames" ],
  99         [ 'foe_pool=s@', "distrusted hostnames" ],
 100         [ 'allowed_per_pool_failure_ratio:f', "ratio (0.0-1.0) of allowed per-pool failure", { default => 1.0 } ],
 101         [ 'proxy|p:s', "what to pass to curl's --socks5-hostname (if unset, environment variables may affect curl's behavior -- see curl(1) for details)" ],
 102     );
 103
 104     usage() if $opt->help;
 105     usage() unless $opt->pal_pool && $opt->neutral_pool && $opt->foe_pool;
 106
 107     $runas       = $opt->user if $opt->user;
 108     $>           = getpwnam($runas) if $runas;
 109     $useragent   = $opt->user_agent;
 110     $debug       = $opt->debug;
 111     $log         = $opt->log_file if $opt->log_file;
 112     $quiet       = $opt->quiet;
 113     $set_date    = ! $opt->dont_set_date;
 114     $done_file   = $opt->done_file if $opt->done_file;
 115     $res_file    = $opt->success_file if $opt->success_file;
 116     $allowed_per_pool_failure_ratio = $opt->allowed_per_pool_failure_ratio;
 117     $proxy       = $opt->proxy if $opt->proxy;
 118     @pools = map {
 119         [
 120             map {
 121                 $_ = 'https://'.$_ unless $_ =~ /^http/i;
 122             } split(/,/, join(',', @{$_}))
 123         ]
 124     } ($opt->pal_pool, $opt->neutral_pool, $opt->foe_pool);
 125 }
 126
 127 sub usage () {
 128     print STDERR $usage->text;
 129     exit;
 130 }
 131
 132 sub newestDateHeader {
 133     my ($dir) = @_;
 134
 135     my @files = grep { ! ( $_ =~ m|/?\.{1,2}$| ) } glob("$dir/.* $dir/*");
 136     @files or error "No downloaded files can be found";
 137
 138     my $newestdt;
 139
 140     foreach my $file (@files) {
 141         next if -l $file || -d _;
 142         my $date;
 143         open(my $file_h, '<', $file) or die "Can not read file $file: $!";
 144         while (my $line = <$file_h>) {
 145             chomp $line;
 146             # empty line == we leave the headers to go into the content
 147             last if $line eq '';
 148             last if ($date) = ($line =~ m/^\s*Date:\s+(.*)$/m);
 149         }
 150         close $file_h;
 151         if (defined $date) {
 152             # RFC 2616 (3.3.1) says Date headers MUST be represented in GMT
 153             my $dt = DateTime::Format::DateParse->parse_datetime( $date, 'GMT' );
 154             if (! defined $newestdt || DateTime->compare($dt, $newestdt) > 0) {
 155                 $newestdt = $dt;
 156             }
 157         }
 158     }
 159
 160     return $newestdt;
 161 }
 162
 163 =head2 random_first_with_allowed_failure_ratio
 164
 165 Returns the result of the first successful application of
 166 $args->{code} on a random element of $args->{list}.
 167 Success is tested using the $args->{is_success} predicate,
 168 called on the value returned by $args->{code}.
 169
 170 $args->{allowed_failure_ratio} caps the maximum failure ratio before
 171 giving up.
 172
 173 $args->{code} is called with two arguments: the currently (randomly
 174 picked) considered element, and $args->{args}.
 175
 176 Any exceptions thrown by $args->{code} is catched.
 177
 178 =cut
 179 sub random_first_with_allowed_failure_ratio {
 180     my $args = shift;
 181
 182     my %tried;
 183     $tried{$_} = 0 for (@{$args->{list}});
 184     my $failures = 0;
 185     my $total = keys %tried;
 186
 187     while ( $failures / $total <= $args->{allowed_failure_ratio} ) {
 188         my @randomized_left = shuffle grep { ! $tried{$_} } keys(%tried);
 189         my $picked = $randomized_left[0];
 190         $tried{$picked}++;
 191         my $res;
 192         try {
 193             $res = $args->{code}->($picked, $args->{args})
 194         };
 195         return $res if $args->{is_success}->($res);
 196         $failures++;
 197     }
 198
 199     return;
 200 }
 201
 202 sub getPoolDateDiff {
 203     my $args = shift;
 204
 205     random_first_with_allowed_failure_ratio({
 206         list => $args->{urls},
 207         code => \&getUrlDateDiff,
 208         is_success => sub { defined shift },
 209         allowed_failure_ratio => $allowed_per_pool_failure_ratio,
 210     });
 211 }
 212
 213 sub getUrlDateDiff {
 214     my $url = shift;
 215     my $args = shift;
 216
 217     defined $url or error "getUrlDateDiff must be passed an URL";
 218     debug("getUrlDateDiff: $url");
 219
 220     my $tmpdir = tempdir("XXXXXXXXXX", TMPDIR => 1);
 221
 222     my @curl_options = (
 223         '--user-agent', $useragent, '--silent',
 224         '--proto', '=https', '--tlsv1',
 225         '--head', '--output', catfile($tmpdir, 'headers'),
 226     );
 227     push @curl_options, ('--socks5-hostname', $proxy) if defined $proxy;
 228
 229     my @cmdline = ('curl', @curl_options, $url);
 230
 231     # fetch (the page and) referenced resources:
 232     # images, stylesheets, scripts, etc.
 233     my $before = DateTime->now->epoch();
 234     WIFEXITED(system(@cmdline)) or error "Failed to fetch content from $url: $!";
 235     my $local = DateTime->now->epoch();
 236     my $newestdt;
 237     eval { $newestdt = newestDateHeader($tmpdir) };
 238     if ($EVAL_ERROR =~ m/No downloaded files can be found/) {
 239         rmtree($tmpdir);
 240         error "No file could be downloaded from $url.";
 241     }
 242
 243     rmtree($tmpdir);
 244
 245     defined $newestdt or error "Could not get any Date header";
 246     my $newest_epoch = $newestdt->epoch();
 247
 248     my $diff = $newest_epoch - $local;
 249     my $took = $local - $before;
 250
 251     debug("$url (took ${took}s) => diff = $diff second(s)");
 252
 253     return $diff;
 254 }
 255
 256 sub adjustDate {
 257     my ($diff) = @_;
 258
 259     defined $diff or error "adjustDate was passed an undefined diff";
 260
 261     my $local = DateTime->now->epoch();
 262     my $absdiff = abs($diff);
 263
 264     debug("Median diff: $diff second(s)");
 265
 266     if ( $maxadjust && $absdiff gt $maxadjust ) {
 267         message("Not setting clock as diff ($diff seconds) is too large.");
 268     }
 269     elsif ( $absdiff lt $minadjust) {
 270         message("Not setting clock as diff ($diff seconds) is too small.");
 271     }
 272     else {
 273         my $newtime = DateTime->now->epoch + $diff;
 274         message("Setting time to $newtime...");
 275         if ($set_date) {
 276             $> = 0 if $runas;
 277             open(my $fd, "-|", $datecommand, $dateparam, '@' . $newtime)
 278                 or die "Cannot set run command $datecommand: $!";
 279             if ( $? != 0 ) {
 280                 my @output = <$fd>;
 281                 error "An error occured setting the time\n@output";
 282             }
 283             close($fd);
 284             $> = getpwnam($runas) if $runas;
 285         }
 286     }
 287     if (defined $res_file) {
 288         $> = 0 if $runas;
 289         open my $res_h, '>>', $res_file or die "Cannot open res file $res_file: $!";
 290         print $res_h "$diff\n";
 291         close $res_h;
 292         $> = getpwnam($runas) if $runas;
 293     }
 294 }
 295
 296 sub median {
 297     my @a = sort {$a <=> $b} @_;
 298     return ($a[$#a/2] + $a[@a/2]) / 2;
 299 }
 300
 301 parseCommandLine();
 302 message("Running htpdate.");
 303 my @diffs = grep {
 304     defined $_
 305 } map {
 306     my $diff = $_->join();
 307     if (! defined $diff) {
 308         error('Aborting as one pool could not be reached');
 309     }
 310     $diff;
 311 } map {
 312     threads->create(\&getPoolDateDiff, { urls => $_ })
 313 } @pools
 314     or error "No Date header could be received.";
 315 adjustDate(median(@diffs));
 316 done;