{$M-,X+}
program serve;

include {NOLIST} 'jsys.def';
include {NOLIST} 'domain:mdep.def';
include {NOLIST} 'domain:master.def';
include {NOLIST} 'domain:lparse.def';
include {NOLIST} 'domain:naddrr.hdr';
include {NOLIST} 'domain:irdata.hdr';
include {NOLIST} 'domain:tport.hdr';
include {NOLIST} 'domain:msub.hdr';
include {NOLIST} 'domain:pp.hdr';
include {NOLIST} 'domain:mdep.hdr';
include {NOLIST} 'domain:msure.hdr';
include {NOLIST} 'domain:iomsg.hdr';
include {NOLIST} 'domain:dump.hdr';

const	recursion_limit=10;	{ This value is used to define the maximum
				  number of times the search algorithm will
				  follow CNAME chains, etc.; the limit
				  prevents infinite loops during searches.

				  The actual value is stored in the variable
				  recursion_left, and must be decremented and
				  checked every time a potential for loop
				  occurs
				}

var	master:master_block_pointer;	{ base of all tables }
	csavings,gmtoff:integer;
	scratch:packed array[1..20] of char;
	i,ns_handle:integer;
	bp:g1bpt;
	message:domsg;
	m_tport:transport;
	raw_message:rawmsg;
	class_index:dclass;
	low_class,high_class:dclass;
	time_value:integer;
	recursion_left:integer;		{ used to prevent infinite loops }
	discard, ok:boolean;

	query_qclass,query_qtype:integer;
	original_query_name:dname_string;
	search_name:dname_string;
	search_cased_name:dname_string;
	search_dst:dname_string_table;
	asp_done:packed array[sectcode] of array [0..max_rrs] of boolean;
procedure sq_one_class(		search_qtype:qtype;
				search_class:dclass;
				dest_section:sectcode;
				ezone:zone_entry_pointer { NS glue zone }
			);forward;

procedure size_graph(msize:integer;
		     savings:integer);

{ This procedure graphs the domain message size and compression savings
  for packets sent by the name server }

var	myfbp:file_blk_ptr;

begin
if master^.logua<>0
then begin
	 myfbp:=ofile(log);
	 writeln(myfbp^.fident,'Domain message size ',msize:4,
		 ' Compression savings ',savings:4);
	 cfile(myfbp);
     end;

if msize<1 then msize:=0 else if msize>512 then msize:=512;
xaos(master^.measure.nsusiz[msize]);

if savings<0 then savings:=0
   else if savings>maxcs then savings:=maxcs;
xaos(master^.measure.nsucs[savings]);

end;

function rrcomp(rrbp:g1bpt;
		myrr:rr_pointer):boolean;

{ This function checks to see that the data in a RR is the same
  as in a string }

var  myttl,mylen,tlen:integer;
     mychunk:rdchunk_pointer;
     bp:g1bpt;
     test_name:dname_string;
     result:boolean;
begin
if xildb2(rrbp)<>ord(myrr^.rrtype) { check the type }
then rrcomp:=false
else if xildb2(rrbp)<>ord(myrr^.rrclass) { check the class }
     then rrcomp:=false
     else begin
     		myttl:=xildb4(rrbp);
		mylen:=xildb2(rrbp);
		mychunk:=myrr^.rdata;
		result:=true;
		while result and (mychunk<>NIL)
		do begin
		       if mychunk^.ckind=lit_chunk
		       then with mychunk^.litdata^ (* binary data compare *)
			    do if lcount>mylen
			       then result:=false
			       else begin
					 bp:=xseto(ldata);
					 xadjbp(bp,2);
					 if ccomp(bp,rrbp,lcount)
					 then begin
						  xadjbp(rrbp,lcount);
						  mylen:=mylen-lcount
					      end
					 else result:=false
				    end
		       else begin { domain name }
			    bp:=xseto(test_name);
			    cvdnp(mychunk^.rrname,bp);
			    bp:=xseto(test_name);
			    tlen:=lendns(bp);
			    if tlen<>lendns(rrbp)
			    then result:=false
			    else if ccomp(bp,rrbp,tlen)
				 then begin
					  xadjbp(rrbp,tlen);
					  mylen:=mylen-tlen
				      end
				 else result:=false
			    end;
			 mychunk:=mychunk^.more
		   end;
		rrcomp:=result and (mychunk=NIL) and (mylen=0)
	  end
