httpserver_20080306/dnsasync.pas

   1 { Copyright (C) 2005 Bas Steendijk and Peter Green\r
   2   For conditions of distribution and use, see copyright notice in zlib_license.txt\r
   3   which is included in the package\r
   4   ----------------------------------------------------------------------------- }\r
   5 \r
   6 //FIXME: this code only ever seems to use one dns server for a request and does\r
   7 //not seem to have any form of retry code.\r
   8 \r
   9 unit dnsasync;\r
  10 \r
  11 interface\r
  12 \r
  13 uses\r
  14   {$ifdef win32}\r
  15     dnswin,\r
  16   {$endif}\r
  17   lsocket,lcore,\r
  18   classes,binipstuff,dnscore,btime;\r
  19 \r
  20 \r
  21 type\r
  22   //after completion or cancelation a dnswinasync may be reused\r
  23   tdnsasync=class(tcomponent)\r
  24 \r
  25   private\r
  26     //made a load of stuff private that does not appear to be part of the main\r
  27     //public interface. If you make any of it public again please consider the\r
  28     //consequences when using windows dns. --plugwash.\r
  29     sock:twsocket;\r
  30 \r
  31     sockopen:boolean;\r
  32 \r
  33 \r
  34     state:tdnsstate;\r
  35 \r
  36     dnsserverid:integer;\r
  37     startts:double;\r
  38     {$ifdef win32}
  39       dwas : tdnswinasync;\r
  40     {$endif}
  41 \r
  42 \r
  43     procedure asyncprocess;\r
  44     procedure receivehandler(sender:tobject;error:word);\r
  45     function sendquery(const packet:tdnspacket;len:integer):boolean;\r
  46     {$ifdef win32}
  47       procedure winrequestdone(sender:tobject;error:word);\r
  48     {$endif}
  49   public\r
  50     onrequestdone:tsocketevent;\r
  51 \r
  52     //addr and port allow the application to specify a dns server specifically\r
  53     //for this dnsasync object. This is not a reccomended mode of operation\r
  54     //because it limits the app to one dns server but is kept for compatibility\r
  55     //and special uses.\r
  56     addr,port:string;\r
  57 \r
  58     //A family value of AF_INET6 will give only\r
  59     //ipv6 results. Any other value will give ipv4 results in preference and ipv6\r
  60     //results if ipv4 results are not available;\r
  61     forwardfamily:integer;\r
  62 \r
  63     procedure cancel;//cancel an outstanding dns request\r
  64     function dnsresult:string; //get result of dnslookup as a string\r
  65     procedure dnsresultbin(var binip:tbinip); //get result of dnslookup as a tbinip\r
  66     procedure forwardlookup(const name:string); //start forward lookup,\r
  67                                                 //preffering ipv4\r
  68     procedure reverselookup(const binip:tbinip); //start reverse lookup\r
  69 \r
  70     constructor create(aowner:tcomponent); override;\r
  71     destructor destroy; override;\r
  72 \r
  73   end;\r
  74 \r
  75 implementation\r
  76 \r
  77 uses sysutils;\r
  78 \r
  79 constructor tdnsasync.create;\r
  80 begin\r
  81   inherited create(aowner);\r
  82   dnsserverid := -1;\r
  83   sock := twsocket.create(self);\r
  84 end;\r
  85 \r
  86 destructor tdnsasync.destroy;\r
  87 begin\r
  88   if dnsserverid >= 0 then begin\r
  89     reportlag(dnsserverid,-1);\r
  90     dnsserverid := -1;\r
  91   end;\r
  92   sock.release;\r
  93   setstate_request_init('',state);\r
  94   inherited destroy;\r
  95 end;\r
  96 \r
  97 procedure tdnsasync.receivehandler;\r
  98 begin\r
  99   if dnsserverid >= 0 then begin\r
 100     reportlag(dnsserverid,trunc((unixtimefloat-startts)*1000));\r
 101     dnsserverid := -1;\r
 102   end;\r
 103 {  writeln('received reply');}\r
 104   fillchar(state.recvpacket,sizeof(state.recvpacket),0);\r
 105   state.recvpacketlen := twsocket(sender).Receive(@state.recvpacket, SizeOf(state.recvpacket));\r
 106   state.parsepacket := true;\r
 107   asyncprocess;\r
 108 end;\r
 109 \r
 110 function tdnsasync.sendquery;\r
 111 begin\r
 112 {  writeln('sendquery ',decodename(state.packet,state.packetlen,12,0,a),' ',state.requesttype);}\r
 113   result := false;\r
 114   if len = 0 then exit; {no packet}\r
 115   if not sockopen then begin\r
 116     if addr <> '' then sock.addr := addr else sock.addr := getcurrentsystemnameserver(dnsserverid);//getunixnameservercached;\r
 117     startts := unixtimefloat;\r
 118     if port = '' then port := '53';\r
 119     sock.port := port;\r
 120     sock.Proto := 'udp';\r
 121     sock.ondataavailable := receivehandler;\r
 122     try\r
 123       sock.connect;\r
 124     except\r
 125       on e:exception do begin\r
 126         //writeln('exception '+e.message);\r
 127         exit;\r
 128       end;\r
 129     end;\r
 130     sockopen := true;\r
 131   end;\r
 132   sock.send(@packet,len);\r
 133   result := true;\r
 134 end;\r
 135 \r
 136 procedure tdnsasync.asyncprocess;\r
 137 begin\r
 138   state_process(state);\r
 139   case state.resultaction of\r
 140     action_ignore: begin {do nothing} end;\r
 141     action_done: begin\r
 142       onrequestdone(self,0);\r
 143     end;\r
 144     action_sendquery:begin\r
 145       sendquery(state.sendpacket,state.sendpacketlen);\r
 146     end;\r
 147   end;\r
 148 end;\r
 149 \r
 150 procedure tdnsasync.forwardlookup;\r
 151 begin\r
 152   {$ifdef win32}\r
 153     if usewindns or (addr = '') then begin\r
 154       dwas := tdnswinasync.create;\r
 155       dwas.onrequestdone := winrequestdone;\r
 156       if forwardfamily = AF_INET6 then begin\r
 157         dwas.forwardlookup(name,true);\r
 158       end else begin\r
 159         dwas.forwardlookup(name,false);\r
 160       end;\r
 161     end;\r
 162   {$endif}\r
 163 \r
 164   ipstrtobin(name,state.resultbin);\r
 165   if state.resultbin.family <> 0 then begin\r
 166     onrequestdone(self,0);\r
 167     exit;\r
 168   end;\r
 169 \r
 170 \r
 171   setstate_forward(name,state,forwardfamily);\r
 172   asyncprocess;\r
 173 \r
 174 end;\r
 175 \r
 176 procedure tdnsasync.reverselookup;\r
 177 \r
 178 begin\r
 179   {$ifdef win32}\r
 180     if usewindns or (addr = '') then begin\r
 181       dwas := tdnswinasync.create;\r
 182       dwas.onrequestdone := winrequestdone;\r
 183       dwas.reverselookup(binip);\r
 184     end;\r
 185   {$endif}\r
 186 \r
 187   setstate_reverse(binip,state);\r
 188   asyncprocess;\r
 189 end;\r
 190 \r
 191 function tdnsasync.dnsresult;\r
 192 begin\r
 193   if state.resultstr <> '' then result := state.resultstr else begin\r
 194     result := ipbintostr(state.resultbin);\r
 195   end;\r
 196 end;\r
 197 \r
 198 procedure tdnsasync.dnsresultbin(var binip:tbinip);\r
 199 begin\r
 200   move(state.resultbin,binip,sizeof(binip));\r
 201 end;\r
 202 \r
 203 procedure tdnsasync.cancel;\r
 204 begin\r
 205   {$ifdef win32}
 206     if assigned(dwas) then begin\r
 207       dwas.release;\r
 208       dwas := nil;\r
 209     end else
 210   {$endif}
 211   begin\r
 212 \r
 213     if dnsserverid >= 0 then begin\r
 214       reportlag(dnsserverid,-1);\r
 215       dnsserverid := -1;\r
 216     end;\r
 217     if sockopen then begin\r
 218       sock.close;\r
 219       sockopen := false;\r
 220     end;\r
 221   end;\r
 222   setstate_failure(state);\r
 223   onrequestdone(self,0);\r
 224 end;\r
 225 \r
 226 {$ifdef win32}
 227   procedure tdnsasync.winrequestdone(sender:tobject;error:word);\r
 228   begin\r
 229     if dwas.reverse then begin \r
 230       state.resultstr := dwas.name;\r
 231     end else begin \r
 232       state.resultbin := dwas.ip;\r
 233       if (forwardfamily = AF_INET6) and (state.resultbin.family = AF_INET) then begin\r
 234         fillchar(state.resultbin,sizeof(tbinip),0);\r
 235       end;\r
 236     end;\r
 237     dwas.release;\r
 238     onrequestdone(self,error);\r
 239   end;\r
 240 {$endif}
 241 end.\r