bin/fup

   1 #! /usr/bin/perl
   2 #
   3 # $Id$
   4
   5
   6 use strict;
   7 use warnings;
   8 require LWP::UserAgent;
   9 require HTTP::Cookies;
  10 require URI::Escape;
  11 use Data::Dumper;
  12
  13 my $USER="adsl_303141";
  14 my $USERNAME="Jan Kratochvil";
  15 my $PASSWORD=&_priv_postget("uzivatel.gtsnovera.cz.pwd");
  16 my $IFDEV="eth0";
  17 my $SECS=8;
  18 my $RX_THRESHOLD=200000;        # 226085
  19 my $TX_THRESHOLD=200000;        # 291251
  20 my $STABILIZE_OFF=2;
  21 my $STABILIZE_ON=10;
  22
  23 $|=1;
  24 my $ua=LWP::UserAgent->new();
  25 #$ua->timeout(60);
  26 #$ua->env_proxy();      # conflicts with 'https'
  27 push @{$ua->requests_redirectable()},"POST";    # probably not needed
  28 my $jar=HTTP::Cookies->new();
  29 $ua->cookie_jar($jar);  # important
  30
  31 sub simple($;$)
  32 {
  33 my($url,$content)=@_;
  34
  35         my $request=HTTP::Request->new(($content ? "POST" : "GET"),$url);
  36         do { $request->content($_) if $_; } for $content;
  37         my $response=$ua->simple_request($request);
  38         die Dumper($response)."\n".$url if !$response->is_success() || !(my $r=$response->content());
  39         return $response;
  40 }
  41
  42 sub _priv_postget($)
  43 {
  44 my($base)=@_;
  45
  46         my $full=$ENV{"HOME"}."/priv/postget.".$base;
  47         local *F;
  48         open F,$full or die "$full: $!";
  49         my $r=do { local $/; <F>; } or die "read \"$full\": $!";
  50         close F or die "close \"$full\": $!";
  51         chomp $r;
  52         return $r;
  53 }
  54
  55 sub login()
  56 {
  57         my $login=simple("https://uzivatel.gtsnovera.cz/cgi-bin/login.pl",
  58                         'login='.URI::Escape::uri_escape($USER).'&password='.URI::Escape::uri_escape($PASSWORD),
  59                         )->decoded_content() or die "login";
  60         $login=~m{<span class="textTitle1">\Q$USERNAME\E,</span>} or die $login."\nNo name found";
  61 }
  62
  63 sub change($)
  64 {
  65 my($on)=@_;
  66
  67         $on=($on ? 1 : 0);
  68         my $try=0;
  69         my $change;
  70         do {
  71                 print "!" if $try;
  72                 die "Looping to login" if $try++>0x10;
  73                 login() if $try;
  74                 $change=simple("https://uzivatel.gtsnovera.cz/cgi-bin/fup.pl",
  75                                 'action.'.($on ? 'setManual' : 'unsetManual').'=1',
  76                                 )->decoded_content() or die "change: ".$on;
  77                 } while $change=~m{No authentication cookie was sent.};
  78         my $is_on =($change=~m{\bFUP active\b});
  79         my $is_off=($change=~m{\bFUP not active\b});
  80         $is_on==!$is_off or die $change."\nInvalid change state";
  81         $on==$is_on or die $change."\nChange not changed, wanted: ".$on;
  82         print "<$on>";
  83         return $on;
  84 }
  85
  86 if (defined(my $change=$ARGV[0])) {
  87         print "OK: ";
  88         change($change);
  89         print "\n";
  90         exit 0;
  91         }
  92
  93 my($rx_last,$tx_last);
  94 my $on=0;
  95 change($on);
  96
  97 my @history;
  98 sub history($$)
  99 {
 100 my($what,$length)=@_;
 101
 102         my $idx=@history;
 103         while ($length-->0) {
 104                 return if --$idx<0;
 105                 return if $what!=$history[$idx];
 106                 }
 107         return 1;
 108 }
 109
 110 for (;;) {
 111         local *F;
 112         open F,"/proc/net/dev" or die;
 113         my $dev=do { local $/; <F> or die; };
 114         close F or die;
 115         my($rx,$tx)=($dev=~/^\s*$IFDEV:\s*(\d+)(?:\s+\d+){7}\s+(\d+)\s/m) or die;
 116         my $on_now=1;
 117         if (defined $rx_last) {
 118 ###             print(($rx-$rx_last)."\t".($tx-$tx_last)."\n");
 119                 $on_now=0 if ($rx-$rx_last) > $RX_THRESHOLD;
 120                 $on_now=0 if ($tx-$tx_last) > $TX_THRESHOLD;
 121                 }
 122         $rx_last=$rx;
 123         $tx_last=$tx;
 124         push @history,$on_now;
 125         print $on_now;
 126         $on=change(1) if $on==0 && history(1,$STABILIZE_ON);
 127         $on=change(0) if $on==1 && history(0,$STABILIZE_OFF);
 128         sleep $SECS;
 129         }