end; { RRCOMP }
function lenrdata(myrr:rr_pointer):integer;

{ This function returns the length of the rdata section of an RR,
  not including the fixed 10 byte header }

var	ptr:rdchunk_pointer;
	dnp:dname_pointer;
	count:integer;
begin
count:=0;
ptr:=myrr^.rdata;
while ptr<>NIL
do begin
  	if ptr^.ckind=lit_chunk
	then { binary } 
		count:=count+ptr^.litdata^.lcount
	else { dname }
		begin
		dnp:=ptr^.rrname;
		while dnp<>NIL
		do begin
			count:=count+dnp^.dlabel.labptr^.text[0]+1;
			dnp:=dnp^.more
		   end
		end;
	ptr:=ptr^.more
   end;
lenrdata:=count;
end; { lenrdata }
procedure cpyrr(    myrr:rr_pointer;
 	 	 var bp:g1bpt);

{ This routine outputs a RR in linear format, including its fixed header.
  The byte pointer gets updated }

var	count,sum:integer;
	temp_bp,frombp,sumptr:g1bpt;
	ptr:rdchunk_pointer;
	dnp:dname_pointer;
begin
{ Output the fixed header }
xidpb2(bp,ord(myrr^.rrtype));
xidpb2(bp,ord(myrr^.rrclass));
xidpb4(bp,myrr^.ttl);
sumptr:=bp;
xidpb2(bp,0); (* reserve space *)
sum:=0;

ptr:=myrr^.rdata;
while ptr<>NIL
do begin
  	if ptr^.ckind=lit_chunk
	then { binary } 
	     begin
		 frombp:=xseto(ptr^.litdata^.ldata);
		 count:=xildb2(frombp);
		 sum:=sum+count;
		 ccopy(frombp,bp,count)
	     end
	else { dname }
		begin
		dnp:=ptr^.rrname;
		temp_bp:=bp;
		cvdnp(dnp,bp); { copy with case adjustment }
		sum:=sum+lendns(temp_bp);
		end;
	ptr:=ptr^.more
   end;
xidpb2(sumptr,sum)
end; (* cpyrr *)
function copy_hits(	search_qtype:qtype;
			use_nodename:boolean;
			from_node:node_pointer;
			dest_section:sectcode):integer;

{	COPY_HITS copies all RRs that match search_qtype into
	the specified section.  SCAN points to a RR chain.

	The value of copy_hits is equal to the number of RRs copied
	or duplictes tossed }

var	i,len_name,len_new_rr,copied:integer;
	scan:rr_pointer;
	name_stored,found:boolean;
	node_name_bp,bp,equal_name:g1bpt;
	scan_sect:sectcode;
	node_name:dname_string;
begin
scan:=from_node^.rr_ptr;
copied:=0;
name_stored:=false; (* name not already stored in domsg *)
if use_nodename
then begin
	 node_name_bp:=xseto(node_name);
	 bp:=node_name_bp;
	 cvnnp(from_node,bp);
     end
