#!/usr/bin/perl -w

# VPN-over-DNS perl client v3 2026-11-09 (protocol v3)

# Copyright (c) 2015-2026, Alexandre Fenyo - www.fenyo.net - alex@fenyo.net
# All rights reserved.
#
# Redistribution and use in source and binary forms, with or without
# modification, are permitted provided that the following conditions
# are met:
#
# 1. Redistributions of source code must retain the above copyright
# notice, this list of conditions and the following disclaimer.
#
# 2. Redistributions in binary form must reproduce the above copyright
# notice, this list of conditions and the following disclaimer in the
# documentation and/or other materials provided with the distribution.
#
# THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
# "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
# LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
# FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
# COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
# INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
# BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
# LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
# CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
# LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
# ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
# POSSIBILITY OF SUCH DAMAGE.

############################################################
# Web site      : https://www.vpnoverdns.com
# Protocol      : docs/protocol-v3.md in the server repository
# Support       : support@vpnoverdns.com

############################################################
# BOOTSTRAP WITHOUT INTERNET CONNECTION
# This client only needs Perl (5.10 or later) and its core modules: no Net::DNS, no other module.
# On a site where only DNS works, get it with dig or nslookup:
#   dig perl3.vpnoverdns.com. txt +short | tr '\\' ' ' | xargs csh -c
# or, under csh:
#   set i=0
#   while ( $i < N )     # N: see perl3.vpnoverdns.com
#     dig $i.v3.src.vpnoverdns.com. TXT +short
#     @ i++
#   end | sed -e s/.// -e 's/.$//' | perl -MMIME::Base64 -ne 'print decode_base64($_);' > vpnoverdns3.pl
# Check its SHA-256 against sha256.vpnoverdns.com.

############################################################
# USAGE (see -h)
#   1. get an API token on https://www.vpnoverdns.com (or use the anonymous mode: -A, ssh only, 2 minutes)
#   2. vpnoverdns3.pl -u vod3_xxxxxxxx_yyyy...      (saved in ~/.vpnoverdns3)
#   3. vpnoverdns3.pl -L 2222:my.ssh.server:22      then: ssh -p 2222 user@127.0.0.1
#      or: vpnoverdns3.pl -S my.ssh.server -o "-l user"

use strict;
use Socket;
use IO::Select;
use IO::Handle;
use Time::HiRes qw[ time ];
use Getopt::Long;
use Pod::Usage;
use MIME::Base64;
use Digest::SHA qw[ hmac_sha256 ];
use POSIX ":sys_wait_h";

my $clientversion = "vpnoverdns3.pl/3.0";
my $domain = "tun.vpnoverdns.com";
my $suffix = ".v3.$domain";
my $conffile = ($ENV{HOME} || $ENV{USERPROFILE} || ".") . "/.vpnoverdns3";

# protocol constants (see the server: net.fenyo.vpnoverdns.v3.V3)
my ($KIND_PROBE, $KIND_HELLO, $KIND_AUTH, $KIND_ANON, $KIND_DATA) = (1, 2, 3, 4, 5);
my $FLAG_PACKET = 1;
my ($RC_OK, $RC_BAD_SESSION, $RC_BAD_MAC, $RC_AUTH_FAILED, $RC_DENIED, $RC_BUSY, $RC_BAD_REQUEST, $RC_EXPIRED, $RC_QUOTA) = (0 .. 8);
my @rcnames = ('OK', 'unknown or closed session', 'integrity check failed', 'authentication failed', 'access denied',
               'server busy', 'bad request', 'session expired', 'monthly quota exceeded');
my ($ENC_TXT_RAW, $ENC_TXT_B64, $ENC_AAAA, $ENC_A) = (0, 1, 2, 3);
my @encnames = ('txt-raw', 'txt-b64', 'aaaa', 'a');
my ($F_OPEN, $F_OPEN_OK, $F_OPEN_ERR, $F_DATA, $F_FIN, $F_RST, $F_MSG, $F_BYE, $F_QUOTA) = (1 .. 9);
my @openerrors = ('', 'denied', 'unreachable', 'can not resolve', 'too many streams');
my $WINDOW = 64;

# Avoid zombie processes.
$SIG{CHLD} = 'IGNORE';
$| = 1;

# Default values for general options.
my $optdebug = 0;
my $optverbose = 0;
my $opthelp = 0;
my $optuuid = 0;
my $optanonymous = 0;
my $optglobal = 0;
my $optlocal = 0;
my $optssh = 0;
my $optsshoptions = "";
my $optsshcommand = "";
my $optping = -1;      # -1: -r not given (-r 0 must be rejected, not ignored)
my $optsilent = 0;
my $optinitlistenport = 8081;
my $optresolver = "";
my $optencoding = "auto";
my $optsize = 0;
my $optmaxparallelrequests = 16;
my $optmaxwrite = 0;
my $optmaxtimeout = 3;
# Public resolvers throttle clients that send too many queries (Google: 1500 per second and per address).
my $optrate = 400;

pod2usage 2 if $#ARGV < 0;
Getopt::Long::Configure('bundling');
my $optstatus = GetOptions('debug|d' => \$optdebug, 'verbose|v' => \$optverbose,
                           'help|h' => \$opthelp, 'uuid|u' => \$optuuid,
                           'anonymous|A' => \$optanonymous, 'global|g' => \$optglobal,
                           'local|L' => \$optlocal, 'port|p=i' => \$optinitlistenport,
                           'ssh|S' => \$optssh, 'o|options=s' => \$optsshoptions,
                           'C|command=s' => \$optsshcommand, 'rtt|r=i' => \$optping,
                           'silent|s' => \$optsilent, 'resolver|N=s' => \$optresolver,
                           'encoding|e=s' => \$optencoding, 'size|z=i' => \$optsize,
                           'parallel|P=i' => \$optmaxparallelrequests, 'maxwrite|m=i' => \$optmaxwrite,
                           'maxdelay|a=i' => \$optmaxtimeout, 'rate|q=i' => \$optrate);
