/pliant/protocol/dns/common.pli
1	abstract
2	[DNS protocol related data types, and caching mechanism.]
3
4
5	module "/pliant/language/unsafe.pli"
6	module "/pliant/language/stream/stream.pli"
7	module "/pliant/language/stream/udp.pli"
8	module "/pliant/fullpliant/this_computer.pli"
9	module "/pliant/protocol/dns/name.pli"
10
11	scope "/pliant/protocol/dns/"
12	public
13
14	constant minimum_timeout 120
15
16	doc
17	[Data types.]
18
19	type DnsHeader
20	packed
21	field uInt16_hi id
22	field uInt16_hi flags
23	field uInt16_hi qdcount ancount nscount arcount
24
25	type DnsTail
26	packed
27	field uInt16_hi qtype qclass
28
29	type DnsAnswer
30	packed
31	field uInt32_hi ttl
32	field uInt16_hi rdlength
33
34
35	doc
36	[Compressed names encoding and decoding.]
37
38	function read_name buf offset limit -> name
39	arg Address buf ; arg_rw Int offset ; arg Int limit ; arg Str name
40	name := ""
41	var Int start := offset
42	while true
43	if offset>=limit
44	return ""
45	var uInt8 len := (buf translate Byte offset) map uInt8 ; offset += 1
46	if len=0
47	if name:len>0
48	name := name 0 name:len-1
49	return
50	eif len<64
51	if offset+len>=limit
52	return ""
53	(var Str one) set (buf translate Byte offset) len false ; offset += len
54	name += one+"."
55	eif len<192
56	return ""
57	else
58	if offset+1>=limit
59	return ""
60	var Int offset2 := ((buf translate Byte offset) map uInt8)+(len-192)*256 ; offset += 1
61	var Str subname := read_name buf offset2 start
62	if subname<>""
63	return name+subname
64	else
65	return ""
66
67
68	function write_name buf offset limit name
69	arg Address buf ; arg_rw Int offset ; arg Int limit ; arg Str name
70	var Str all := name+"."
71	while (all eparse any:(var Str first) "." any:(var Str remain))
72	var uInt8 len := first len
73	if offset+2+len>=limit
74	return
75	(buf translate Byte offset) map uInt8 := len ; offset += 1
76	memory_copy first:characters (buf translate Byte offset) len ; offset += len
77	all := remain
78	(buf translate Byte offset) map uInt8 := 0 ; offset += 1
79
80
81	doc
82	[Parsing an answer to find the shortest timeout.]
83
84	function answer_timeout answer -> timeout
85	arg Str answer ; arg Int timeout
86	var Address buf := answer characters ; var Int limit := answer len
87	if DnsHeader:size>limit
88	return undefined
89	timeout := 30*86400
90	var Pointer:DnsHeader h :> buf map DnsHeader ; var Int offset := DnsHeader size
91	for (var Int i) 0 h:qdcount+h:ancount+h:nscount+h:arcount-1
92	var Str id := read_name buf offset limit
93	if offset+DnsTail:size>limit
94	return
95	var Pointer:DnsTail t :> (buf translate Byte offset) map DnsTail ; offset += DnsTail size
96	if i>=h:qdcount
97	if offset+DnsAnswer:size>limit
98	return
99	var Pointer:DnsAnswer a :> (buf translate Byte offset) map DnsAnswer ; offset += DnsAnswer size
100	if offset+a:rdlength>limit
101	return undefined
102	if a:ttl<30*86400
103	timeout := min timeout a:ttl
104	offset += a:rdlength
105	if offset<>limit
106	# console "wrong DNS answer size" eol
107	return undefined
108	timeout := max timeout minimum_timeout
109	# console "DNS answer timeout is " timeout eol
110
111
112
113
114	doc
115	[Caching.]
116
117	type CacheEntry
118	field Str answer
119	field Int hits
120	field DateTime expires
121
122	gvar Sem sem
123	gvar Dictionary cache
124	gvar Int cache_size := 1024
125
126
127	function set_cache query answer
128	arg Str query answer
129	var DateTime now := datetime
130	var Int timeout := answer_timeout answer
131	var Link:CacheEntry e :> new CacheEntry
132	e answer := answer 2 answer:len
133	e hits := 0
134	e expires := now ; e:expires seconds += timeout
135	sem request
136	if cache:count>=cache_size
137	var Intn total := 0
138	each ee cache type CacheEntry
139	total += ee hits
140	var Intn threshold := total\cache:count
141	var List drop
142	each ee cache type CacheEntry getkey k
143	if ee:expires<=now or ee:hits<=threshold
144	ee answer := k
145	drop append addressof:ee
146	else
147	ee hits \= 2
148	var Pointer:Arrow c :> drop first
149	while c<>null
150	cache remove (c map CacheEntry):answer c
151	c :> drop next c
152	this_computer:env:"pliant":"dns":"cache_size" parse cache_size
153	cache insert (query 2 query:len) true addressof:e
154	sem release
155
156
157	function query_cache query -> answer
158	arg Str query answer
159	var DateTime now := datetime
160	sem rd_request
161	var Pointer:Arrow c :> cache first (query 2 query:len)
162	if c<>null
163	var Link:CacheEntry e :> c map CacheEntry
164	if e:expires>=now
165	answer := (query 0 2)+e:answer
166	e hits += 1
167	sem rd_release
168	return
169	sem rd_release
170	answer := ""
171
172
173	doc
174	['query_providers' will forward the request to external DNS servers, then record the answer in the cache.]
175
176	function query_provider query server timeout -> answer
177	arg Str query server ; arg Float timeout ; arg Str answer
178	(var Stream fwd) open "udp://"+server+"/client/53" in+out+safe
179	fwd configure "priority high"
180	fwd writechars query
181	fwd configure "timeout "+string:timeout
182	fwd read_available (var Address adr2) (var Int size2)
183	if size2<>0
184	answer set (memory_allocate size2 addressof:answer) size2 true
185	memory_copy adr2 answer:characters size2
186	set_cache query answer
187	else
188	answer := ""
189
190	function query_providers query -> answer
191	arg Str query answer
192	for (var Int lap) 0 4
193	each provider this_computer:env:"pliant":"dns"
194	if (keyof:provider parse "provider" any) and provider<>""
195	answer := query_provider query provider (min 2^lap 4)
196	if answer:len<>0
197	return
198	answer := ""