else node_name_bp:=xseto(search_cased_name);
while scan<>NIL
do begin
       if tmatch(internet,search_qtype,scan^.rrtype)
       then begin
	    found:=false; (* look for a duplicate RR *)
	    for scan_sect:=answer to dest_section
	    do if not found
	       then with message.parse[scan_sect]
		    do begin (* check all RRs in a section *)
			   i:=1;
			   while not(found) and (i<=count)
			   do if dnscomp(node_name_bp,rdv[i].namebp)
			      then begin { names match }
				   equal_name:=rdv[i].namebp;
				   repeat if rdv[i].namebp=equal_name
				          then if rrcomp(rdv[i].databp,scan)
					       then found:=true
					       else begin
							i:=i+1;
							if i<=count
							then if rdv[i].namebp<>equal_name
							     then equal_name:=nil
							     else
						   end
				   until found or (i>count) or (equal_name=NIL)
				   end
			      else i:=i+1 { names don't match }
		       end;
	    if not found
	    then with message.parse[dest_section]
		 do begin (* not a duplicate, add it *)
			len_name:=lendns(node_name_bp);
			len_new_rr:=lenrdata(scan)+10;
			if not name_stored
			then len_new_rr:=len_new_rr+len_name;
			if (count=max_rrs) or (message.free_cnt<len_new_rr)
			then truncated:=true
			else begin (* create the RR *)
				message.free_cnt:=message.free_cnt-len_new_rr;
				count:=count+1;
				asp_done[dest_section][count]:=false;
				if name_stored
				then rdv[count].namebp:=rdv[count-1].namebp
				else begin
					  rdv[count].namebp:=message.free_ptr;
					  copydns(node_name_bp,message.free_ptr);
					  xadjbp(message.free_ptr,len_name);
					  name_stored:=true
				      end;
				 rdv[count].databp:=message.free_ptr;
				 cpyrr(scan,message.free_ptr);
			     end;
		    end;
	    copied:=copied+1
	    end;
       scan:=scan^.next
   end;
copy_hits:=copied

end; { copy_hits }

function csearch(	search_qtype:qtype;
			search_class:dclass;
			dest_section:sectcode):boolean;

begin
csearch:=false	{ no cache search for now }
{ Fix output routine to understand TTL }
end; { csearch }

procedure asp(scode:sectcode;	{ section of entry to check }
	      index:integer;	{ entry index }
	      ez:zone_entry_pointer);	{ glue search zone }

{	ASP does the additional section processing for a
	single entry in the message }

var	cdscan,csize:integer;
	chunk:g1bpt;
	table:rdata_table_pointer;
	myclass:dclass;
	icode:rdata_field;
begin
if not asp_done[scode][index]
then begin
	asp_done[scode][index]:=true;
	chunk:=message.parse[scode].rdv[index].databp;
	myclass:=f_class(chunk);
	table:=irdata(myclass);
	with table^[f_type(chunk)]
	do begin
		st_rdata(chunk); (* skip to rdata *)
		cdscan:=1;
		repeat icode:=rdata_item[cdscan];
		       case icode of
		dname_field: begin
			     csize:=lendns(chunk);
			     if rdata_asp[cdscan]<>ord(dtype_l_bound)
			     then begin { asp required }
				  ccdns(chunk,xseto(search_name));
				  copydns(chunk,xseto(search_cased_name));
				  m_dst(xseto(search_name),search_dst);
				  sq_one_class(rdata_asp[cdscan],
					       myclass,additional,ez)
				  end;
			     end;
		cstring_field:     csize:=peekb(chunk)+1;

		time_field,int32_field,inet_a_field: csize:=4;

		int16_field: csize:=2;

		inet_p_field: csize:=1;

		others:	      icode:=no_more_field
		       end; { case }
		       xadjbp(chunk,csize);
		       cdscan:=cdscan+1;
		until  icode=no_more_field
	   end;
   end
end; { asp }

procedure asp_all;

{	ASP_ALL calls ASP to perform additional section processing for
	the message
}

var	scode:sectcode;
	i:integer;

begin
for scode:=answer to authority	{ don't asp the additional section }
do with message.parse[scode]
   do begin
	   i:=1;
	   while i<=count { and records in the section }
	   do begin
		   if not asp_done[scode][i] { if not already done }
		   then	{ and there is space for an answer }
			if (message.parse[additional].count<max_rrs) and
			    not(message.parse[additional].truncated)
			then asp(scode,i,NIL); { do asp }
		   i:=i+1
	      end
      end

end; { asp_all }
function asearch(	search_qtype:qtype;
			search_match:integer;
		 	myzone:zone_entry_pointer;
			dest_section:sectcode;
			glue_search:boolean
		):boolean;

{ ASEARCH searches an authoritative zone for the desired RR
  or RRs.  The search terminates with a referral, name error, or
  answer for a normal search.  If a glue serch is specified, the
  search terminates in an answer or failure, but never a referral

  ASEARCH returns true if the search completed the request, i.e.
  found the answer, or found that the node didn't exist }

type	search_state=(above,inside,below);	{ where is serch in zone with
						respect to region of authority}

var	result:boolean;
	state:search_state;
	spoint,next_spoint:node_pointer;
	aresult,search_cond:boolean;
	scan:rr_pointer;
	toss:integer;
	start_refs,hit_idex:integer;

	procedure include_soa;

	begin { this gets called when the SOA may want to be copied into
	        the authority section if we are putting authoritative stuff
		in the answer section }
        if (dest_section=answer) and (recursion_left=recursion_limit)
        then toss:=copy_hits(ord(soa),true,myzone^.zsoa,authority)
	end; { include_soa }
	
	function star_search:boolean;

	{	STAR_SEARCH looks for a * label match	}
	
	var	star_label:packed array[0..63] of octet;
		toss:integer;

	begin
	star_label[0]:=1;
	star_label[1]:=ord('*');
	if f_son(spoint,xseto(star_label),spoint,toss)
	then begin
		  start_refs:=message.parse[dest_section].count+1;
		  toss:=copy_hits(search_qtype,false,spoint,dest_section);
		  star_search:=true
	     end
	else star_search:=false
	end { star_search };

begin
{ Initialize the search.  For a regular zone it starts where the search
  tree left off.  For a glue search, it must restart at the root }

if glue_search
then begin
	 state:=above; (* start glue search at root *)
	 spoint:=myzone^.zone_node;
	 search_match:=search_dst.count
     end
else begin
	 state:=inside;		{ initialize search state to inside (SOA) }
	 spoint:=myzone^.zsoa;	{ search pointer to top of authority }
     end;

{ Now descend to the named node, name error, or delegation }

if search_match>1 (* are there more labels to match *)
then repeat search_match:=search_match-1;
   	    search_cond:=f_son(spoint,search_dst.bp[search_match],next_spoint,toss);
	    if search_cond
	    then begin
		 spoint:=next_spoint;
		 case state of
    above:	    if spoint^.node_lchain<>NIL then state:=inside;
    inside:	    if spoint^.node_lchain=NIL (* drop off the bottom? *)
		    then begin
			  state:=below;
			  if not glue_search then search_cond:=false
		         end;
    below:	 end { case }
		 end
	    else search_match:=search_match+1;
     until  (search_cond=false) or (search_match=1);

{ search is complete, separate cases }
aresult:=(search_match=1) and ( (state=inside) or glue_search);
start_refs:=message.parse[answer].count+1; { save for glue scan iff top node }
if aresult
then { found the node }
     if copy_hits(search_qtype,true,spoint,dest_section)=0
     then { Nothing copied, go for cname }
	  if not(glue_search) and (dest_section=answer)
	  then if copy_hits(ord(CNAME),true,spoint,answer)<>0
	       then { CNAME there, restart search }
		    if recursion_left>0
		    then begin { restart query }
			 recursion_left:=recursion_left-1;
			 scan:=spoint^.rr_ptr;
			 while scan^.rrtype<>CNAME
			 do scan:=scan^.next;
			 bp:=xseto(search_name);
			 ccvdnp(scan^.rdata^.rrname,bp);
			 bp:=xseto(search_cased_name);
			 cvdnp(scan^.rdata^.rrname,bp);
			 m_dst(xseto(search_name),search_dst);
			 sq_one_class(search_qtype,scan^.rrclass,answer,NIL);
			 recursion_left:=recursion_left+1
		         end
		    else message.dhead.rcode:=server_failure
	       else { No CNAME there }
	  else
     else (* answers copied, all done *)
	  if state=inside
	  then begin
		   include_soa; (* add SOA to AA answer *)
		   if (dest_section=answer) and (spoint=myzone^.zsoa)
		   then for hit_idex:=start_refs to message.parse[answer].count
		        do if (hit_idex<=max_rrs) (* special asp for top ns *)
			   then if f_type(message.parse[answer].rdv[hit_idex].databp)=ns
			        then asp(answer,hit_idex,myzone)
	       end
	  else
else if not glue_search { did not find the node }
     then if state=below { search of authoritative zone}
	  then if dest_section=answer	{ referral }
	       then begin (* pass on referrals for question only *)
		       start_refs:=message.parse[authority].count+1;
		       if copy_hits(ord(ns),true,spoint,authority)>0
		       then { special search for NS referrals }
			    for hit_idex:=start_refs to message.parse[authority].count
			    do asp(authority,hit_idex,myzone)
		    end
	       else
	  else { either name error or * match }
	       begin
		   aresult:=true;
		   if not star_search
		   then if dest_section=answer
			then message.dhead.rcode:=name_error;
		   include_soa
	       end;
	  
asearch:=aresult
end; { asearch }

procedure sq_one_class;

{	sq_one_class processes a standard query for a specific class.

	It returns true if it finds the answer. (Regardless of zone) }

var	auth_zone:zone_entry_pointer;
	result:boolean;
	scanptr:zone_entry_pointer;
	now_at:node_pointer;
	i,search_last,toss:integer;
	s_result:boolean;
begin
auth_zone:=NIL;
{ Find and lock authoritative zone (if any) }
while not locks(master^.search_zone.zone_lock,100,2000) do; {get search lock}
now_at:=master^.search_zone.zone_node;

i:=search_dst.count; (* start at root *)
repeat	if now_at^.zone_ptr<>NIL
	then	begin (* find zone with matching class *)
		scanptr:=now_at^.zone_ptr;
		while scanptr<>NIL
		do	if (scanptr^.zone_class=search_class)
				AND
			   scanptr^.loaded
			then	begin
				auth_zone:=scanptr;
				search_last:=i;
				scanptr:=NIL
				end
			else	scanptr:=scanptr^.zone_chain
		end;
	i:=i-1;	(* move down one label *)
	if i<>0
	then	s_result:=f_son(now_at,search_dst.bp[i],now_at,toss)
until	(i=0) or (not(s_result));
if auth_zone<>NIL (* lock the authoritative zone *)
then while not locks(auth_zone^.zone_lock,100,2000) do;
ulocks(master^.search_zone.zone_lock); {release search zone lock}

if auth_zone<>NIL
then	{ search a zone where authoritative answer or delegation will result }
	begin
	result:=asearch(search_qtype,
			search_last,
			auth_zone,
			dest_section,
			false);
	if (dest_section=answer)
		AND
	   (recursion_left=recursion_limit)
	then message.dhead.aa:=result
	end
else	result:=false;

{ is no authoritative search was performed, or if it didn't get the
  answer, try searching the cache }

if not result
then	result:=csearch(search_qtype,
			search_class,
			dest_section);

{ if we still don't have the answer, but a glue zone was specified,
  try searching it }

if (not(result)) and (ezone<>NIL)
then	result:=asearch(search_qtype,
			search_last,
			ezone,
			dest_section,
			true);

if auth_zone<>NIL (* unlock authoritative zone, if any *)
then ulocks(auth_zone^.zone_lock);
end; { sq_one_class }
procedure dosq;

var	qindex:qgraph_index;
	myatom:atom;
	myfbp:file_blk_ptr;
	toss:integer;

begin {dosq}
if (message.parse[question].count<>1) or message.parse[question].truncated
then message.dhead.rcode:=format_error
else begin
	 message.dhead.rcode:=0; { presume innocence }
	 message.dhead.aa:=false;
	 with message.parse[question].rdv[1] (* setup query *)
	 do begin
		bp:=databp;
		query_qtype:=xildb2(bp);
		query_qclass:=xildb2(bp);
		copydns(namebp,xseto(search_cased_name));
		copydns(namebp,xseto(original_query_name));
		ccdns(namebp,xseto(search_name));
		m_dst(xseto(search_name),search_dst)
	    end;

	 if (query_qtype>0) and (query_qtype<=qslots) (* qgraph *)
	 then qindex:=query_qtype else qindex:=qslots;
	 xaos(master^.measure.nsbyqt[qindex]);

	 if (query_qclass>0) and (query_qclass<=cslots) (* cgraph *)
         then qindex:=query_qclass else qindex:=cslots;
	 xaos(master^.measure.nsbyqc[qindex]);

	 if query_qclass=star	(* setup class loop *)
	 then	begin
		    low_class:=succ(dclass_l_bound);
		    high_class:=pred(dclass_h_bound)
		end
	 else	if query_qclass>=ord(dclass_h_bound)
	        then	message.dhead.rcode:=format_error
		else	begin
			    low_class:=chrclass(query_qclass);
			    high_class:=low_class
			end;
		
	 if message.dhead.rcode=0 { loop over search classes }
	 then for class_index:=low_class to high_class
	      do begin
		     recursion_left:=recursion_limit;
		     sq_one_class(query_qtype,class_index,answer,NIL)
		 end;
	 asp_all;	{ perform asp }
		     
	 if low_class<>high_class then message.dhead.aa:=false;

	 { Update counts }
	 message.dhead.ancount:=message.parse[answer].count;
	 message.dhead.nscount:=message.parse[authority].count;
	 message.dhead.arcount:=message.parse[additional].count;

	 if master^.logns<>0 (* name server summary logging *)
	 then begin
		  myfbp:=ofile(log);
		  dmphst(myfbp^.fident,m_tport.foreign_address);
		  write(myfbp^.fident,' ');
		  write(myfbp^.fident,message.dhead.domain_id:4:h);
		  write(myfbp^.fident,' ');
		  ppqtype(query_qtype,myatom);
		  toss:=dmpatom(myfbp^.fident,myatom);
		  write(myfbp^.fident,' ');
		  ppqclass(query_qclass,myatom);
		  toss:=dmpatom(myfbp^.fident,myatom);
		  write(myfbp^.fident,' ');
		  toss:=dmpdns(myfbp^.fident,xseto(original_query_name));
		  if message.dhead.rcode<>0
		  then write(myfbp^.fident,' RCODE=',message.dhead.rcode:1);
		  writeln(myfbp^.fident);
		  cfile(myfbp)
	      end
	 
    end;
	 
end; {dosq}
procedure serve;

var     ac1,ac2,ac3:integer;
	toss:integer;
	baseline:fruse;
	sect_idex:sectcode;

begin { serve }

jsys(odtim;scratch,-1,0); (* compute ODTIM offset for GMT to local *)
for ac1:=11 to 20
do if (scratch[ac1]>'0') and (scratch[ac1]<='9')
   then scratch[ac1]:='0';
jsys(idtim,1;scratch,0;ac1,gmtoff);

master:=getmaster;

baseline:=master^.measure.nusage; (* setup fork resource measurement *)
jsys(runtm;fhslf;ac1,ac2,ac3);
master^.measure.nusage.elwb:=ac3;

u_initialize(true, (* this is a server *)
	     dns_socket,toss,ns_handle);

while true (* forever *)
do begin
   if u_receive(ns_handle,raw_message,true)
   then	if not p_rawmsg(message,m_tport,raw_message)
        then xaos(master^.measure.pfail)
        else if message.dhead.response (*  ignore bogons *)
	     then begin
		  xaos(master^.measure.bogon);
	          xaos(master^.measure.nsuhst[hlook(m_tport.foreign_address,
				  master^.measure.nsuhst)].touts)
		  end
	     else begin
		     time_value:=msclock;
		     xaos(master^.measure.nsuhst[hlook(m_tport.foreign_address,
				  master^.measure.nsuhst)].touts);
		     xaos(master^.measure.nsugra.touts);
		     message.dhead.response:=true;

		     case message.dhead.opcode of

std_query:	       dosq; { standard query }

inv_query:	       message.dhead.rcode:=not_implemented; { inverse query }
    
cm_query:              message.dhead.rcode:=not_implemented;

cu_query:              message.dhead.rcode:=not_implemented;

others:                message.dhead.rcode:=format_error

		     end; { case by query type}

		     { do statistics for AA, truncation, section sizes }
		     if message.dhead.aa then xaos(master^.measure.nsaa);

		     for sect_idex:=question to additional
		     do with message.parse[sect_idex],master^.measure.nssgra[sect_idex]
			do begin
			       if truncated then xaos(strun);
			       xaos(ssize[min(count,sgmax)])
			   end;

		     { send response in message }
		     f_rawmsg(message,m_tport,raw_message,csavings);
		     s_rawmsg(ns_handle,m_tport,raw_message);
		     if raw_message.dhead.tc then xaos(master^.measure.nudptc);
		     size_graph(raw_message.iplength-ip_hdr_sz-udp_hdr_sz
				,csavings);
		     time_value:=msclock-time_value;
		     thisto(master^.measure.nsugra,time_value);
		     hhisto(master^.measure.nsuhst,time_value,m_tport.foreign_address);
		     xaos(master^.measure.nsucod[message.dhead.rcode]);
		     end;

   jsys(gtad;;ac1); (* bump time of day graph *)
   ac1:=bshift(band(ac1-gmtoff,rh)*(dimax+1),-18);
   xaos(master^.measure.nsbyds[ac1]);

   ruse(master^.measure.nusage,baseline)	  
   end
end.