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