← Back to branch summary

~ubuntu-branches/ubuntu/wily/libio-socket-ssl-perl/wily-proposed

« back to all changes in this revision

Viewing changes to util/analyze-ssl.pl

  • Committer: Package Import Robot
  • Author(s): Salvatore Bonaccorso
  • Date: 2015-04-28 18:31:55 UTC
  • mfrom: (47.1.12 experimental)
  • Revision ID: package-import@ubuntu.com-20150428183155-k743ul0fe37qqp2f
Tags: 2.012-2
Upload to unstable

Show diffs side-by-side

added added

removed removed

Lines of Context:
util/analyze-ssl.pl
1
 
use strict;
2
 
use warnings;
3
 
use Socket;
4
 
use IO::Socket::SSL 1.984;
5
 
use IO::Socket::SSL::Utils;
6
 
use Getopt::Long qw(:config posix_default bundling);
7
 
 
8
 
 
9
 
my $can_ocsp = IO::Socket::SSL->can_ocsp;
10
 
my $ocsp_cache = $can_ocsp && IO::Socket::SSL::OCSP_Cache->new;
11
 
 
12
 
my %starttls = (
13
 
    ''  => [ 443,undef, 'http' ],
14
 
    'smtp' => [ 25, \&smtp_starttls, 'smtp' ],
15
 
    'http_proxy' => [ 443, \&http_connect,' http' ],
16
 
    'http_upgrade' => [ 80, \&http_upgrade,'http' ],
17
 
    'imap' => [ 143, \&imap_starttls,'imap' ],
18
 
    'pop'  => [ 110, \&pop_stls,'pop3' ],
19
 
    'ftp'  => [ 21, \&ftp_auth,'ftp' ],
20
 
    'postgresql'  => [ 5432, \&postgresql_init,'default' ],
21
 
);
22
 
 
23
 
my $verbose = 0;
24
 
my $timeout = 10;
25
 
my ($stls,$stls_arg);
26
 
my $capath;
27
 
my $all_ciphers;
28
 
my $show_chain;
29
 
my $dump_chain;
30
 
my %conf;
31
 
GetOptions(
32
 
    'h|help' => sub { usage() },
33
 
    'v|verbose:1' => \$verbose,
34
 
    'd|debug:1' => \$IO::Socket::SSL::DEBUG,
35
 
    'T|timeout=i' => \$timeout,
36
 
    'CApath=s' => \$capath,
37
 
    'show-chain' => \$show_chain,
38
 
    'dump-chain' => \$dump_chain,
39
 
    'all-ciphers' => \$all_ciphers,
40
 
    'starttls=s' => sub {
41
 
        ($stls,$stls_arg) = $_[1] =~m{^(\w+)(?::(.*))?$};
42
 
        usage("invalid starttls $stls") if ! $starttls{$stls};
43
 
    },
44
 
    'cert=s' => \$conf{SSL_cert_file},
45
 
    'key=s'  => \$conf{SSL_key_file},
46
 
    'name=s' => \$conf{SSL_hostname},
47
 
) or usage("bad usage");
48
 
@ARGV or usage("no hosts given");
49
 
my %default_ca =
50
 
    ! $capath ? () :
51
 
    -d $capath ? ( SSL_ca_path => $capath, SSL_ca_file => '' ) :
52
 
    -f $capath ? ( SSL_ca_file => $capath, SSL_ca_path => '' ) :
53
 
    die "no such file or dir: $capath";
54
 
die "need Net::SSLeay>=1.58 for showing chain" if $show_chain
55
 
    && ! defined &IO::Socket::SSL::peer_certificates;
56
 
 
57
 
$conf{SSL_verifycn_name} ||= $conf{SSL_hostname} if $conf{SSL_hostname};
58
 
if ($conf{SSL_cert_file}) {
59
 
    $conf{SSL_key_file} ||= $conf{SSL_cert_file};
60
 
    $conf{SSL_use_cert} = 1;
61
 
}
62
 
 
63
 
 
64
 