pod2usage 2 if !$optstatus;
pod2usage(-exitval => 0, -verbose => 2) if $opthelp;
my $rttgiven = $optping != -1;
$optping = 0 unless $rttgiven;

############################################################
# Small helpers.

sub debug { print STDERR "$$: ", @_, "\n" if $optdebug; }
sub verbose { print STDERR "$$: ", @_, "\n" if $optverbose || $optdebug; }

my @b32 = ('a' .. 'z', '2' .. '7');
my %b32 = map { $b32[$_] => $_ } 0 .. 31;

sub b32($) {
  my $bits = unpack "B*", shift;
  $bits .= "0" x ((5 - length($bits) % 5) % 5);
  return join "", map { $b32[oct "0b$_"] } $bits =~ /(.{5})/g;
}

sub unb32($) {
  my $s = lc shift;
  my $bits = join "", map { die "invalid base32\n" unless exists $b32{$_}; sprintf "%05b", $b32{$_} } split //, $s;
  $bits = substr $bits, 0, length($bits) - length($bits) % 8;
  return pack "B*", $bits;
}

sub randbytes($) {
  my $n = shift;
  my $out = "";
  if (open my $r, '<', '/dev/urandom') { binmode $r; read $r, $out, $n; close $r; }
  $out .= chr int rand 256 while length $out < $n;
  return $out;
}

sub seqdiff($$) { return ((($_[0] - $_[1] + 32768) & 0xffff) - 32768); }

############################################################
# DNS: we build and parse the packets ourselves (no Net::DNS needed).

sub find_resolver() {
  return $optresolver if $optresolver;
  return $ENV{VPNOVERDNS_RESOLVER} if $ENV{VPNOVERDNS_RESOLVER};
  if (open my $rc, '<', '/etc/resolv.conf') {
    while (<$rc>) { return $1 if /^\s*nameserver\s+([0-9a-fA-F.:]+)/; }
  }
  # Windows and others: ask nslookup which server it uses
  my $out = `nslookup localhost 2>&1`;
  return $1 if defined $out && $out =~ /Address(?:es)?:\s*([0-9a-fA-F.:]+)/;
  die "$$: can not find a DNS resolver: use -N address\n";
}

my ($dnssock, $dnsdest);

sub open_dns($) {
  my $resolver = shift;
  if ($resolver =~ /:/) {
    # IPv6 resolver: needs Socket::getaddrinfo (Perl 5.14 and later)
    my ($err, @res) = eval { Socket::getaddrinfo($resolver, 53, { socktype => SOCK_DGRAM }) };
    die "$$: IPv6 resolver $resolver not supported by this Perl: use an IPv4 resolver with -N\n" if $@ || $err || !@res;
    socket $dnssock, $res[0]{family}, SOCK_DGRAM, 0 or die "$$: socket: $!\n";
    $dnsdest = $res[0]{addr};
  } else {
    my $addr = inet_aton($resolver) or die "$$: invalid resolver address $resolver\n";
    socket $dnssock, PF_INET, SOCK_DGRAM, (getprotobyname('udp') || 17) or die "$$: socket: $!\n";
    $dnsdest = sockaddr_in(53, $addr);
  }
  binmode $dnssock;
}

my %qtypes = ($ENC_TXT_RAW => 16, $ENC_TXT_B64 => 16, $ENC_AAAA => 28, $ENC_A => 1);

# DNS query with an EDNS(0) OPT record announcing 1232 bytes.
sub dns_packet($$$) {
  my ($id, $name, $qtype) = @_;
  my $qname = join("", map { chr(length $_) . $_ } split /\./, $name) . "\0";
  return pack("n6", $id, 0x0100, 1, 0, 0, 1) . $qname . pack("n2", $qtype, 1) . "\0" . pack("n2Nn", 41, 1232, 0, 0);
}

sub skip_name($$) {
  my ($buf, $off) = @_;
  while ($off < length $buf) {
    my $len = ord substr $buf, $off, 1;
    return $off + 2 if ($len & 0xc0) == 0xc0;
    return $off + 1 if $len == 0;
    $off += $len + 1;
  }
  return undef;
}

# Returns (id, rcode, truncated, [ [type, rdata], ... ]) or undef.
sub dns_parse($) {
  my $buf = shift;
  return undef if length $buf < 12;
  my ($id, $flags, $qd, $an) = unpack "n4", $buf;
  my $off = 12;
  for (1 .. $qd) { $off = skip_name($buf, $off); return undef unless defined $off; $off += 4; }
  my @rrs;
  for (1 .. $an) {
    $off = skip_name($buf, $off);
    return undef unless defined $off && $off + 10 <= length $buf;
    my ($type, $class, $ttl, $rdlen) = unpack "n2Nn", substr $buf, $off, 10;
    $off += 10;
    return undef if $off + $rdlen > length $buf;
    push @rrs, [ $type, substr $buf, $off, $rdlen ];
    $off += $rdlen;
  }
  return ($id, $flags & 0xf, ($flags & 0x200) ? 1 : 0, \@rrs);
}

