s4: bring nsupdate-gss into the s4 tree
[ira/wip.git] / source4 / scripting / bin / nsupdate-gss
1 #!/usr/bin/perl -w
2 # update a win2000 DNS server using gss-tsig 
3 # tridge@samba.org, October 2002
4
5 # jmruiz@animatika.net
6 # updated, 2004-Enero
7
8 # tridge@samba.org, September 2009
9 # added --verbose, --noverify, --ntype and --nameserver
10
11 # See draft-ietf-dnsext-gss-tsig-02, RFC2845 and RFC2930
12
13 use strict;
14 use lib "GSSAPI";
15 use Net::DNS;
16 use GSSAPI;
17 use Getopt::Long;
18
19 my $opt_wipe = 0;
20 my $opt_add = 0;
21 my $opt_noverify = 0;
22 my $opt_verbose = 0;
23 my $opt_help = 0;
24 my $opt_nameserver;
25 my $opt_ntype = "A";
26
27 # main program
28 GetOptions (
29             'h|help|?' => \$opt_help,
30             'wipe' => \$opt_wipe,
31             'nameserver=s' => \$opt_nameserver,
32             'ntype=s' => \$opt_ntype,
33             'add' => \$opt_add,
34             'noverify' => \$opt_noverify,
35             'verbose' => \$opt_verbose
36             );
37
38
39 #########################################
40 # display help text
41 sub ShowHelp()
42 {
43     print "
44  nsupdate with gssapi
45  Copyright (C) tridge\@samba.org
46
47  Usage: nsupdate-gss [options] HOST DOMAIN TARGET TTL
48
49  Options:
50          --wipe               wipe all records for this name
51          --add                add to any existing records
52          --ntype=TYPE         specify name type (default A)
53          --nameserver=server  specify a specific nameserver
54          --noverify           don't verify the MIC of the reply
55          --verbose            show detailed steps
56            
57 ";
58     exit(0);
59 }
60
61 if ($opt_help) {
62         ShowHelp();
63 }
64
65 if ($#ARGV != 3) {
66         ShowHelp();
67 }
68
69
70 my $host = $ARGV[0];
71 my $domain = $ARGV[1];
72 my $target = $ARGV[2];
73 my $ttl = $ARGV[3];
74 my $alg = "gss.microsoft.com";
75
76
77
78 #######################################################################
79 # signing callback function for TSIG module
80 sub gss_sign($$)
81 {
82     my $key = shift;
83     my $data = shift;
84     my $sig;
85     $key->get_mic(0, $data, $sig);
86     return $sig;
87 }
88
89
90
91 #####################################################################
92 # write a string into a file
93 sub FileSave($$)
94 {
95     my($filename) = shift;
96     my($v) = shift;
97     local(*FILE);
98     open(FILE, ">$filename") || die "can't open $filename";    
99     print FILE $v;
100     close(FILE);
101 }
102
103
104 #######################################################################
105 # verify a TSIG signature from a DNS server reply
106 #
107 sub sig_verify($$)
108 {
109     my $context = shift;
110     my $packet = shift;
111
112     my $tsig = ($packet->additional)[0];
113     $opt_verbose && print "calling sig_data\n";
114     my $sigdata = $tsig->sig_data($packet);
115
116     $opt_verbose && print "sig_data_done\n";
117
118     return $context->verify_mic($sigdata, $tsig->{"mac"}, 0);
119 }
120
121
122 #######################################################################
123 # find the nameserver for the domain
124 #
125 sub find_nameservers($)
126 {
127     my $domain = shift;
128     my $res;
129     if ($opt_nameserver) {
130             $res = Net::DNS::Resolver->new(
131                     nameservers => [qw($opt_nameserver)],
132                     recurse     => 0,
133                     debug       => 1);
134     } else {
135             $res = Net::DNS::Resolver->new;
136     }
137     $res->nameservers($domain);
138     return $res;
139 }
140
141
142 #######################################################################
143 # find a server name for a domain - currently uses the LDAP SRV record.
144 # I wonder if there is a _dns record type?
145 sub find_server_name($)
146 {
147     my $domain = shift;
148     my $res = Net::DNS::Resolver->new;
149     my $srv_query = $res->query("_ldap._tcp.$domain.", "SRV");
150     if (!defined($srv_query)) {
151         return undef;
152     }
153     my $server_name = ($srv_query->answer)[0]->{"target"};
154     return $server_name;
155 }
156
157 #######################################################################
158
159 #
160 sub negotiate_tkey($$$$)
161 {
162
163     my $nameserver = shift;
164     my $domain = shift;
165     my $server_name = shift;
166     my $key_name = shift;
167
168     my $status;
169
170     my $context = GSSAPI::Context->new;
171     my $name = GSSAPI::Name->new;
172
173     # use a principal name of dns/server@DOMAIN
174     $status = $name->import($name, "dns/" . $server_name . "@" . uc($domain));
175     if (! $status) {
176             print "import name: $status\n";
177             return undef;
178     }
179
180     my $flags = 
181         GSS_C_REPLAY_FLAG | GSS_C_MUTUAL_FLAG | 
182         GSS_C_SEQUENCE_FLAG | GSS_C_CONF_FLAG | 
183         GSS_C_INTEG_FLAG | GSS_C_DELEG_FLAG;
184
185
186     $status = GSSAPI::Cred::acquire_cred(undef, 120, undef, GSS_C_INITIATE,
187                                          my $cred, my $oidset, my $time);
188
189     if (! $status) {
190         print "acquire_cred: $status\n";
191         return undef;
192     }
193
194     $opt_verbose && print "creds acquired\n";
195
196     # call gss_init_sec_context()
197     $status = $context->init($cred, $name, undef, $flags,
198                              0, undef, "", undef, my $tok,
199                              undef, undef);
200     if (! $status) {
201             print "init_sec_context: $status\n";
202             return undef;
203     }
204
205     $opt_verbose && print "init done\n";
206
207     my $gss_query = Net::DNS::Packet->new("$key_name", "TKEY", "IN");
208
209     # note that Windows2000 uses a SPNEGO wrapping on GSSAPI data sent to the nameserver.
210     # I tested using the gen_negTokenTarg() call from Samba 3.0 and it does work, but
211     # for this utility it is better to use plain GSSAPI/krb5 data so as to reduce the
212     # dependence on external libraries. If we ever want to sign DNS packets using
213     # NTLMSSP instead of krb5 then the SPNEGO wrapper could be used
214
215     $opt_verbose && print "calling RR new\n";
216
217     $a = Net::DNS::RR->new(
218                            Name    => "$key_name",
219                            Type    => "TKEY",
220                            TTL     => 0,
221                            Class   => "ANY",
222                            mode => 3,
223                            algorithm => $alg,
224                            inception => time,
225                            expiration => time + 24*60*60,
226                            key => $tok,
227                            other_data => "",
228                            );
229
230     $gss_query->push("answer", $a);
231
232     my $reply = $nameserver->send($gss_query);
233
234     if (!defined($reply) || $reply->header->{'rcode'} ne 'NOERROR') {
235         print "failed to send TKEY\n";
236         return undef;
237     }
238
239     my $key2 = ($reply->answer)[0]->{"key"};
240
241     # call gss_init_sec_context() again. Strictly speaking
242     # we should loop until this stops returning CONTINUE
243     # but I'm a lazy bastard
244     $status = $context->init($cred, $name, undef, $flags,
245                              0, undef, $key2, undef, $tok,
246                              undef, undef);
247     if (! $status) {
248         print "init_sec_context step 2: $status\n";
249         return undef;
250     }
251
252     if (!$opt_noverify) {
253             $opt_verbose && print "verifying\n";
254
255             # check the signature on the TKEY reply
256             my $rc = sig_verify($context, $reply);
257             if (! $rc) {
258                     print "Failed to verify TKEY reply: $rc\n";
259 #               return undef;
260             }
261
262             $opt_verbose && print "verifying done\n";
263     }
264
265     return $context;
266 }
267
268
269 #######################################################################
270 # MAIN
271 #######################################################################
272
273
274 # find the nameservers
275 my $nameserver = find_nameservers("$domain.");
276
277 $opt_verbose && print "Found nameserver $nameserver\n";
278
279 if (!defined($nameserver) || $nameserver->{'errorstring'} ne 'NOERROR') {
280     print "Failed to find a nameserver for domain $domain\n";
281     exit 1;
282 }
283
284 # find the name of the DNS server
285 my $server_name = find_server_name($domain);
286 if (!defined($server_name)) {
287     print "Failed to find a DNS server name for $domain\n";
288     exit 1;
289 }
290 $opt_verbose && print "Using DNS server name $server_name\n";
291
292 # use a long random key name
293 my $key_name = int(rand 10000000000000);
294
295 # negotiate a TKEY key
296 my $gss_context = negotiate_tkey($nameserver, $domain, $server_name, $key_name);
297 if (!defined($gss_context)) {
298     print "Failed to negotiate a TKEY\n";
299     exit 1;
300 }
301 $opt_verbose && print "Negotiated TKEY $key_name\n";
302
303 # construct a signed update
304 my $update = Net::DNS::Update->new($domain);
305
306 $update->push("pre", yxdomain("$domain"));
307 if (!$opt_add) {
308         $update->push("update", rr_del("$host.$domain. $opt_ntype"));
309 }
310 if (!$opt_wipe) {
311         $update->push("update", rr_add("$host.$domain. $ttl $opt_ntype $target"));
312 }
313
314 my $sig = Net::DNS::RR->new(
315                             Name    => $key_name,
316                             Type    => "TSIG",
317                             TTL     => 0,
318                             Class   => "ANY",
319                             Algorithm => $alg,
320                             Time_Signed => time,
321                             Fudge => 36000,
322                             Mac_Size => 0,
323                             Mac => "",
324                             Key => $gss_context,
325                             Sign_Func => \&gss_sign,
326                             Other_Len => 0,
327                             Other_Data => "",
328                             Error => 0,
329                             mode => 3,
330                             );
331
332 $update->push("additional", $sig);
333
334 # send the dynamic update
335 my $update_reply = $nameserver->send($update);
336
337 if (! defined($update_reply)) {
338     print "No reply to dynamic update\n";
339     exit 1;
340 }
341
342 # make sure it worked
343 my $result = $update_reply->header->{"rcode"};
344 $opt_verbose && print "Update gave rcode $result\n";
345
346 if ($result ne 'NOERROR') {
347     exit 1;
348 }
349
350 exit 0;