sub usage {
65
 
    print STDERR "ERROR: @_\n" if @_;
66
 
    print STDERR <<USAGE;
67
 
 
68
 
Analyze SSL connectivity for problems.
69
 
Usage: $0 [options] (host|host:port)+
70
 
Options:
71
 
  -h|--help              - this screen
72
 
  -d|--debug level       - IO::Socket::SSL/Net::SSLeay debugging
73
 
 
74
 
  # how to connect
75
 
  --starttls proto[:arg] - start plain and upgrade to SSL with starttls protocol
76
 
                           (imap,smtp,http_upgrade,http_proxy,pop,ftp,postgresql)
77
 
  -T|--timeout T         - use timeout (default 10)
78
 
 
79
 
  # SSL specific settings
80
 
  --CApath file|dir      - use given dir|file instead of system default CA store
81
 
  --cert cert            - use given certificate for client authentication
82
 
  --key  key             - use given key for client authentication (default: cert)
83
 
  --name name            - use given name as server name in verification and SNI 
84
 
                           instead of host (useful if target is given as IP)
85
 
 
86
 
  # what to show
87
 
  -v|--verbose level     - verbose output
88
 
  --all-ciphers          - find out all supported ciphers
89
 
  --show-chain           - show certificate chain
90
 
  --dump_chain           - dump certificate chain, e.g. all certificates as PEM
91
 
 
92
 
Examples:
93
 
 
94
 
  $0 --show-chain --all-ciphers -v3 www.live.com:443
95
 
  $0 --starttls http_proxy:proxy_host:proxy_port www.live.com:443
96
 
  $0 --starttls imap mail.gmx.de
97
 
 
98
 
USAGE
99
 
    exit(2);
100
 
}
101
 
 
102
 
 
103
 
 
104
 
my @tests;
105
 
for my $host (@ARGV) {
106
 
    my ($ip,$port);
107
 
    $host =~m{^(?:\[(.+)\]|([^:]+))(?::(\w+))?$} or die "invalid dst: $host";
108
 
    $host = $1||$2;
109
 
    my $st = $starttls{$stls ||''};
110
 
    $port = $3 || $st->[0] || 443;
111
 
    if ( $host =~m{:|^[\d\.]+$} ) {
112
 
        $ip = $host;
113
 
        $host = undef;
114
 
    }
115
 
    push @tests, [ $host||$ip,$port,$conf{SSL_hostname}||$host,$st->[1],$st->[2] || 'default' ];
116
 
}
117
 
 
118
 
my $ioclass = IO::Socket::SSL->can_ipv6 || 'IO::Socket::INET';
119
 