# Rebuilds the v3 response string ([len 2][rcode 1][body]) from the answer RRs; returns (rcode, body) or ().
sub v3_payload($$) {
  my ($enc, $rrs) = @_;
  my $s = "";
  if ($enc == $ENC_TXT_RAW || $enc == $ENC_TXT_B64) {
    for my $rr (@$rrs) {
      next unless $rr->[0] == 16;
      my ($rd, $o) = ($rr->[1], 0);
      while ($o < length $rd) { my $l = ord substr $rd, $o, 1; $s .= substr $rd, $o + 1, $l; $o += $l + 1; }
    }
    $s = decode_base64($s) if $enc == $ENC_TXT_B64;
  } else {
    my $type = $enc == $ENC_AAAA ? 28 : 1;
    my %parts;
    for my $rr (@$rrs) { $parts{ord substr $rr->[1], 0, 1} = substr $rr->[1], 1 if $rr->[0] == $type; }
    $s = join "", map { $parts{$_} } sort { $a <=> $b } keys %parts;
  }
  return () if length $s < 3;
  my $len = unpack "n", $s;
  return () if length($s) < 2 + $len;
  return (ord(substr $s, 2, 1), substr $s, 3, $len - 1);
}

# Same computation as the server (V3Answer.capacity): response string bytes that fit in a message.
sub capacity($$$) {
  my ($enc, $questionlen, $max) = @_;
  my $room = $max - 12 - $questionlen - 11;
  my $txt = sub { my $rd = shift; return 0 if $rd <= 1; return $rd - int(($rd + 255) / 256); };
  return $txt->($room - 12) if $enc == $ENC_TXT_RAW;
  return int($txt->($room - 12) / 4) * 3 if $enc == $ENC_TXT_B64;
  my $n = int(($room < 0 ? 0 : $room) / ($enc == $ENC_AAAA ? 28 : 16));
  $n = 256 if $n > 256;
  return $n * ($enc == $ENC_AAAA ? 15 : 3);
}

############################################################
# v3 queries.

my %S = (sid => 0, key => undef, enc => $ENC_TXT_B64, max => 512);
my $qidcounter = int rand 65536;

# Upstream bytes per query: the name is limited to 253 characters.
sub upcapacity() {
  my $avail = 253 - length($suffix) - 22;                # 21 characters of header label + its dot
  my $chars = $avail - int(($avail + 63) / 64);          # one dot per 63-character label
  my $bytes = int($chars * 5 / 8);
  $bytes = $optmaxwrite if $optmaxwrite && $optmaxwrite < $bytes;
  return $bytes;
}

sub v3_name($$) {
  my ($hdr, $data) = @_;
  my $d = b32($data);
  my @labels = $d =~ /(.{1,63})/g;
  return join ".", @labels, b32($hdr) . $suffix;
}

# Header: sid 3, kind 1, qid 2, seq 2, ack 2, mac 3. The mac covers the first 10 bytes and the data.
sub v3_query($$$$$) {
  my ($kind, $flags, $seq, $ack, $data) = @_;
  my $qid = $qidcounter = ($qidcounter + 1) & 0xffff;
  my $h = substr(pack("N", $S{sid}), 1, 3) . chr(($kind << 4) | $flags) . pack("n3", $qid, $seq, $ack);
  my $mac = defined $S{key} && $kind == $KIND_DATA ? substr(hmac_sha256("C" . $h . $data, $S{key}), 0, 3) : "\0\0\0";
  return ($qid, v3_name($h . $mac, $data));
}

my %waiting;     # dns id -> { qid, sent, ... }
sub new_dnsid() { my $id; do { $id = int rand 65536 } while exists $waiting{$id}; return $id; }

sub send_query($$) {
  my ($name, $qtype) = @_;
  my $id = new_dnsid();
  send $dnssock, dns_packet($id, $name, $qtype), 0, $dnsdest;
  debug "query $id: $name";
  return $id;
}

# Synchronous exchange used before the tunnel runs (probe, session setup): returns (rcode, body, msglen) or ().
sub exchange($$$$) {
  my ($name, $enc, $tries, $timeout) = @_;
  for my $try (1 .. $tries) {
    my $id = send_query($name, $qtypes{$enc});
    my $deadline = time + $timeout;
    my $sel = IO::Select->new($dnssock);
    while ((my $left = $deadline - time) > 0) {
      next unless $sel->can_read($left);
      my $buf = "";
      recv $dnssock, $buf, 65535, 0 or next;
      my ($rid, $rcode, $tc, $rrs) = dns_parse($buf);
      next unless defined $rid && $rid == $id;
      my @p = v3_payload($enc, $rrs);
      return (@p, length $buf) if @p;
      last;
    }
    debug "no valid answer, try $try";
  }
  return ();
}

############################################################
# Probe: find the most efficient encoding and size that the resolvers let through.

sub probe() {
  my @candidates;
  for my $size ($optsize ? ($optsize) : (1232, 512)) {
    for my $enc ($ENC_TXT_RAW, $ENC_TXT_B64, $ENC_AAAA, $ENC_A) {
      next if $optencoding ne "auto" && $encnames[$enc] ne $optencoding;
      push @candidates, [ $enc, $size ];
    }
  }
  die "$$: unknown encoding $optencoding\n" unless @candidates;
  # all the probes at once
  my %pending;
  for my $try (1 .. 2) {
    for my $c (@candidates) {
      next if defined $c->[2];
      my ($qid, $name) = v3_query($KIND_PROBE, 0, 0, 0, pack("Cn", $c->[0], $c->[1]));
      my $id = send_query($name, $qtypes{$c->[0]});
      $pending{$id} = $c;
      $c->[3] = length($name) + 2 + 4;   # question length
    }
    my $deadline = time + 2.5;
    my $sel = IO::Select->new($dnssock);
    while ((my $left = $deadline - time) > 0 && grep { !defined $_->[2] } @candidates) {
      next unless $sel->can_read($left);
      my $buf = "";
      recv $dnssock, $buf, 65535, 0 or next;
      my ($rid, $rcode, $tc, $rrs) = dns_parse($buf);
      next unless defined $rid && exists $pending{$rid};
      my $c = delete $pending{$rid};
      my ($rc, $body) = v3_payload($c->[0], $rrs);
      my $ok = 0;
      if (defined $rc && $rc == $RC_OK && length $body >= 2) {
        my $count = unpack "n", $body;
        my $pattern = substr $body, 2;
        my $expected = join "", map { chr($_ & 0xff) } 0 .. $count - 1;
        my $min = capacity($c->[0], $c->[3], $c->[1]) - 3 - 2 - 16;
        $ok = (length $pattern == $count && $pattern eq $expected && $count >= $min) ? 1 : 0;
      }
      $c->[2] = $ok;
      debug "probe $encnames[$c->[0]] $c->[1]: " . ($ok ? "ok" : "failed");
    }
  }
  # best = largest downstream capacity for a poll query
  my $pollq = length(v3_name("x" x 13, "")) + 2 + 4;
  my ($best) = sort { capacity($b->[0], $pollq, $b->[1]) <=> capacity($a->[0], $pollq, $a->[1]) } grep { $_->[2] } @candidates;
  die "$$: no answer from the VPN-over-DNS server through the DNS resolver " . find_resolver() . "\n" unless $best;
  ($S{enc}, $S{max}) = ($best->[0], $best->[1]);
  verbose "encoding $encnames[$S{enc}], messages up to $S{max} bytes";
}

