]>
Commit | Line | Data |
---|---|---|
7eddace0 | 1 | #!/usr/bin/perl |
4e0938ef | 2 | # |
77b1029d | 3 | ## Copyright (C) 1996-2020 The Squid Software Foundation and contributors |
4e0938ef AJ |
4 | ## |
5 | ## Squid software is distributed under GPLv2+ license and includes | |
6 | ## contributions from numerous individuals and organizations. | |
7 | ## Please see the COPYING and CONTRIBUTORS files for details. | |
8 | ## | |
7eddace0 | 9 | |
10 | # htcp-client.pl | |
11 | # by Duane Wessels | |
12 | # | |
13 | # simple tool to send client HTCP queries | |
14 | # | |
15 | # only supports TST and CLR so far | |
16 | # | |
17 | ||
18 | use strict; | |
19 | use warnings; | |
20 | use IO::Socket::INET; | |
21 | ||
22 | my $op = shift; | |
23 | my $url = shift; | |
24 | my $server = shift; | |
25 | my %opcodes = ( | |
47f28373 FC |
26 | NOP => 0, |
27 | TST => 1, | |
28 | MON => 2, | |
29 | SET => 3, | |
30 | CLR => 4, | |
31 | ); | |
7eddace0 | 32 | |
33 | print "sending $op $url to $server\n"; | |
34 | ||
35 | my $op_data = op_data($op, $url); | |
36 | ||
37 | ||
38 | my $data = data($op_data, $opcodes{$op}, 0, 1, 0, rand 1<<31); | |
39 | my $auth = auth(); | |
40 | ||
41 | my $htcp = packet($data, $auth); | |
42 | ||
43 | my $sock = IO::Socket::INET->new(PeerAddr => $server, | |
47f28373 FC |
44 | PeerPort => 4827, |
45 | Proto => 'udp'); | |
7eddace0 | 46 | |
47 | die "$server: $!" unless $sock; | |
48 | ||
49 | $sock->send($htcp, 0) || die "send $server: $!"; | |
50 | exit 0; | |
51 | ||
52 | sub packet { | |
47f28373 FC |
53 | my $data = shift; |
54 | my $auth = shift; | |
55 | my $hdr = header(length($data) + length($auth)); | |
56 | printf STDERR "hdr is %d bytes\n", length($hdr); | |
57 | printf STDERR "data is %d bytes\n", length($data); | |
58 | printf STDERR "auth is %d bytes\n", length($auth); | |
59 | $hdr . $data . $auth; | |
7eddace0 | 60 | } |
61 | ||
62 | sub header { | |
47f28373 FC |
63 | my $length = 4 + shift; |
64 | my $major = 0; | |
65 | my $minor = 0; | |
66 | my $buf; | |
67 | pack('nCC', $length, $major, $minor); | |
7eddace0 | 68 | } |
69 | ||
70 | sub data { | |
47f28373 FC |
71 | my $op_data = shift; |
72 | my $opcode = shift; | |
73 | my $response = shift; | |
74 | my $reserved = 0; | |
75 | my $f1 = shift; | |
76 | my $rr = shift; | |
77 | my $trans_id = shift; | |
78 | printf STDERR "op_data is %d bytes\n", length($op_data); | |
79 | printf STDERR "response is %d\n", $response; | |
80 | printf STDERR "F1 is %d\n", $f1; | |
81 | printf STDERR "RR is %d\n", $rr; | |
82 | my $length = 8 + length($op_data); | |
83 | my $x1 = ($opcode & 0xF) | (($response & 0xF) << 4); | |
84 | #my $x2 = ($rr & 0x1) | (($f1 & 0x1) << 1) | (($reserved & 0x3F) << 2); | |
85 | my $x2 = ($reserved & 0x3F) | (($f1 & 0x1) << 6) | (($rr & 0x1) << 7); | |
86 | pack('nCCNa*', $length, $x1, $x2, $trans_id, $op_data); | |
7eddace0 | 87 | } |
88 | ||
89 | sub auth { | |
47f28373 | 90 | pack('n', 2); |
7eddace0 | 91 | } |
92 | ||
93 | sub countstr { | |
47f28373 FC |
94 | my $str = shift; |
95 | pack('na*', length($str), $str); | |
7eddace0 | 96 | } |
97 | ||
98 | sub specifier { | |
47f28373 FC |
99 | my $method = countstr(shift); |
100 | my $uri = countstr(shift); | |
101 | my $version = countstr(shift); | |
102 | my $req_hdrs = countstr(shift); | |
103 | $method . $uri . $version . $req_hdrs; | |
7eddace0 | 104 | } |
105 | ||
106 | sub clr { | |
47f28373 FC |
107 | my $reason = shift; |
108 | my $reserved = 0; | |
109 | my $specifier = shift; | |
110 | printf STDERR "CLR specifier is %d bytes\n", length($specifier); | |
111 | my $x1 = ($reason & 0xF) | (($reserved & 0x7F) << 4); | |
112 | pack('na*', $x1, $specifier); | |
7eddace0 | 113 | } |
114 | ||
115 | sub tst { | |
47f28373 FC |
116 | my $specifier = shift; |
117 | printf STDERR "TST specifier is %d bytes\n", length($specifier); | |
118 | pack('a*', $specifier); | |
7eddace0 | 119 | } |
120 | ||
121 | sub op_data { | |
47f28373 FC |
122 | my $op = shift; |
123 | my $url = shift; | |
124 | if ($op eq 'CLR') { | |
125 | return clr(1, specifier('GET', $url, 'HTTP/1.1', "Accept: */*\r\n")); | |
126 | } elsif ($op eq 'TST') { | |
127 | return tst(specifier('GET', $url, 'HTTP/1.1', "Accept: */*\r\n")); | |
128 | } else { | |
129 | print STDERR "unsupported HTCP opcode $op\n"; | |
130 | exit 1; | |
131 | } | |
7eddace0 | 132 | } |