for my $test (@tests) {
120
 
    my ($host,$port,$name,$stls_sub,$scheme) = @$test;
121
 
    VERBOSE(1,"checking host=$host port=$port".
122
 
        ($stls ? " starttls=$stls":""));
123
 
 
124
 
    my $tcp_connect = sub {
125
 
        my $tries = shift || 1;
126
 
        my ($cl,$error);
127
 
        my %ioargs = (
128
 
            PeerAddr => $host,
129
 
            PeerPort => $port,
130
 
            Timeout => $timeout,
131
 
        );
132
 
        for(1..$tries) {
133
 
            if ($stls_sub) {
134
 
                last if $cl = eval { $stls_sub->(\%ioargs,$stls_arg) };
135
 
                $error = $@ || 'starttls error';
136
 
                $cl = undef;
137
 
            } elsif ( $cl = $ioclass->new(%ioargs)) {
138
 
                last;
139
 
            } else {
140
 
                $error = "tcp connect: $!";
141
 
            }
142
 
        }
143
 
        $cl or die $error;
144
 
    };
145
 
 
146
 
    my @problems;
147
 
 
148
 
    # basic connects without verification or any TLS extensions (OCSP)
149
 
    # find out usable version and ciphers. Because some hosts (like cloudflare)
150
 
    # behave differently if SNI is used we try to use it and only fall back if
151
 
    # it fails.
152
 
    my ($use_version,$version,$cipher);
153
 
    my $sni = $name;
154
 
    BASE: for my $v (qw(
155
 
        SSLv23:!TLSv1_2:!TLSv1_1:!TLSv1
156
 
        SSLv23:!TLSv1_2:!TLSv1_1
157
 
        SSLv23:!TLSv1_2
158
 
        SSLv23
159
 
    )) {
160
 
        for my $ciphers ( '','HIGH:ALL' ) {
161
 
            my $cl = &$tcp_connect;
162
 
            if ( IO::Socket::SSL->start_SSL($cl,
163
 
                %conf,
164
 
                SSL_version => $v,
165
 
                SSL_verify_mode => 0,
166
 
                SSL_hostname => $sni,
167
 
                SSL_cipher_list => $ciphers,
168
 
            )) {
169
 
                $use_version = $v;
170
 
                $version = $cl->get_sslversion();
171
 
                $cipher = $cl->get_cipher();
172
 
                VERBOSE(2,"version $v no verification, ciphers=$ciphers, no TLS extensions -> $version,$cipher");
173
 
            } else {
174
 
                VERBOSE(2,"version $v, no verification, ciphers=$ciphers, no TLS extensions -> FAIL! $SSL_ERROR");
175
 
                if ( ! $ciphers && $v eq 'SSLv23' ) {
176
 
                    push @problems, "using default SSL_version $v, default ciphers -> $SSL_ERROR";
177
 
                } elsif ( ! $ciphers ) {
178
 
                    push @problems, "using SSL_version $v, default ciphers -> $SSL_ERROR";
179
 
                } else {
180
 
                    push @problems, "using SSL_version $v, ciphers $ciphers -> $SSL_ERROR";
181
 
                }
182
 
                last BASE if $version;
183
 
            }
184
 
        }
185
 
    }
186
 
    if ($version) {
187
 
        VERBOSE(1,"successful connect with $version cipher=$cipher, sni=$sni and no other TLS extensions");
188
 
    } elsif ($sni) {
189
 
        $sni = '';
190
 
        goto BASE;
191
 
    } else {
192
 
        die "$host failed basic SSL connect: $SSL_ERROR\n";
193
 
    }
194
 
 
195
 
    %conf = ( %conf, SSL_version => $use_version, SSL_cipher_list => $cipher );
196
 
    my $sni_status;
197
 
    if (!$sni) {
198
 
        if ($version =~m{^TLS}) {
199
 
            VERBOSE(1,"SNI FAIL!");
200
 
            push @problems, "using SNI (default)";
201
 
            $sni_status = 'FAIL';
202
 
            $conf{SSL_hostname} = '';
203
 
        }
204
 
    } else {
205
 
        VERBOSE(1,"SNI success");
206
 
        $conf{SSL_hostname} = $name;
207
 
        $sni_status = 'ok';
208
 
    }
209
 
 
210
 
 
211
 
    # get chain info
212
 
    my (@cert_chain,@cert_chain_nosni);
213
 
    if ($show_chain || $dump_chain) {
214
 
        for(
215
 
            [ \%conf, \@cert_chain ],
216
 
            ! $conf{SSL_hostname} ? () 
217
 
                # cloudflare has different cipher list without SNI, so don't
218
 
                # enforce the existing one
219
 
                : ([ { %conf, SSL_cipher_list => undef, SSL_hostname => '' }, \@cert_chain_nosni ])
220
 
        ) {
221
 
            my ($conf,$chain) = @$_;
222
 
            my $cl = &$tcp_connect;
223
 
            if ( IO::Socket::SSL->start_SSL($cl, %$conf,
224
 
                SSL_verify_mode => 0
225
 
            )) {
226
 
                for my $cert ( $cl->peer_certificates ) {
227
 
                    my ($subject,$bits);
228
 
                    $subject = Net::SSLeay::X509_NAME_oneline(
229
 
                        Net::SSLeay::X509_get_subject_name($cert));
230
 
                    if ( !@$chain) {
231
 
                        my @san = $cl->peer_certificate('subjectAltNames');
232
 
                        for( my $i=0;$i<@san;$i++) {
233
 
                            $san[$i] = 'DNS' if $san[$i] == 2;
234
 
                            $san[$i] .= ":".splice(@san,$i+1,1);
235
 
                        }
236
 
                        $subject .= " SAN=".join(",",@san) if @san;
237
 
                    }
238
 
                    if (my $pkey = Net::SSLeay::X509_get_pubkey($cert)) {
239
 
                        $bits = eval { Net::SSLeay::EVP_PKEY_bits($pkey) };
240
 
                        Net::SSLeay::EVP_PKEY_free($pkey);
241
 
                    }
242
 
                    push @$chain,[
243
 
                        $bits||'???',
244
 
                        $subject,
245
 
                        join('|', grep { $_ } @{ CERT_asHash($cert)->{ocsp_uri} || []}),
246
 
                        PEM_cert2string($cert),
247
 
                    ],
248
 
                }
249
 
            } else {
250
 
                die "failed to connect with previously successful config: $SSL_ERROR";
251
 
            }
252
 
        }
253
 
        # if same certificate ignore nosni
254
 
        if (@cert_chain_nosni 
255
 
            && $cert_chain_nosni[0][3] eq $cert_chain[0][3]) {
256
 
            VERBOSE(2,"same certificate in without SNI");
257
 
            @cert_chain_nosni = ();
258
 
        }
259
 
    }
260
 
 
261
 
    # check verification against given/builtin CA w/o OCSP
262
 
    my $verify_status;
263
 
    my $cl = &$tcp_connect;
264
 
    if ( IO::Socket::SSL->start_SSL($cl, %conf,
265
 
        SSL_verify_mode => SSL_VERIFY_PEER,
266
 
        SSL_ocsp_mode => SSL_OCSP_NO_STAPLE,
267
 
        SSL_verifycn_scheme => 'none',
268
 
        %default_ca
269
 
    )) {
270
 
        %conf = ( %conf, SSL_verify_mode => SSL_VERIFY_PEER, %default_ca );
271
 
        if ( $cl->verify_hostname( $name,$scheme )) {
272
 
            VERBOSE(1,"certificate verify success");
273
 
            $verify_status = 'ok';
274
 
            %conf = ( %conf,
275
 
                SSL_verifycn_scheme => $scheme,
276
 
                SSL_verifycn_name => $name,
277
 
            );
278
 
        } else {
279
 
            my @san = $cl->peer_certificate('subjectAltNames');
280
 
            for( my $i=0;$i<@san;$i++) {
281
 
                $san[$i] = 'DNS' if $san[$i] == 2;
282
 
                $san[$i] .= ":".splice(@san,$i+1,1);
283
 
            }
284
 
            VERBOSE(1,"certificate verify - name does not match:".
285
 
                " subject=".$cl->peer_certificate('subject').
286
 
                " SAN=".join(",",@san)
287
 
            );
288
 
            $verify_status = 'name-mismatch';
289
 
            %conf = ( %conf, SSL_verifycn_scheme => 'none');
290
 
        }
291
 
 
292
 
    } else {
293
 
        VERBOSE(1,"certificate verify FAIL!");
294
 
        $verify_status = "FAIL: $SSL_ERROR";
295
 
        push @problems, "using certificate verification (default) -> $SSL_ERROR";
296
 
    }
297
 
 
298
 
    # check with OCSP stapling
299
 
    my $ocsp_staple;
300
 
    if ( $can_ocsp && $verify_status eq 'ok' ) {
301
 
        my $cl = &$tcp_connect;
302
 
        $conf{SSL_ocsp_cache} = $ocsp_cache;
303
 
        if ( IO::Socket::SSL->start_SSL($cl, %conf)) {
304
 
            if ( ${*$cl}{_SSL_ocsp_verify} ) {
305
 
                $ocsp_staple = 'got stapled response',
306
 
            } else {
307
 
                $ocsp_staple = 'no stapled response',
308
 
            }
309
 
            VERBOSE(1,"OCSP stapling: $ocsp_staple");
310
 
        } else {
311
 
            $ocsp_staple = "FAIL: $SSL_ERROR";
312
 
            $conf{SSL_ocsp_mode} = SSL_OCSP_NO_STAPLE;
313
 
            VERBOSE(1,"access with OCSP stapling FAIL!");
314
 
            push @problems, "using OCSP stapling (default) -> $SSL_ERROR";
315
 
        }
316
 
    }
317
 
 
318
 
    my $ocsp_status;
319
 
    if ( $can_ocsp && $verify_status eq 'ok' ) {
320
 
        my $cl = &$tcp_connect;
321
 
        $conf{SSL_ocsp_mode} |= SSL_OCSP_FULL_CHAIN;
322
 
        if ( ! IO::Socket::SSL->start_SSL($cl, %conf)) {
323
 
            die sprintf("failed with SSL_ocsp_mode=%b, even though it succeeded with default mode",
324
 
                $conf{SSL_ocsp_mode});
325
 
        }
326
 
        my $ocsp_resolver = $cl->ocsp_resolver;
327
 
        my %todo = $ocsp_resolver->requests;
328
 
        while (my ($uri,$req) = each %todo) {
329
 
            VERBOSE(3,"need to send %d bytes OCSP request to %s",length($req),$uri);
330
 
        }
331
 
        my $errors = $ocsp_resolver->resolve_blocking();
332
 
        die "resolver not finished " if ! defined $errors;
333
 
        if ( ! $errors ) {
334
 
            VERBOSE(1,"all certificates verified");
335
 
            $ocsp_status = "good";
336
 
        } else {
337
 
            VERBOSE(1,"failed to verify certicates: $errors");
338
 
            $ocsp_status = "FAIL: $errors";
339
 
        }
340
 
        if (my $soft_error = $ocsp_resolver->soft_error) {
341
 
            $ocsp_status .= " (soft error: $soft_error)"
342
 
        }
343
 
    }
344
 
 
345
 
    # check out all supported ciphers
346
 
    my @ciphers;
347
 
    {
348
 
        my $c = 'HIGH:ALL:eNULL';
349
 
        while ($all_ciphers || @ciphers<2 ) {
350
 
            my $cl = &$tcp_connect;
351
 
            if ( IO::Socket::SSL->start_SSL($cl, 
352
 
                %conf,
353
 
                SSL_verify_mode => 0,
354
 
                SSL_version => $conf{SSL_version},
355
 
                SSL_cipher_list => $c,
356
 
            )) {
357
 
                push @ciphers, [ $cl->get_sslversion, $cl->get_cipher ];
358
 
                $c .= ":!".$ciphers[-1][1];
359
 
                VERBOSE(2,"connect with version %s cipher %s",
360
 
                    @{$ciphers[-1]});
361
 
            } else {
362
 
                VERBOSE(3,"handshake failed with $c: $SSL_ERROR");
363
 
                last;
364
 
            }
365
 
        }
366
 
    }
367
 
 
368
 
    # try to detect if the server accepts our cipher order by trying two
369
 
    # ciphers in different order
370
 
    my $server_cipher_order;
371
 
    if (@ciphers>=2) {
372
 
        my %used_cipher;
373
 
        for( "$ciphers[0][1]:$ciphers[1][1]","$ciphers[1][1]:$ciphers[0][1]" ) {
374
 
            my $cl = &$tcp_connect;
375
 
            if ( IO::Socket::SSL->start_SSL($cl,
376
 
                %conf,
377
 
                SSL_version => $use_version,
378
 
                SSL_verify_mode => 0,
379
 
                SSL_hostname => '',
380
 
                SSL_cipher_list => $_,
381
 
            )) {
382
 
                $used_cipher{$cl->get_cipher}++;
383
 
            } else {
384
 
                warn "failed to SSL handshake with SSL_cipher_list=$_: $SSL_ERROR";
385
 
            }
386
 
        }
387
 
        if (keys(%used_cipher) == 2) {
388
 
            VERBOSE(2,"client decides cipher order");
389
 
            $server_cipher_order = 0;
390
 
        } elsif ( (values(%used_cipher))[0] == 2 ) {
391
 
            VERBOSE(2,"server decides cipher order");
392
 
            $server_cipher_order = 1;
393
 
        }
394
 
    }
395
 
 
396
 
 
397
 
    # summary
398
 
    print "-- $host port $port".($stls? " starttls $stls":"")."\n";
399
 
    print " ! $_\n" for(@problems);
400
 
    print " * maximum SSL version  : $version ($use_version)\n";
401
 
    print " * preferred cipher     : $cipher\n";
402
 
    print " * cipher order by      : ".(
403
 
        ! defined $server_cipher_order ? "unknown\n" :
404
 
        $server_cipher_order ? "server\n" : "client\n"
405
 
    );
406
 
    print " * SNI supported        : $sni_status\n" if $sni_status;
407
 
    print " * certificate verified : $verify_status\n";
408
 
    if ($show_chain) {
409
 
        for(my $i=0;$i<@cert_chain;$i++) {
410
 
            my $c = $cert_chain[$i];
411
 
            print "   * [$i] bits=$c->[0], ocsp_uri=$c->[2], $c->[1]\n"
412
 
        }
413
 
        if (@cert_chain_nosni) {
414
 
            print " * chain without SNI\n";
415
 
            for(my $i=0;$i<@cert_chain_nosni;$i++) {
416
 
                my $c = $cert_chain_nosni[$i];
417
 
                print "   * [$i] bits=$c->[0], ocsp_uri=$c->[2], $c->[1]\n"
418
 
            }
419
 
        }
420
 
    }
421
 
    print " * OCSP stapling        : $ocsp_staple\n" if $ocsp_staple;
422
 
    print " * OCSP status          : $ocsp_status\n" if $ocsp_status;
423
 
    if ($all_ciphers) {
424
 
        print " * supported ciphers\n";
425
 
        for(@ciphers) {
426
 
            printf "   * %6s %s\n",@$_;
427
 
        }
428
 
    }
429
 
    if ($dump_chain) {
430
 
        print "---------------------------------------------------------------\n";
431
 
        for(my $i=0;$i<@cert_chain;$i++) {
432
 
            my $c = $cert_chain[$i];
433
 
            print "# $c->[1]\n$c->[3]\n";
434
 
        }
435
 
    }
436
 
}
437
 
 
438
 
 
439
 
 
440
 