############################################################
# Session setup.

sub get_token() {
  open my $in, '<', $conffile
    or die "$$: can not open file $conffile: $!\nPlease, first launch vpnoverdns3.pl with '-u TOKEN' (API token from https://www.vpnoverdns.com) or with '-A' (anonymous mode: ssh only, limited duration).\n";
  my $t = <$in>;
  close $in;
  die "$$: $conffile is empty\n" unless defined $t;
  chomp $t;
  $t =~ s/\s+//g;
  return $t;
}

sub save_token($) {
  my $t = shift;
  die "$$: invalid token (expected: vod3_xxxxxxxx_ followed by 52 characters, or 'anonymous')\n"
    unless $t eq 'anonymous' || $t =~ /^vod3_[a-z2-7]{8}_[a-z2-7]{52}$/;
  open my $out, '>', $conffile or die "$$: can not open file $conffile: $!";
  print $out "$t\n" or die "$$: can not write file $conffile: $!";
  close $out or die "$$: can not close file $conffile: $!";
  chmod 0600, $conffile;
}

my $sessionlifetime = 0;

sub open_session($) {
  my $token = shift;
  my $nc = randbytes(8);
  my $sw = $clientversion . " perl/$]";
  if ($token eq 'anonymous') {
    my (undef, $name) = v3_query($KIND_ANON, 0, 0, 0, $nc . pack("Cnn", $S{enc}, $S{max}, 0) . $sw);
    my ($rc, $body) = exchange($name, $S{enc}, 4, $optmaxtimeout);
    die "$$: no answer to the session request\n" unless defined $rc;
    die "$$: anonymous session refused: $rcnames[$rc]\n" unless $rc == $RC_OK && length $body >= 13;
    $S{sid} = unpack "N", "\0" . substr $body, 0, 3;
    my $ns = substr $body, 3, 8;
    $sessionlifetime = unpack "n", substr $body, 11, 2;
    $S{key} = hmac_sha256("key" . substr($body, 0, 3) . $nc . $ns, "vpnoverdns-v3-anonymous");
    print "anonymous session: ssh (port 22) only, closed by the server after $sessionlifetime seconds\n";
    print "message from server: ", substr($body, 13), "\n" if length $body > 13;
    return;
  }
  my ($id, $secret) = $token =~ /^vod3_([a-z2-7]{8})_([a-z2-7]{52})$/ or die "$$: invalid token in $conffile\n";
  my $kt = hmac_sha256("vpnoverdns-v3-token", unb32($secret));
  my (undef, $name) = v3_query($KIND_HELLO, 0, 0, 0, unb32($id) . $nc . pack("Cnn", $S{enc}, $S{max}, 0) . $sw);
  my ($rc, $body) = exchange($name, $S{enc}, 4, $optmaxtimeout);
  die "$$: no answer to the session request\n" unless defined $rc;
  die "$$: session refused: $rcnames[$rc]\n" unless $rc == $RC_OK && length $body >= 11;
  my $sid3 = substr $body, 0, 3;
  my $ns = substr $body, 3, 8;
  $S{sid} = unpack "N", "\0" . $sid3;
  my (undef, $aname) = v3_query($KIND_AUTH, 0, 0, 0, substr(hmac_sha256("auth" . $sid3 . $nc . $ns, $kt), 0, 16));
  ($rc, $body) = exchange($aname, $S{enc}, 4, $optmaxtimeout);
  die "$$: no answer to the authentication request\n" unless defined $rc;
  die "$$: authentication failed: $rcnames[$rc]\n" unless $rc == $RC_OK && length $body >= 17;
  die "$$: the server could not prove its identity\n"
    unless substr($body, 0, 16) eq substr(hmac_sha256("srv" . $sid3 . $nc . $ns, $kt), 0, 16);
  $S{key} = hmac_sha256("key" . $sid3 . $nc . $ns, $kt);
  my $nports = ord substr $body, 16, 1;
  my @ports = unpack "n*", substr $body, 17, 2 * $nports;
  verbose "session $S{sid} opened, allowed destination ports: @ports";
  my $motd = substr $body, 17 + 2 * $nports;
  print "message from server: $motd\n" if length $motd;
}

############################################################
# Tunnel: reliable transport and stream multiplexing.

