REBOL [
	Title: "DNS protocol"
	Date: 19-Feb-2005
	Author: "VDemong"
	Email: vdemongodin@free.fr
	File: %dig.r
	Version: 0.0.1
	History: "First try"
	Purpose: { REBOL DIG : Implementation of DNS protocol (RFC 1035)  
          	  
		  URL is dig://name-server/TYPE/name
		   
		  ans: read dig://ns.thomething.com/SOA/thomething.com
		  ans: read dig://172.30.1.1/PTR/194.252.19.3
		  ans: read dig::/172.30.1.1/A/noway.myhome.com
		  
		  you can see a list of available TYPEs in cmd-list in beginning of code
		  
		  use ans/to-str to obtain readable answer:
		  
		  >> do %dig.r                                        
		  Script: "DNS protocol" (19-Feb-2005)
		  dig protocol loaded
		  >> ans: read dig://ns.libertysurf.net/SOA/tiscali.fr
		  connecting to: ns.libertysurf.net
		  >> print ans/to-str                                 
		  ;; REQUEST: SOA(6) for tiscali.fr
		  ;; id: 7724 AA: 1 RD: 1 RA: 0 ANSWER(s): 1 AUTHORITY(s): 2 ADDITIONAL(s): 2

		  ;; ANSWER(s):
	          tiscali.fr. 1800    SOA ns.libertysurf.net.  admin-dns.libertysurf.net.  2005021701  1800  900  1209600  1800

		  ;; AUTHORITY(s)
		  tiscali.fr. 604800  NS  ns.libertysurf.net.
                  tiscali.fr. 604800  NS  ns2.libertysurf.net.

		  ;; ADDITIONAL(s)
                  ns.libertysurf.net. 1800    A   213.36.80.2
                  ns2.libertysurf.net.    1800    A   213.36.80.4

                   >> 
		  
		  If you want to extract yourself information look at the structure of objects question,answer,resource and (xxx)-data in code 
    }
	Category: [protocol]
        Library: [
		level: 'advanced
		platform: 'all
		type: [protocol tool]
		domain: [other-net protocol]
		tested-under: "Mac OsX"
		support: vdemongodin@free.fr
		license: gpl
		see-also: none
        ]
]