sub smtp_starttls {
441
 
    my $cl = $ioclass->new(%{shift()}) or die "tcp connect: $!";
442
 
    my $last_status_line = qr/((\d)\d\d(?:\s.*)?)/;
443
 
    my ($line,$code) = _readlines($cl,$last_status_line);
444
 
    $code == 2 or die "server denies access: $line\n";
445
 
    print $cl "EHLO example.com\r\n";
446
 
    ($line,$code) = _readlines($cl,$last_status_line);
447
 
    $code == 2 or die "server did not accept EHLO: $line\n";
448
 
    print $cl "STARTTLS\r\n";
449
 
    ($line,$code) = _readlines($cl,$last_status_line);
450
 
    $code == 2 or die "server did not accept STARTTLS: $line\n";
451
 
    VERBOSE(3,"...reply to starttls: $line");
452
 
    return $cl;
453
 
}
454
 
 
455
 
sub imap_starttls {
456
 
    my $cl = $ioclass->new(%{shift()}) or die "tcp connect: $!";
457
 
    <$cl>; # welcome
458
 
    print $cl "abc STARTTLS\r\n";
459
 
    while (<$cl>) {
460
 
        m{^abc (OK)?} or next;
461
 
        $1 or die "STARTTLS failed: $_";
462
 
        s{\r?\n$}{};
463
 
        VERBOSE(3,"...starttls: $_");
464
 
        return $cl;
465
 
    }
466
 
    die "starttls failed";
467
 
}
468
 
 
469
 