my @listeners;           # { sock, host, port }
my %streams;             # id -> { sock, state: opening|open, out, finrecv, finsent }
my %bysock;              # fileno -> stream id
my $nextstream = 1;
my $muxout = "";         # frames waiting to be packetized
my $muxin = "";          # received bytes not yet parsed into frames
my @up;                  # unacknowledged upstream packets: { seq, data, sent, inflight }
my $upnext = 1;
my $downlast = 0;        # last downstream packet received in sequence
my %downbuf;
my $srtt = 0.3;
my $lastactivity = 0;
my $lastpoll = 0;
my ($ratebudget, $ratetime) = (0, 0);   # token bucket limiting the queries per second
my $running = 1;
my $leaving = 0;
my $sel;                 # IO::Select of the tunnel loop
my ($bytesup, $bytesdown) = (0, 0);

sub frame($$$) { my ($type, $id, $data) = @_; return pack("Cnn", $type, $id, length $data) . $data; }

sub close_stream($) {
  my $id = shift;
  my $st = delete $streams{$id} or return;
  delete $bysock{fileno $st->{sock}};
  $sel->remove($st->{sock}) if $sel;
  close $st->{sock};
  verbose "stream $id closed";
}

sub handle_frame($$$) {
  my ($type, $id, $data) = @_;
  my $st = $streams{$id};
  if ($type == $F_OPEN_OK) {
    return unless $st;
    $st->{state} = 'open';
    $sel->add($st->{sock});          # read the local connection only once the remote one is established
    verbose "stream $id connected";
  } elsif ($type == $F_OPEN_ERR) {
    my $code = ord substr($data, 0, 1);
    print STDERR "$$: connection refused by the server: ", ($openerrors[$code] || "error"), " (", substr($data, 1), ")\n";
    close_stream($id);
  } elsif ($type == $F_DATA) {
    if ($st) { $st->{out} .= $data; } else { $muxout .= frame($F_RST, $id, ""); }
  } elsif ($type == $F_FIN) {
    return unless $st;
    $st->{finrecv} = 1;
  } elsif ($type == $F_RST) {
    close_stream($id);
  } elsif ($type == $F_MSG) {
    print "message from server: $data\n";
  } elsif ($type == $F_QUOTA && length $data >= 16) {
    # [used 8][quota 8], 64-bit big-endian; two 32-bit halves so that 32-bit Perls without 64-bit integers work
    my ($uh, $ul, $qh, $ql) = unpack "N4", $data;
    verbose sprintf "monthly traffic: %.1f MB of %.1f MB", ($uh * 4294967296 + $ul) / 1e6, ($qh * 4294967296 + $ql) / 1e6;
  } elsif ($type == $F_BYE) {
    print "session closed by the server: $data\n";
    $running = 0;
  }
}

sub parse_frames() {
  while (length $muxin >= 5) {
    my ($type, $id, $len) = unpack "Cnn", $muxin;
    last if length $muxin < 5 + $len;
    my $data = substr $muxin, 5, $len;
    substr($muxin, 0, 5 + $len) = "";
    handle_frame($type, $id, $data);
  }
}

sub handle_answer($$) {
  my ($q, $buf) = @_;
  my ($rid, $dnsrcode, $tc, $rrs) = dns_parse($buf);
  my ($rc, $body) = v3_payload($S{enc}, $rrs);
  return unless defined $rc;
  # the session is over on the server side: say it once, and no BYE afterwards
  if ($rc == $RC_EXPIRED || $rc == $RC_BAD_SESSION) {
    if (defined $S{key}) {
      if ($rc == $RC_EXPIRED) { print "session expired", ($sessionlifetime ? " (anonymous sessions last $sessionlifetime seconds)" : ""), "\n"; }
      elsif (!$leaving) { print STDERR "$$: the server closed the session\n"; }
    }
    $S{key} = undef;
    $running = 0;
    return;
  }
  if ($rc != $RC_OK) { debug "answer: $rcnames[$rc]"; return; }
  return if length $body < 8 || !defined $S{key};
  my ($mac, $rest) = (substr($body, 0, 3), substr($body, 3));
  if ($mac ne substr(hmac_sha256("S" . pack("n", $q->{qid}) . chr($RC_OK) . $rest, $S{key}), 0, 3)) {
    debug "bad mac in answer";
    return;
  }
  my ($dseq, $ack, $flags) = unpack "nnC", $rest;
  my $data = substr $rest, 5;
  debug sprintf "answer qid %d: ack %d, %s, %d inflight, %d unacked up, downlast %d", $q->{qid}, $ack,
    ($flags & $FLAG_PACKET) ? "packet $dseq (" . length($data) . " bytes)" : "no packet", scalar(keys %waiting), scalar(@up), $downlast;
  # acknowledged upstream packets
  while (@up && seqdiff($ack, $up[0]{seq}) >= 0 && seqdiff($ack, $up[0]{seq}) < 4 * $WINDOW) { shift @up; }
  if ($flags & $FLAG_PACKET) {
    my $d = seqdiff($dseq, $downlast);
    if ($d > 0 && $d <= 2 * $WINDOW) {
      $downbuf{$dseq} = $data;
      while (exists $downbuf{($downlast + 1) & 0xffff}) {
        $downlast = ($downlast + 1) & 0xffff;
        my $chunk = delete $downbuf{$downlast};
        $muxin .= $chunk;
        $bytesdown += length $chunk;
      }
      $lastactivity = time;
      parse_frames();
    }
  }
}