make root-protocol [

	;; save usefull functions
	sys-copy: get in system/words 'copy
	net-log: get in net-utils 'net-log
	
	
	;; Supported commands
	cmd-list: sys-copy [
		"A/" 1 "address"
		"NS/" 2 "name server"
		"CNAME/" 5 "cononical name"
		"SOA/" 6 "source of authority"
		"MB/" 7 "mail box"
		"MG/" 8 "mai group"
		"MR/" 9 "mail rename"
		"NULL/" 10 "null" 
		"WKS/" 11 "well know service"
		"PTR/" 12 "domain name pointer"
		"HINFO/"  13 "host informatin"
		"MINFO/" 14 "mailbox information"
		"MX/" 15 "mail exchange"
		"TXT/" 16 "text"
		"ALL/" 255 "all"
	]
	
	;; Options
	recurse?: true  ;recursive question ?
	
	
	;; packet builder
	
	question: make object! [
		TYPE: sys-copy ["A/" 1 "address"]
		ID: 0 ; 
		RD: does [ either recurse? [1][0] ]
		QNAME: sys-copy ""
		
		to-str: does [
			typ: rejoin [sys-copy/part (first TYPE) (length? first TYPE) - 1 "(" second TYPE ")"]
			rejoin [";; REQUEST: "  typ " for " QNAME ]			
		]
	
		;;set the value of type
		set-command: function [cmd [string!]] [blk] [
			blk: find cmd-list cmd
		 	either blk = none [
		 		TYPE: sys-copy ["A/" 1 "address"]
		 	][
		 		TYPE: sys-copy/part blk 3
			]
		]

		;build binary data to send packet	see insert at the end of this code
		to-bin: does[
			ID: (to-integer now/time) // 65025 ; limit to 2 bytes 
			bin: sys-copy #{}
			append bin to-char ID / 255   ; first byte
			append bin to-char ID // 255  ; second byte
			append bin either recurse? [#{0100}][#{0000}] ; set or unset RD bit
			append bin #{0001000000000000} ; QDCOUNT =1 ANCOUNT,NSCOUNT,ARCOUNT=0
			if "PTR/" = first TYPE [
				QNAME:  reverse-ip QNAME ; get name in in-addr.arpa domain
			]
			append bin encode QNAME
			append bin #{00}
			append bin to-char second TYPE
			append bin #{0001} ; IN class
			bin
		]
	
		;build reverse IP for PTR request in in-addr.arpa domain	
		reverse-ip: func [ip [string!]][
			join reverse to-tuple ip ".in-addr.arpa"
		]
	
		;encode qname :  length string length string ... 0x00
		encode: function[name [string!]] [bin][
			bin: sys-copy #{}
			repeat token parse name "." [
				append bin to-char length? token
				append bin token
			]
			append bin #{00}
			bin
		]
	]	
	
	
	;; decoding packet returning this object in copy , see copy at the end of code 
	answer: make object! [
		
		ID: 0
		AA: 0
		RD: 0
		RA: 0
		RCODE: 0
		ANCOUNT: 0
		NSCOUNT: 0
		ARCOUNT: 0
		error: none
		ques: none
		answers: sys-copy []
		authoritys: sys-copy []
		additionals: sys-copy []
	
		init: function [ data [binary!] ] [pos rep][
			decode-header data
			if error = none [
				pos: decode-question data
				
				for ind 1 ANCOUNT 1 [
					rep: decode-answer data pos
					pos: first rep
					append answers second rep
				]
				
				for ind 1 NSCOUNT 1 [
					rep: decode-answer data pos
					pos: first rep
					append authoritys second rep
				]
				
				for ind 1 ARCOUNT 1 [
					rep: decode-answer data pos
					pos: first rep
					append additionals second rep
				]
			]
		]
		
		
		to-str: does [
			either error = none [
				str: rejoin [
					ques/to-str newline
					";; id: " ID " AA: " AA " RD: " RD " RA: " RA " ANSWER(s): " ANCOUNT " AUTHORITY(s): " NSCOUNT " ADDITIONAL(s): " ARCOUNT newline newline
					";; ANSWER(s):" newline
				]
				
				repeat a answers [ append append str a/to-str newline]
				append str newline
				append append str ";; AUTHORITY(s)" newline
				repeat a authoritys [ append append str a/to-str newline]
				append str newline
				append append str ";; ADDITIONAL(s)" newline
				repeat a additionals [ append append str a/to-str newline]
				str
					
			
			][
				rejoin [
					ques/to-str newline
					";; id: " ID " AA: " AA " RD: " RD " RA: " RA " ANSWER(s): " ANCOUNT newline newline ";; "
					error
				]
			]
		]
		
		
		;; RFC 1035 - 4.1.1
		decode-header: func [ data [binary!] ][
			ID: get-int16 data 0
			flags: get-int16 data 2
			AA: shl (mask flags 2#{0000010000000000}) 10
			RD: shl (mask flags 2#{0000000100000000}) 8
			RA: shl (mask flags 2#{0000000010000000}) 7
			RCODE: mask flags   2#{0000000000001111}
			
			switch/default RCODE [
				0 [
					ANCOUNT: get-int16 data 6
					NSCOUNT: get-int16 data 8
					ARCOUNT: get-int16 data 10
				]
				1 [ error: "1 - Format errror" ]
				2 [ error: "2 - Server failure" ]
				3 [ error: "3 - Name error" ]
				4 [ error: "4 - Not Implemented" ]
				5 [ error: "5 - Refused" ]
			][
				net-error reform ["invalid data RCODE=" RCODE ]
			]
		]
		
		;shift left
		shl: func [arg [integer!] len [integer!] ] [ arg / (2 ** len) ]
		
		;mask
		mask: func [arg [integer!] msk [binary!] ] [ arg and (to-integer msk) ]
		
		decode-question: function [ data [binary!] ] [pos rep typ cmd][
			ques: make question []
			ques/ID: ID
			ques/RD: RD
			pos: 12 ; begining of question
			rep: get-name data pos
			ques/QNAME: sys-copy/part second rep (length? second rep) - 1
			pos: first rep
			typ: get-int16 data pos
			cmd: back find cmd-list typ
			ques/TYPE: sys-copy/part cmd 3
			pos + 4			
		]
		
		;;RFC 1035 - 4.1.3  and 3.3.Standards RRs
		decode-answer: function [ data [binary!] pos [integer!] ] [rep ans nam typ cur-pos rdata str count] [
			rep: sys-copy []
			cur-pos: pos
			ans: make resource []
			nam: get-name data cur-pos
			cur-pos: first nam
			ans/name: second nam
			typ: get-int16 data cur-pos
			cmd: back find cmd-list typ
			ans/TYPE: sys-copy/part cmd 3
			cur-pos: cur-pos + 4 ; skip CLASS
			ans/TTL: get-int32 data cur-pos
			cur-pos: cur-pos + 4
			ans/RDLENGTH: get-int16 data cur-pos
			cur-pos: cur-pos + 2
			rdata: none
			
			name-case: [
				rdata: make name-data []
				str: get-name data cur-pos
				cur-pos: first str
				rdata/name: second str
			]
			
			switch typ [
				1 [ ; A
					rdata: make a-data []
					str: get-ip data cur-pos
					cur-pos: first str
					rdata/ip: second str
				]
				2 name-case ;NS
				5 name-case ;CNAME
				6 [ ; SOA
					rdata: make soa-data []
					str: get-name data cur-pos
					cur-pos: first str
					rdata/MNAME: second str
					str: get-name data cur-pos
					cur-pos: first str
					rdata/RNAME: second str
					rdata/SERIAL: get-int32 data cur-pos
					cur-pos: cur-pos + 4
					rdata/REFRESH:  get-int32 data cur-pos
					cur-pos: cur-pos + 4
					rdata/RETRY:  get-int32 data cur-pos
					cur-pos: cur-pos + 4
					rdata/EXPIRE:  get-int32 data cur-pos
					cur-pos: cur-pos + 4
					rdata/MINIMUM:  get-int32 data cur-pos
					cur-pos: cur-pos + 4
					
				]
				7 name-case ; MB
				8 name-case ;MG
				9 name-case ;MR
				10 [ ; NULL
					rdata: make garbage-data []
					rdata/data: sys-copy/part (at data cur-pos) ans/RDLENGTH
					cur-pos: cur-pos + ans/RDLENGTH
				]
				11 [ ; WKS
					rdata: make wks-data []
					str: get-ip data cur-pos
					cur-pos: first str
					rdata/ip: second str
					str: get-proto data cur-pos
					cur-pos: first str
					rdata/proto: second str
					str: get-bitmap data cur-pos
					cur-pos: first str
					rdata/bit-map: second str
					]
				12 name-case ;PTR
				13 [ ; HINFO
					rdata: make hinfo-data []
					str: get-string data cur-pos
					cur-pos: first str
					rdata/cpu: second str
					str: get-string data cur-pos
					cur-pos: first str
					rdata/os: second str
					
				]
				14 [ ; MINFO
					rdata: make minfo-data []
					str: get-name data cur-pos
					cur-pos: first str
					rdata/RMAILBOX: second str
					str: get-name data cur-pos
					cur-pos: first str
					rdata/EMAILBOX: second str
				]
				15 [ ; MX
					rdata: make mx-data []
					rdata/preference: get-int16 data cur-pos
					cur-pos: cur-pos + 2
					str: get-name data cur-pos
					cur-pos: first str
					rdata/exchange: second str
				]
				16 [ ; TXT
					rdata: make txt-data[]
					count: 0
					until [
						str: get-string data cur-pos
						cur-pos: first str
						count: count + first str
						append rdata/datas second str
						append rdata/datas newline
						(count >= ans/RDLENGTH)
					]
				]

			]
			ans/RDATA: rdata
			append append rep cur-pos ans
		]
		
		
		
		get-int16: func [ data [binary!] pos [integer!]  ] [
			to-integer sys-copy/part (at data pos + 1) 2 
		]
		
		get-int32: func [ data [binary!] pos [integer!]  ] [
			to-integer sys-copy/part (at data pos + 1) 4
		]
		
		get-string: function [ data [binary!] pos [integer!]  ] [cur-pos ind rep][
			rep: sys-copy []
			cur-pos: pos + 1
			len: to-integer pick data cur-pos
			str: to-string sys-copy/part (at data cur-pos + 1) len
			append rep (pos + len + 1)
			append rep str
		]
		
		get-name: function [ data [binary!] pos [integer!]  ] [cur-pos ptr str rep tmp][
			rep: sys-copy []
			cur-pos: pos + 1
			len: to-integer pick data cur-pos
			if len = 0 [return append append rep (pos + 1) sys-copy ""]
			if (to-integer #{C0}) = mask len #{C0} [
				ptr: get-int16 data pos
				ptr: ptr xor (to-integer #{C000})
				return append append rep  (pos + 2) second get-name data ptr
			]
			str: get-string data pos
			pos: first str
			tmp: get-name data pos
			append append rep first tmp rejoin [second str "." second tmp]  
			
		]
		
		get-proto: function [ data [binary!] pos [integer!]  ] [rep][
			rep: sys-copy []
			append append rep (pos + 1)  pick data pos
		]
		
		get-bitmap: function [ data [binary!] pos [integer!]  ] [rep][
			rep: sys-copy []
			append append rep (pos + ans/RDLENGTH - 3)  (tsys-copy/part (at data pos) (ans/RDLENGTH - 3))					
		]
		
		get-ip: function [ data [binary!] pos [integer!]  ] [rep adr][
			rep: sys-copy []
			append append rep (pos + 4)  (to-tuple sys-copy/part (at data pos + 1) 4)
		]
	]
	
	;; resource and resource types
	 resource: make object! [
	 	NAME: sys-copy ""
	 	TYPE: none
	 	TTL: 0
	 	RDLENGTH: 0
	 	RDATA: none
	 	to-str: does [
	 		if not (type = none) [
	 			rejoin [NAME TAB TTL TAB sys-copy/part (first TYPE) (length? first TYPE) - 1 TAB RDATA/to-str ]
	 		]
	 	]
	 ]
	 
	 ;; NS CNAME MB MG MR PTR
	 name-data: make object! [
	 	name: sys-copy ""
	 	to-str: does [ name]
	 ]
	 
	 ;; TXT
	 txt-data: make object! [
	 	datas: sys-copy ""
	 	to-str: does [ datas]
	 ]
	 
	 ;; HINFO
	 hinfo-data: make object! [
	 	cpu: sys-copy ""
	 	os: sys-copy ""
	 	to-str: does [ rejoin ["cpu: " cpu " os: " os]]
	 ]

	;; MINFO
	minfo-data: make object! [
		RMAILBOX: sys-copy ""
		EMAILBOX: sys-copy ""
		to-str: does [  rejoin [RMAILBOX "  " EMAILBOX] ]
	]
	 
	;; MX 
	mx-data: make object! [
		preference: 0
		exchange: sys-copy ""
		to-str: does [rejoin [preference "   " exchange]]
	]
	
	;; SOA
	soa-data: make object! [
		MNAME: sys-copy ""
		RNAME: sys-copy ""
		SERIAL: 0
		REFRESH: 0
		RETRY: 0
		EXPIRE: 0
		MINIMUM: 0
		to-str: does [ 
			rejoin [
				MNAME "  "
				RNAME "  "
				SERIAL "  "
				REFRESH "  "
				RETRY "  "
				EXPIRE "  "
				MINIMUM
			]		
		]
	]
	
	;; A
	a-data: make object! [
		ip: none
		to-str: does [to-string ip]
	]
	
	;; WKS
	wks-data: make object! [
		ip: none
		proto: 0
		bit-map: sys-copy #{00}
		to-str: does [
			str: sys-copy ""
			append str to-sring ip
			append str "  "
			append str switch/default proto [ 6 ["tcp"] 17 ["udp"]] [ proto ]
			append str "  "
			i: 0
			repeat byte bit-map [
				val: to-integer byte
				for j 8 1 -1 [
					if j = (j and val) [
						append str i " "
					]
					i: i + 1
				]
			]
		]
	]
		
	
	
	;; NULL
	garbage-data: make object! [
		data: none
		to-str: does [data]
	]
	
	
	;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 
	;;protocol methods and fields
	
	scheme: 'dig
	port-id: 53
	port-flags: system/standard/port-flags/pass-thru or 32
	
	open: func [port] [
		open-proto/sub-protocol port 'udp
		if none <> port/target [
			insert port port/target
		]
	]
	
	insert: function [port data] [bin][
		quest: make question [ QNAME: data ]
		quest/set-command port/path
		net-log quest/to-str
		bin: quest/to-bin
		write-io port/sub-port bin length? bin
	]
	
	copy: function [port] [buffer length][
		buffer: make binary! 512
		until [
			length: read-io port/sub-port buffer 512
			(length <= 512)
		]
		net-log rejoin ["COPY read " length? buffer " byte(s)"]
		ans: make answer []
		ans/init buffer
		ans
	]
	
	read: func [port] [
		net-log "READ port"
		insert port port/target
	]
	
	
	
	net-utils/net-install 'dig self 53

]