sub pop_stls {
470
 
    my $cl = $ioclass->new(%{shift()}) or die "tcp connect: $!";
471
 
    <$cl>; # welcome
472
 
    print $cl "STLS\r\n";
473
 
    my $reply = <$cl>;
474
 
    die "STLS failed: $reply" if $reply !~m{^\+OK};
475
 
    $reply =~s{\r?\n}{};
476
 
    VERBOSE(3,"...stls $reply");
477
 
    return $cl;
478
 
}
479
 
 
480
 
sub http_connect {
481
 
    my ($ioargs,$proxy) = @_;
482
 
    $proxy or die "no proxy host:port given";
483
 
    $proxy =~m{^(?:\[(.+)\]|([^:]+)):(\w+)$} or die "invalid dst: $proxy";
484
 
    my $cl = $ioclass->new( %$ioargs,
485
 
        PeerAddr => $1||$2,
486
 
        PeerPort => $3,
487
 
    ) or die "tcp connect: $!";
488
 
    print $cl "CONNECT $ioargs->{PeerAddr}:$ioargs->{PeerPort} HTTP/1.0\r\n\r\n";
489
 
    my $hdr = _readlines($cl,qr/\r?\n/);
490
 
    $hdr =~m{\A(HTTP/1\.[01]\s+(\d\d\d)[^\r\n]*)};
491
 
    die "CONNECT failed: $1" if $2 != 200;
492
 
    VERBOSE(3,"...connect request: $1");
493
 
    return $cl;
494
 
}
495
 
 
496
 