# Sends the queries the tunnel needs: retransmissions, new packets, then polls.
sub pump_queries() {
  my $now = time;
  my $rto = 2 * $srtt + 0.1; $rto = 0.3 if $rto < 0.3; $rto = 5 if $rto > 5;
  my $busy = $now - $lastactivity < 1.5 || length $muxout || grep { !$_->{inflight} } @up;
  my $target = $busy ? $optmaxparallelrequests : 1;
  my $cap = upcapacity();
  $ratebudget += ($now - $ratetime) * $optrate;
  $ratebudget = $optrate / 20 if $ratebudget > $optrate / 20;   # bursts of 50 ms at most
  $ratetime = $now;
  while (keys(%waiting) < $target && $ratebudget >= 1) {
    $ratebudget--;
    my $pkt;
    for my $p (@up) {
      if (!$p->{inflight} && (!$p->{sent} || $now - $p->{sent} > $rto)) { $pkt = $p; last; }
    }
    if (!$pkt && length $muxout && @up < $WINDOW) {
      $pkt = { seq => $upnext, data => substr($muxout, 0, $cap), sent => 0, inflight => 0 };
      substr($muxout, 0, length $pkt->{data}) = "";
      $upnext = ($upnext + 1) & 0xffff;
      push @up, $pkt;
      $bytesup += length $pkt->{data};
    }
    if (!$pkt) {
      # poll; when idle, one at a time and not more than 5 per second
      last if !$busy && ($now - $lastpoll < 0.2);
      $lastpoll = $now;
    }
    my ($qid, $name) = $pkt ? v3_query($KIND_DATA, $FLAG_PACKET, $pkt->{seq}, $downlast, $pkt->{data})
                            : v3_query($KIND_DATA, 0, 0, $downlast, "");
    my $id = send_query($name, $qtypes{$S{enc}});
    $waiting{$id} = { qid => $qid, sent => $now, pkt => $pkt };
    if ($pkt) { $pkt->{sent} = $now; $pkt->{inflight} = 1; }
    $lastactivity = $now if $pkt;
  }
}

sub add_listener($) {
  my $spec = shift;
  # [bind_address:]port:host:hostport, host may be an IPv6 address between brackets (as with ssh)
  my ($bind, $port, $host, $hostport) = $spec =~ /^(?:([0-9.]+):)?(\d+):(\[[0-9a-fA-F:.]+\]|[^:\[\]]+):(\d+)$/
    or pod2usage 2;
  $host =~ s/^\[(.*)\]$/$1/;
  my $bindaddr = $optglobal ? INADDR_ANY : INADDR_LOOPBACK;
  if (defined $bind) { $bindaddr = inet_aton($bind) or die "$$: invalid address in $spec\n"; }
  my $sock;
  socket $sock, PF_INET, SOCK_STREAM, (getprotobyname('tcp') || 6) or die "$$: socket: $!";
  setsockopt $sock, SOL_SOCKET, SO_REUSEADDR, 1 or die "$$: setsockopt: $!";
  bind $sock, sockaddr_in($port, $bindaddr) or die "$$: bind on port $port: $!\n";
  listen $sock, SOMAXCONN or die "$$: listen: $!";
  push @listeners, { sock => $sock, host => $host, port => $hostport };
  verbose "listening on port $port, forwarded to $host:$hostport";
}

sub run_tunnel(;$) {
  my $child = shift;
  $sel = IO::Select->new($dnssock);
  $sel->add($_->{sock}) for @listeners;
  local $SIG{INT} = local $SIG{TERM} = sub { $running = 0; };
  while ($running) {
    pump_queries();
    my @rd = $sel->can_read(0.02);
    for my $fh (@rd) {
      if ($fh == $dnssock) {
        my $buf = "";
        recv $dnssock, $buf, 65535, 0 or next;
        my $rid = unpack "n", $buf;
        my $q = delete $waiting{$rid} or next;
        $q->{pkt}{inflight} = 0 if $q->{pkt};
        my $rtt = time - $q->{sent};
        $srtt = 0.875 * $srtt + 0.125 * $rtt;
        handle_answer($q, $buf);
        next;
      }
      my ($l) = grep { $_->{sock} == $fh } @listeners;
      if ($l) {
        my $client;
        accept $client, $fh or next;
        binmode $client;
        $client->autoflush(1);
        my $id = $nextstream;
        do { $id = ($id % 65535) + 1 } while exists $streams{$id};
        $nextstream = $id;
        $streams{$id} = { sock => $client, state => 'opening', out => "", finrecv => 0, finsent => 0 };
        $bysock{fileno $client} = $id;
        $muxout .= frame($F_OPEN, $id, pack("n", $l->{port}) . $l->{host});
        $lastactivity = time;
        verbose "new local connection: stream $id to $l->{host}:$l->{port}";
        next;
      }
      my $fn = fileno $fh;
      next unless defined $fn;                      # closed earlier in this iteration
      my $id = $bysock{$fn};
      my $st = defined $id ? $streams{$id} : undef;
      if (!$st) { $sel->remove($fh); next; }
      next unless $st->{state} eq 'open' && !$st->{finsent} && length $muxout < 65536;
      my $data;
      my $n = sysread $fh, $data, 8192;
      if (!$n) {
        $muxout .= frame($F_FIN, $id, "");
        $st->{finsent} = 1;
        $sel->remove($fh);
      } else {
        $muxout .= frame($F_DATA, $id, $data);
        $lastactivity = time;
      }
    }
    # data for the local connections
    for my $id (keys %streams) {
      my $st = $streams{$id};
      if (length $st->{out}) {
        my $n = syswrite $st->{sock}, $st->{out}, 16384;
        if (!defined $n) { $muxout .= frame($F_RST, $id, ""); $sel->remove($st->{sock}); close_stream($id); next; }
        substr($st->{out}, 0, $n) = "";
      }
      if ($st->{finrecv} && !length $st->{out}) {
        if ($st->{finsent}) { close_stream($id); }
        elsif (!$st->{shut}) { shutdown $st->{sock}, 1; $st->{shut} = 1; }
      }
    }
    # lost queries: a lost query must not hold a slot for long (4 smoothed RTTs, at least 0.4 s)
    my $now = time;
    my $lost = 4 * $srtt; $lost = 0.4 if $lost < 0.4; $lost = $optmaxtimeout if $lost > $optmaxtimeout;
    for my $id (keys %waiting) {
      next if $now - $waiting{$id}{sent} < $lost;
      my $q = delete $waiting{$id};
      $q->{pkt}{inflight} = 0 if $q->{pkt};
      debug "query $id lost";
    }
    if (defined $child && waitpid($child, WNOHANG) == $child) { $running = 0; }
  }
  # tell the server we leave (best effort)
  $leaving = 1;
  if ($S{key}) {
    $muxout .= frame($F_BYE, 0, "");
    my $end = time + 1.5;
    while (time < $end && defined $S{key} && (length $muxout || @up)) {
      pump_queries();
      my @rd = IO::Select->new($dnssock)->can_read(0.05);
      if (@rd) {
        my $buf = "";
        recv $dnssock, $buf, 65535, 0 or next;
        my $q = delete $waiting{unpack "n", $buf} or next;
        $q->{pkt}{inflight} = 0 if $q->{pkt};
        handle_answer($q, $buf);
      }
    }
  }
  verbose "tunnel closed: $bytesup bytes sent, $bytesdown bytes received";
}

