/pliant/protocol/dns/server.pli
1	abstract
2	[This is a partial DNS server implementation, according to RFC 1035.]
3
4
5	module "/pliant/install/minimal.pli"
6	module "/pliant/language/compiler.pli"
7	submodule "/pliant/protocol/common/tcp_server.pli"
8	module "/pliant/protocol/common/misc.pli"
9	module "/pliant/language/stream.pli"
10	module "/pliant/fullpliant/this_computer.pli"
11	module "common.pli"
12	module "name.pli"
13	module "/pliant/protocol/http/proxy.pli"
14	module "/pliant/protocol/http/site.pli"
15
16	module "/pliant/language/context.pli"
17	module "/pliant/language/schedule/resourcesem.pli"
18
19	(gvar TraceSlot dns_trace) configure "DNS server"
20
21
22	type DnsServer
23	tcp_server_fields "DNS" 53
24	field CBool please_stop_udp
25	field ResourceSem resource
26	public
27	field Str cache
28	field Str default
29	field Int parallel <- (constant (max (min (cast memory_assigned\2^20 Int) 1024) 64))
30	TcpServer maybe DnsServer
31
32
33	gvar Int dns_refresh := 24*3600 # in seconds
34	gvar Int dns_hits := 0
35
36
37
38
39	doc
40	[A few utility functions.]
41
42	method s write_header adr size flags
43	arg_rw Stream s ; arg Address adr ; arg Int size ; arg Int flags
44	var Pointer:DnsHeader h :> adr map DnsHeader
45	h flags := flags
46	h qdcount := 1
47	h ancount := 0
48	h nscount := 0
49	h arcount := 0
50	s raw_write adr size
51
52	method s write_name name
53	arg_rw Stream s ; arg Str name
54	var Int offset := (cast s:stream_write_cur Int) .-. (cast s:stream_write_buf Int)
55	var Int limit := (cast s:stream_write_stop Int) .-. (cast s:stream_write_buf Int)
56	write_name s:stream_write_buf offset limit name
57	s:stream_write_cur := s:stream_write_buf translate Byte offset
58
59	method s write_cached_name offset
60	arg_rw Stream s ; arg Int offset
61	var uInt16_hi tag := offset + 0C000h
62	s raw_write addressof:tag uInt16_hi:size
63
64	method s write_answer qtype length flags
65	arg_rw Stream s ; arg Int qtype ; arg Int length ; arg Int flags
66	var DnsTail t
67	t qclass := 1
68	t qtype := qtype
69	s raw_write addressof:t DnsTail:size
70	var DnsAnswer a
71	a ttl := shunt (flags .and. 1)<>0 120 dns_refresh
72	a rdlength := length
73	s raw_write addressof:a DnsAnswer:size
74
75	method s write_ip_answer ip1 ip2 ip3 ip4 flags
76	arg_rw Stream s ; arg uInt ip1 ip2 ip3 ip4 ; arg Int flags
77	s write_answer 1 uInt32_hi:size flags
78	var uInt32_hi ip := ip1*2^24+ip2*2^16+ip3*2^8+ip4 ; s raw_write addressof:ip uInt32_hi:size
79
80	method s write_ipv6_answer ip1 ip2 ip3 ip4 ip5 ip6 ip7 ip8 flags
81	arg_rw Stream s ; arg uInt ip1 ip2 ip3 ip4 ip5 ip6 ip7 ip8 ; arg Int flags
82	s write_answer 28 16 flags
83	var uInt16_hi u := ip1 ; s raw_write addressof:u uInt16_hi:size
84	var uInt16_hi u := ip2 ; s raw_write addressof:u uInt16_hi:size
85	var uInt16_hi u := ip3 ; s raw_write addressof:u uInt16_hi:size
86	var uInt16_hi u := ip4 ; s raw_write addressof:u uInt16_hi:size
87	var uInt16_hi u := ip5 ; s raw_write addressof:u uInt16_hi:size
88	var uInt16_hi u := ip6 ; s raw_write addressof:u uInt16_hi:size
89	var uInt16_hi u := ip7 ; s raw_write addressof:u uInt16_hi:size
90	var uInt16_hi u := ip8 ; s raw_write addressof:u uInt16_hi:size
91
92	method s no_answer
93	arg_rw Stream s
94	s stream_write_cur := s stream_write_buf
95
96
97	function is_ipv6 s ip1 ip2 ip3 ip4 ip5 ip6 ip7 ip8 -> answer
98	arg Str s ; arg_w uInt ip1 ip2 ip3 ip4 ip5 ip6 ip7 ip8 ; arg CBool answer
99	var (Array uInt 7) ips
100	var Int index := 0 ; var Int start := 0 ; var uInt value := 0
101	for (var Int i) 0 s:len-1
102	var Int c := s:i:number
103	if c=":":number
104	if i=start or index>=7
105	return false
106	ips index := value ; index += 1
107	start := i+1 ; value := 0
108	eif i-start>=4
109	return false
110	eif (c>="0":number and c<="9":number)
111	value := value*16+c-"0":number
112	eif (c>="A":number and c<="F":number)
113	value := value*16+c-"A":number+10
114	eif (c>="a":number and c<="f":number)
115	value := value*16+c-"a":number+10
116	else
117	return false
118	if i=start or index<>7
119	return false
120	ip1 := ips 0
121	ip2 := ips 1
122	ip3 := ips 2
123	ip4 := ips 3
124	ip5 := ips 4
125	ip6 := ips 5
126	ip7 := ips 6
127	ip8 := value
128	answer := true
129
130
131	type DnsExtra
132	field Int offset
133	field Str ip
134
135	method d record name s start
136	arg_rw Dictionary d ; arg Str name ; arg Stream s ; arg Address start
137	var Pointer:DnsExtra e :> d kmap name DnsExtra
138	e offset := (cast s:stream_write_cur Int) .-. (cast start Int)
139	e ip := name_ip name
140
141
142	doc
143	['build_answer' will build the answer packet to a request about a domain that is defined in the database, as opposed to other requests that will be forwarded (then cached) to external providers.]
144
145	function build_soa_field d s
146	arg Data:NameDomain d ; arg_rw Stream s
147	var Str master := computer_fullname
148	part get_master_dns
149	each ns d:dns
150	master := ns
151	leave get_master_dns
152	var Str mailbox := d mailbox
153	if mailbox=""
154	mailbox := "postmaster@"+keyof:d
155	datetime:date split (var Int year) (var Int month) (var Int day)
156	var uInt32_hi serial := (cast year uInt)*100^3+(cast month uInt)*100^2+(cast day uInt)*100
157	var uInt32_hi refresh := dns_refresh
158	var uInt32_hi retry := 3600
159	var uInt32_hi expire := 7*86400
160	var uInt32_hi minimum := dns_refresh
161	s write_cached_name DnsHeader:size
162	s write_answer 6 master:len+2+mailbox:len+2+5*uInt32_hi:size 0
163	s write_name master
164	s write_name (replace mailbox "@" ".")
165	s raw_write addressof:serial uInt32_hi:size
166	s raw_write addressof:refresh uInt32_hi:size
167	s raw_write addressof:retry uInt32_hi:size
168	s raw_write addressof:expire uInt32_hi:size
169	s raw_write addressof:minimum uInt32_hi:size
170
171	function build_answer d d2 field flags adr size s
172	arg Data:NameDomain d d2 ; arg Int field flags ; arg Address adr ; arg Int size ; arg_rw Stream s
173	var Address start := s stream_write_cur
174	s write_header adr size flags
175	var Int count1 := 0
176	var Int count2 := 0
177	var Int count3 := 0
178	var Dictionary extra
179	if field=6 or field=255 # query SOA field
180	if exists:d and d:authoritative
181	build_soa_field d s
182	count1 += 1
183	if field=2 or field=255 # query NS field
184	each ns d:dns
185	s write_cached_name DnsHeader:size
186	s write_answer 2 ns:len+2 0
187	extra record ns s start
188	s write_name ns
189	count1 += 1
190	if field=15 or field=255 # query MX field
191	var uInt16_hi priority := 1
192	each m d:mail
193	s write_cached_name DnsHeader:size
194	s write_answer 15 uInt16_hi:size+m:len+2 0
195	s raw_write addressof:priority uInt16_hi:size ; priority += 1
196	extra record m s start
197	s write_name m
198	count1 += 1
199	if field=1 or field=255 # query A field
200	var Str answer := name_ip keyof:d
201	if http_proxy_user:len>0 and (s query "remote_ip_address")="127.0.0.1"
202	var Data:NameHost host :> name_database:data:host keyof:d
203	if exists:host and host:public_key:len>0
204	answer := "127.0.0.1"
205	var Data:Site site :> site_database:data:site keyof:d
206	if exists:site and site:public_key:len>0
207	answer := "127.0.0.1"
208	if (answer parse (var uInt ip1) "." (var uInt ip2) "." (var uInt ip3) "." (var uInt ip4))
209	s write_cached_name DnsHeader:size
210	s write_ip_answer ip1 ip2 ip3 ip4 0
211	count1 += 1
212	if field=28 or field=255 # query AAAA field
213	var Str answer := name_ip keyof:d
214	if (is_ipv6 answer (var uInt ip1) (var uInt ip2) (var uInt ip3) (var uInt ip4) (var uInt ip5) (var uInt ip6) (var uInt ip7) (var uInt ip8))
215	s write_cached_name DnsHeader:size
216	s write_ipv6_answer ip1 ip2 ip3 ip4 ip5 ip6 ip7 ip8 0
217	count1 += 1
218	if field=12 or field=255 # query PTR field
219	var Data:NameReverse r :> name_database:data:reverse keyof:d
220	each ptr r:ptr
221	s write_cached_name DnsHeader:size
222	s write_answer 12 ptr:len+2 0
223	s write_name ptr
224	count1 += 1
225	if count1=0 and exists:d2 and d2:authoritative # autority SOA field
226	build_soa_field d2 s
227	count2 += 1
228	eif field<>2 and (field<>255 or not exists:d) # autority NS fields
229	each ns d2:dns
230	if count2=0
231	var Int offset2 := (cast s:stream_write_cur Int) .-. (cast start Int)
232	s write_name keyof:d2
233	else
234	s write_cached_name offset2
235	s write_answer 2 ns:len+2 0
236	extra record ns s start
237	s write_name ns
238	count2 += 1
239	each e extra type DnsExtra getkey n
240	if (e:ip parse (var uInt ip1) "." (var uInt ip2) "." (var uInt ip3) "." (var uInt ip4))
241	s write_cached_name e:offset
242	s write_ip_answer ip1 ip2 ip3 ip4 0
243	count3 += 1
244	eif (is_ipv6 e:ip (var uInt ip1) (var uInt ip2) (var uInt ip3) (var uInt ip4) (var uInt ip5) (var uInt ip6) (var uInt ip7) (var uInt ip8))
245	s write_cached_name e:offset
246	s write_ipv6_answer ip1 ip2 ip3 ip4 ip5 ip6 ip7 ip8 0
247	count3 += 1
248	(start translate uInt16_hi 3) map uInt16_hi := count1
249	(start translate uInt16_hi 4) map uInt16_hi := count2
250	(start translate uInt16_hi 5) map uInt16_hi := count3
251	var Pointer:DnsHeader h :> start map DnsHeader
252	if count1=0 and (h:flags .and. 15)=0
253	if field<>1 and field<>2 and field<>5 and field<>6 and field<>12 and field<>15 and field<>28 and field<>255
254	h flags += 4 # not implemented
255	eif not exists:d and (name_ip keyof:d)="" and not exists:(name_database:data:reverse keyof:d) and (flags .and. 400h)<>0
256	h flags += 3 # name does not exist (NXDOMAIN)
257
258
259
260
261	doc
262	[Parses then answer a client request.]
263
264
265	method server answer adr size s udp
266	arg_rw DnsServer server ; arg Address adr ; arg Int size ; arg_rw Stream s ; arg CBool udp
267	if size<DnsHeader:size
268	dns_trace trace "Received too short query from " (s query "remote_ip_address") ": no answer"
269	s no_answer ; return
270	var Pointer:DnsHeader h :> adr map DnsHeader
271	if (h:flags .and. 8000h)<>0
272	dns_trace trace "Received answer from " (s query "remote_ip_address") ": no answer"
273	s no_answer ; return
274	if (h:flags .and. 07840h)<>0 or h:qdcount<>1 # was 07870h to reject any request with Z<>0, now just ignores AD et CD bits
275	dns_trace trace "Received invalid query from " (s query "remote_ip_address") " (flags=" (string (cast h:flags Int) "radix 16") " dqcount=" (cast h:qdcount Int) "): not implemented"
276	h flags := 8000h+(h:flags .and. 7970h)+4 # not implemented
277	s raw_write adr size
278	return
279	var CBool local_query := server:cache:len<>0 and ((s query "remote_ip_address") is_inside_ip_domain server:cache)
280	var Int offset := DnsHeader:size
281	var Str name := lower (read_name adr offset size)
282	if local_query and server:default:len<>0 and (name search "." -1)=(-1) and (name_ip name+"."+server:default)<>""
283	name += "."+server:default
284	if size<offset+DnsTail:size
285	dns_trace trace "Received too short query from " (s query "remote_ip_address") ": no answer"
286	s no_answer ; return
287	var Pointer:DnsTail t :> (adr translate Byte offset) map DnsTail
288	offset += DnsTail size
289	if offset>512 # try to avoid a few potencial buffer overflows
290	dns_trace trace "Received too long query from " (s query "remote_ip_address") ": no answer"
291	s no_answer ; return
292	part answer_query "answer DNS query "+name+" (qclass="+string:(cast t:qclass Int)+" qtype="+string:(cast t:qtype Int)+")"
293	var Int flags := 8000h+(h:flags .and. 100h)
294	var Data:NameDomain d :> name_database:data:domain name
295	var Data:NameDomain d2 :> d ; var Int pt := -1
296	while not exists:d2 and { var Int pt2 := (name pt+1 name:len) search "." -1 ; pt2<>(-1) }
297	pt := pt+1+pt2
298	d2 :> name_database:data:domain (name pt+1 name:len)
299	var CBool authoritative := exists:d2 and d2:authoritative
300	if authoritative
301	flags += 400h # set aa flag
302	if local_query
303	flags += 80h # set ra flag
304	if authoritative
305	# a query about a local domain: build the answer localy
306	dns_trace trace "Query " name " (qclass=" (cast t:qclass Int) " qtype=" (cast t:qtype Int) ") from " (s query "remote_ip_address") ": authoritative answer"
307	build_answer d d2 (shunt t:qclass=1 t:qtype -1) flags adr offset s
308	eif t:qclass=1 and (t:qtype=1 or t:qtype=28) and name_ip:name<>""
309	dns_trace trace "Query IP address of " name " from " (s query "remote_ip_address") ": answer is " name_ip:name
310	# we know the name -> IP assignment, so answer whatever the domain is
311	build_answer d d2 t:qtype flags adr offset s
312	eif local_query
313	# a internal request about an external domain: query (then cache) the external DNS servers
314	(var Str query) set adr size false
315	var Str answer := query_cache query
316	if answer=""
317	if udp
318	if (server:resource nowait_request 1)
319	safe
320	var Str ip := s query "remote_ip_address"
321	var Str port := s query "remote_ip_port"
322	thread
323	share server
324	part query_external "Query external DNS ("+name+")"
325	var Str answer2 := query_providers query
326	if answer2<>""
327	dns_trace trace "Local query " name " (qclass=" (cast t:qclass Int) " qtype=" (cast t:qtype Int) ") from " ip ": forwarding answer"
328	(var Stream back) open "udp://"+ip+"/client/"+port "local_ip_port 53" in+out+safe
329	back configure "priority high"
330	back writechars answer2
331	back close
332	else
333	dns_trace trace "Local query " name " (qclass=" (cast t:qclass Int) " qtype=" (cast t:qtype Int) ") from " ip ": failed to get answer from external DNS"
334	server:resource release 1
335	failure
336	dns_trace trace "Local query " name " (qclass=" (cast t:qclass Int) " qtype=" (cast t:qtype Int) ") from " (s query "remote_ip_address") ": no more thread"
337	server:resource release 1
338	else
339	dns_trace trace "Local query " name " (qclass=" (cast t:qclass Int) " qtype=" (cast t:qtype Int) ") from " (s query "remote_ip_address") ": too many pending queries"
340	s no_answer
341	else
342	answer := query_providers query
343	dns_trace trace "Local TCP query " name " (qclass=" (cast t:qclass Int) " qtype=" (cast t:qtype Int) ") from " (s query "remote_ip_address") ": " (shunt answer<>"" "forwarding answer" "failed to get answer from external DNS")
344	else
345	dns_trace trace "Local query " name " (qclass=" (cast t:qclass Int) " qtype=" (cast t:qtype Int) ") from " (s query "remote_ip_address") ": was in cache"
346	if answer<>""
347	s writechars answer
348	else
349	s no_answer
350	eif exists:d2 and not local_query
351	# a query about a sub domain: build the answer localy
352	dns_trace trace "Query about subdomain " name " (qclass=" (cast t:qclass Int) " qtype=" (cast t:qtype Int) ") from " (s query "remote_ip_address") ": non authoritative answer"
353	build_answer d d2 (shunt t:qclass=1 t:qtype -1) flags adr offset s
354	else
355	s write_header adr offset flags+5 # refused
356
357
358	doc
359	[General loop handling requests received on TCP port 53.]
360
361	method server service s
362	arg_rw DnsServer server ; arg_rw Stream s
363	while not s:atend
364	s raw_read addressof:(var uInt16_hi length) uInt16_hi:size
365	var Int size := length
366	var Address adr := memory_allocate size null
367	s raw_read adr size
368	if s=failure
369	memory_free adr
370	return
371	length := 0 ; s raw_write addressof:length uInt16_hi:size
372	server answer adr size s false
373	memory_free adr
374	if s:stream_write_cur=s:stream_write_buf
375	return
376	s:stream_write_buf map uInt16_hi := (cast s:stream_write_cur Int) .-. (cast s:stream_write_buf Int) .-. uInt16_hi:size
377	s flush anytime
378
379
380	doc
381	[When the DNS TCP service starts, we start another thread handling UDP requests, and we stop this thread when the DNS TCP service stops.]
382
383	method server start_checkup -> status
384	arg_rw DnsServer server ; arg Status status
385	server:resource configure server:parallel
386	(var Stream test) open "udp:/server/53" in+out+safe
387	if test=failure
388	return failure
389	test close
390	dns_hits := 0
391	server please_stop_udp := false
392	thread
393	share server
394	part udp_server "UDP DNS server"
395	(var Stream s) open "udp:/server/53" in+out+safe
396	s configure "priority high"
397	while not server:please_stop_udp
398	part wait_for_request "wait for UDP request"
399	s read_available (var Address adr) (var Int size)
400	dns_hits += 1
401	part answer_request "answer UDP request"
402	server answer adr size s true
403	part reset_stream "reset UDP stream"
404	s configure "reset"
405	if s:is_crashed
406	console "DNS UDP stream crashed !  Restarting it." eol
407	s open "udp:/server/53" in+out+safe
408	s configure "priority high"
409	server please_stop_udp := false
410	status := success
411
412	method server stop_checkup
413	arg_rw DnsServer server
414	server please_stop_udp := true
415	while server:please_stop_udp
416	(var Stream s) open "udp://127.0.0.1/client/53" in+out+safe
417	s raw_write "[0]":characters 1
418	s close
419	sleep 0.1
420
421
422	define_tcp_server DnsServer dns_server
423	export dns_server dns_refresh dns_hits