sub http_upgrade {
497
 
    my ($ioargs,$arg) = @_;
498
 
    my $hostname = $ioargs->{PeerAddr};
499
 
    my $cl = $ioclass->new(%$ioargs) or die "tcp connect: $!";
500
 
    my $rq;
501
 
    if ( $arg && $arg =~m{^get(?:=(\S+))?}i ) {
502
 
        my $path = $1 || '/';
503
 
        $rq = "GET $path HTTP/1.1\r\n".
504
 
            "Host: $hostname\r\n".
505
 
            "Upgrade: TLS/1.0\r\n".
506
 
            "Connection: Upgrade\r\n".
507
 
            "\r\n";
508
 
    } else {
509
 
        my $path = $arg && $arg =~m{^options=(\S+)}i
510
 
            ? $1:'*';
511
 
        $rq = "OPTIONS $path HTTP/1.1\r\n".
512
 
            "Host: $hostname\r\n".
513
 
            "Upgrade: TLS/1.0\r\n".
514
 
            "Connection: Upgrade\r\n".
515
 
            "\r\n";
516
 
    }
517
 
    print $cl $rq;
518
 
    my $hdr = _readlines($cl,qr/\r?\n/);
519
 
    $hdr =~m{\A(HTTP/1\.[01]\s+(\d\d\d)[^\r\n]*)};
520
 
    die "upgrade not accepted, code=$2 (expect 101): $1" if $2 != 101;
521
 
    VERBOSE(3,"...tls upgrade request: $1");
522
 
    return $cl;
523
 
}
524
 
 
525
 