############################################################
# Round-trip time test (no session needed).

sub checkrtt($) {
  my $count = shift;
  my ($ok, $total) = (0, 0);
  my %pending;
  my $sel = IO::Select->new($dnssock);
  my $sent = 0;
  while ($sent < $count || keys %pending) {
    while ($sent < $count && keys(%pending) < $optmaxparallelrequests) {
      my (undef, $name) = v3_query($KIND_PROBE, 0, 0, 0, pack("Cn", $S{enc}, 512));
      my $id = send_query($name, $qtypes{$S{enc}});
      $pending{$id} = time;
      $sent++;
    }
    if ($sel->can_read(0.05)) {
      my $buf = "";
      recv $dnssock, $buf, 65535, 0;
      my $id = unpack "n", $buf;
      if (exists $pending{$id}) { $total += time - delete $pending{$id}; $ok++; }
    }
    for my $id (keys %pending) { delete $pending{$id} if time - $pending{$id} > $optmaxtimeout; }
  }
  printf "%d: failed requests: %d / %d (%d%%)\n", $$, $count - $ok, $count, 100 * ($count - $ok) / $count;
  printf "%d: average rtt for non failed requests: %.3f s\n", $$, $ok ? $total / $ok : 0;
}

############################################################
# Process command line parameters and options.

# Everything is checked here, before any network access: a wrong combination must never be silently ignored
# nor fail later with an obscure error. Matrix tested by tools/test-perl-options.sh.
sub usage_error($) { print STDERR "$$: ", shift, "\n(see '$0 -h')\n"; exit 2; }

# -A alone saves the anonymous mode; -A with -L or -S uses it for this run only.
my $nmodes = $optuuid + $optlocal + $optssh + ($rttgiven ? 1 : 0) + ($optanonymous && !$optlocal && !$optssh ? 1 : 0);
usage_error "need one parameter among -u, -A, -L, -S and -r (-A may be combined with -L or -S)" if $nmodes == 0;
usage_error "need only one parameter among -u, -A, -L, -S and -r (-A may be combined with -L or -S)" if $nmodes > 1;

my $runs_tunnel = $optlocal || $optssh;
usage_error "-g only applies to -L" if $optglobal && !$optlocal;
usage_error "-o and -C only apply to -S" if ($optsshoptions ne "" || $optsshcommand ne "") && !$optssh;
usage_error "-p only applies to -S" if $optinitlistenport != 8081 && !$optssh;
usage_error "-s, -N, -e, -z, -P, -m, -a and -q do not apply to -u or -A alone (nothing is sent)"
  if ($optuuid || ($optanonymous && !$runs_tunnel))
     && ($optsilent || $optresolver ne "" || $optencoding ne "auto" || $optsize || $optmaxparallelrequests != 16
         || $optmaxwrite || $optmaxtimeout != 3 || $optrate != 400);
usage_error "-e, -z and -m do not apply to -r" if $rttgiven && ($optencoding ne "auto" || $optsize || $optmaxwrite);

usage_error "-r needs a number of requests between 1 and 10000" if $rttgiven && ($optping < 1 || $optping > 10000);
usage_error "-p needs a port between 1 and 65535" if $optinitlistenport < 1 || $optinitlistenport > 65535;
usage_error "unknown encoding '$optencoding' (auto, txt-raw, txt-b64, aaaa or a)"
  unless grep { $_ eq $optencoding } "auto", "txt-raw", "txt-b64", "aaaa", "a";
usage_error "-z needs a size between 512 and 4096" if $optsize && ($optsize < 512 || $optsize > 4096);
usage_error "-P needs a value between 1 and 256" if $optmaxparallelrequests < 1 || $optmaxparallelrequests > 256;
usage_error "-m needs a positive value" if $optmaxwrite < 0;
usage_error "-a needs a value between 1 and 60 seconds" if $optmaxtimeout < 1 || $optmaxtimeout > 60;
usage_error "-q needs a value between 1 and 100000" if $optrate < 1 || $optrate > 100000;
$optmaxparallelrequests = 4 if $optsilent && $optmaxparallelrequests > 4;
usage_error "-N needs the IP address of a DNS resolver" if $optresolver ne "" && $optresolver !~ /^[0-9a-fA-F.:]+$/;

# arguments of each mode
usage_error "-u needs exactly one argument: the API token" if $optuuid && @ARGV != 1;
usage_error "invalid token '$ARGV[0]' (expected: vod3_xxxxxxxx_ followed by 52 characters, from https://www.vpnoverdns.com)"
  if $optuuid && $ARGV[0] !~ /^\s*vod3_[a-z2-7]{8}_[a-z2-7]{52}\s*$/;
