rdp-helper (3860B)
1 #!/usr/bin/perl 2 3 use strict; 4 use GDBM_File; 5 6 # Global variables and configuration 7 # ---------------------------------- 8 my $log = '/tmp/exthandler.log'; # Debug log, set to /dev/null to suppress 9 my $cdb = '/tmp/client.db'; # GDBM database of clients 10 my %db; # .. and memory representation of it 11 my $timeout = 24*60*60; # Timeout of a connection in secs 12 13 # Logging 14 # ------- 15 sub msg { 16 return if ($log eq '/dev/null' or $log eq ''); 17 open (my $of, ">>$log") or return; 18 print $of (scalar(localtime()), ' ', @_); 19 close ($of); 20 } 21 22 # Reply a back end to the caller and stop processing. 23 # --------------------------------------------------- 24 sub reply ($) { 25 my $b = shift; 26 msg ("Suggesting $b to Crossroads.\n"); 27 print ("$b\n"); 28 exit (0); 29 } 30 31 # Is a value in an array 32 # ---------------------- 33 sub inarray { 34 my $val = shift; 35 for my $other (@_) { 36 return (1) if ($other eq $val); 37 } 38 return (0); 39 } 40 41 # A connection is starting 42 # ------------------------ 43 sub start { 44 my ($ip, $stamp, $backend) = @_; 45 msg ("Logging START of connection for IP $ip on stamp $stamp, ", 46 "back end $backend\n"); 47 $db{$ip} = "$backend:$stamp"; 48 } 49 50 # A connection has ended 51 # ---------------------- 52 sub end { 53 my $ip = shift; 54 msg ("Logging END of connection for IP $ip\n"); 55 $db{$ip} = undef; 56 } 57 58 # A back end has failed 59 # --------------------- 60 sub fail { 61 my $backend = shift; 62 msg ("Back end $backend failed, thanks for notifying me\n"); 63 } 64 65 # Request to determine a back end 66 # ------------------------------- 67 sub dispatch { 68 my $ip = shift; 69 my $stamp = shift; 70 71 msg ("Request to dispatch IP $ip on stamp $stamp\n"); 72 73 # Read the next arguments. They are triplets of 74 # backend-name / availability / weight. Store if the back end is 75 # available. 76 my (@backends, @weights); 77 for (my $i = 0; $i < $#_; $i += 3) { 78 if ($_[$i + 1] != 0) { 79 push (@backends, $_[$i]); 80 push (@weights, $_[$i + 2]); 81 msg ("Candidate back end: $_[$i] with weight ", $_[$i + 2], "\n"); 82 } 83 } 84 85 # See if this is a reconnect by a previously seen client IP. We'll 86 # treat this as a reconnect if the timeout wasn't yet exceeded. 87 if ($db{$ip} ne '') { 88 my ($last_backend, $last_stamp) = split (/:/, $db{$ip}); 89 msg ("IP $ip had last connected on $last_stamp to $last_backend\n"); 90 if ($stamp < $last_stamp + $timeout) { 91 msg ("Timeout not yet exceeded, this may be a reconnect\n"); 92 # We'll allow a reconnect only if the stated last_backend is 93 # free (sanity check). 94 if (inarray ($last_backend, @backends)) { 95 msg ("Last back end $last_backend is available, ", 96 "letting through\n"); 97 reply ($last_backend); 98 } else { 99 msg ("Last used back end isn't free, suggesting a new one\n"); 100 } 101 } else { 102 msg ("Timeout exceeded, suggesting a new back end\n"); 103 } 104 } else { 105 msg ("Np preveious connection data, suggesting a new back end\n"); 106 } 107 108 my $bestweight = -1; 109 my $bestbackend; 110 for (my $i = 0; $i <= $#weights; $i++) { 111 if ($bestweight == -1 or $bestweight > $weights[$i]) { 112 $bestweight = $weights[$i]; 113 $bestbackend = $backends[$i]; 114 } 115 } 116 117 msg ("Best back end: $bestbackend (given weight $bestweight)\n"); 118 reply ($bestbackend); 119 } 120 121 # Main starts here 122 # ---------------- 123 msg ("Start of run, attaching GDBM database '$cdb'\n"); 124 tie (%db, 'GDBM_File', $cdb, &GDBM_WRCREAT, 0600); 125 126 # The first argument must be an action 'dispatch', 'start' or 'end'. 127 # Depending on the action, we do stuff. 128 my $action = shift (@ARGV); 129 if ($action eq 'dispatch') { 130 dispatch (@ARGV); 131 } elsif ($action eq 'start') { 132 start (@ARGV); 133 } elsif ($action eq 'end') { 134 end (@ARGV); 135 } elsif ($action eq 'fail') { 136 fail (@ARGV); 137 } else { 138 print STDERR ("Usage: rdp-helper {dispatch|start|end|fail} args\n"); 139 exit (1); 140 }