sub ftp_auth {
526
 
    my $cl = $ioclass->new(%{shift()}) or die "tcp connect: $!";
527
 
    my $last_status_line = qr/((\d)\d\d(?:\s.*)?)/;
528
 
    my ($line,$code) = _readlines($cl,$last_status_line);
529
 
    die "server denies access: $line\n" if $code != 2;
530
 
    print $cl "AUTH TLS\r\n";
531
 
    ($line,$code) = _readlines($cl,$last_status_line);
532
 
    die "AUTH TLS denied: $line\n" if $code != 2;
533
 
    VERBOSE(3,"...ftp auth: $line");
534
 
    return $cl;
535
 
}
536
 
 
537
 
sub postgresql_init {
538
 
    my $cl = $ioclass->new(%{shift()}) or die "tcp connect: $!";
539
 
    # magic header to initiate SSL:
540
 
    # http://www.postgresql.org/docs/devel/static/protocol-message-formats.html
541
 
    print $cl pack("NN",8,80877103);
542
 
    read($cl, my $buf,1 ) or die "did not get response from postgresql";
543
 
    $buf eq 'S' or die "postgresql does not support SSL (response=$buf)";
544
 
    VERBOSE(3,"...postgresql supports SSL: $buf");
545
 
    return $cl;
546
 
}
547
 
 
548
 
sub _readlines {
549
 
    my ($cl,$stoprx) = @_;
550
 
    my $buf = '';
551
 
    while (<$cl>) {
552
 
        $buf .= $_;
553
 
        return $buf if ! $stoprx;
554
 
        next if ! m{\A$stoprx\Z};
555
 
        return ( m{\A$stoprx\Z},$buf );
556
 
    }
557
 
    die "eof" if $buf eq '';
558
 
    die "unexpected response: $buf";
559
 
}
560
 
 
561
 
 
562
 
 
563
 
sub VERBOSE {
564
 
    my $level = shift;
565
 
    $verbose>=$level || return;
566
 
    my $msg = shift;
567
 
    $msg = sprintf($msg,@_) if @_;
568
 
    my $prefix = $level == 1 ? '+ ' : $level == 2 ? '* ' : "<$level> ";
569
 
    print STDERR "$prefix$msg\n";
570
 
}