usage_error "-A alone takes no argument" if $optanonymous && !$runs_tunnel && @ARGV;
usage_error "-r takes no argument besides its number" if $rttgiven && @ARGV;
usage_error "-S needs exactly one argument: the ssh server" if $optssh && @ARGV != 1;
usage_error "invalid host name '$ARGV[0]'" if $optssh && $ARGV[0] !~ /^(?:[A-Za-z0-9_.-]+|\[?[0-9a-fA-F:.]+\]?)$/;
usage_error "-L needs at least one [bind_address:]port:host:hostport" if $optlocal && !@ARGV;
my $LSPEC = qr/^(?:([0-9.]+):)?(\d+):(\[[0-9a-fA-F:.]+\]|[^:\[\]\s]+):(\d+)$/;
if ($optlocal) {
  my %seen;
  for my $spec (@ARGV) {
    my ($bind, $port, $host, $hostport) = $spec =~ $LSPEC or usage_error "invalid forwarding '$spec': expected [bind_address:]port:host:hostport";
    usage_error "invalid port in '$spec'" if $port < 1 || $port > 65535 || $hostport < 1 || $hostport > 65535;
    usage_error "invalid bind address in '$spec'" if defined $bind && !inet_aton($bind);
    usage_error "local port $port given twice" if $seen{$port}++;
    usage_error "the anonymous mode only allows port 22 ('$spec')" if $optanonymous && $hostport != 22;
  }
}

if ($optuuid) {
  pod2usage 2 if $#ARGV != 0;
  save_token $ARGV[0];
  print "token saved in $conffile\n";
  exit 0;
}

if ($optanonymous && !$optlocal && !$optssh) {
  pod2usage 2 if $#ARGV != -1;
  save_token 'anonymous';
  print "anonymous mode saved in $conffile: ssh (port 22) only, sessions limited to 2 minutes\n";
  exit 0;
}

my $resolver = find_resolver();
verbose "DNS resolver: $resolver";
open_dns($resolver);

if ($optping) {
  pod2usage 2 if $#ARGV != -1;
  $S{enc} = $ENC_TXT_B64;
  checkrtt $optping;
  exit 0;
}

my $token = $optanonymous ? 'anonymous' : get_token();
if ($token eq 'anonymous' && $optlocal) {
  for (@ARGV) { usage_error "anonymous mode saved in $conffile: only port 22 is allowed ('$_')" if /:(\d+)$/ && $1 != 22; }
}
probe();
open_session($token);

if ($optlocal) {
  pod2usage 2 if $#ARGV < 0;
  add_listener $_ for @ARGV;
  print "tunnel ready\n";
  run_tunnel();
  exit 0;
}

if ($optssh) {
  pod2usage 2 if $#ARGV != 0;
  add_listener "$optinitlistenport:$ARGV[0]:22";
  my $pid = fork;
  die "$$: can not fork: $!\n" unless defined $pid;
  if (!$pid) {
    exec "ssh -p $optinitlistenport -o HostKeyAlias=$ARGV[0] $optsshoptions 127.0.0.1 $optsshcommand" or die "$$: can not launch ssh\n";
  }
  local $SIG{CHLD} = 'DEFAULT';
  run_tunnel($pid);
  exit 0;
}

__END__

=head1 NAME

vpnoverdns3.pl - Perl client for the VPN-over-DNS service (protocol v3)
                 at https://www.vpnoverdns.com
                 version 3.0

=head1 SYNOPSIS

 vpnoverdns3.pl [-dv]                    -u token
 vpnoverdns3.pl [-dv]                    -A
 vpnoverdns3.pl [-dvsgA] [NUMERIC_OPTS] -L [bind_address:]port:host:hostport [...]
 vpnoverdns3.pl [-dvsA]  [NUMERIC_OPTS] -S host [-o ssh_options] [-C command]
 vpnoverdns3.pl [-dv]    [NUMERIC_OPTS] -r NUM
 vpnoverdns3.pl -h

Only needs Perl 5.10 or later and its core modules.

 General parameters and options:
  --help          -h     displays this help text
  --debug         -d     debug protocol
  --verbose       -v     verbose output
  --silent        -s     at most 4 parallel requests (lower throughput, less noise)
  --uuid TOKEN    -u     saves the API token given by https://www.vpnoverdns.com,
                         call it once at first use
  --anonymous     -A     uses the anonymous mode: ssh (port 22) only, the server
                         closes the session after 2 minutes; alone, saves this
                         mode as default; with -L or -S, for this run only
  --local         -L     forwards the given local port to host:hostport on the
                         remote side, same meaning as -L with SSH(1); may be
                         given several times
  --global        -g     allows remote hosts to connect to local forwarded
                         ports - same meaning as -g with SSH(1)
  --ssh           -S     connects to the ssh server of a remote host through
                         the tunnel
  --options       -o     ssh command options, ex.: -S myhost -o "-l root"
  --command       -C     optional ssh remote command, ex.: -S myhost -C date
  --rtt NUM       -r NUM checks the round-trip time with NUM requests
  --port NUM      -p NUM local port used by -S (default 8081)
  --resolver IP   -N IP  DNS resolver to use (default: the system one, from
                         /etc/resolv.conf or nslookup)

 Numeric sub options:
  --encoding ENC  -e ENC answer encoding: auto (default), txt-raw, txt-b64,
                         aaaa, a
  --size NUM      -z NUM maximum DNS message size: 512 or 1232 (default: probed)
  --parallel NUM  -P NUM maximum number of parallel requests (default 16)
  --maxwrite NUM  -m NUM maximum byte count sent in one request (default 128)
  --maxdelay NUM  -a NUM seconds before a request is considered lost (default 3)
  --rate NUM      -q NUM maximum number of requests per second (default 400);
                         public resolvers throttle clients that exceed their
                         limits

=head1 AUTHOR

Alexandre Fenyo <support@vpnoverdns.com> - https://www.fenyo.fr