httpserver_20080306/dnswin.pas

   1 unit dnswin;\r
   2 \r
   3 interface\r
   4 uses binipstuff,classes,lcore;\r
   5 \r
   6 //on failure a null string or zeroed out binip will be retuned and error will be\r
   7 //set to a windows error code (error will be left untouched under non error\r
   8 //conditions).\r
   9 function winforwardlookup(name : string;ipv6preffered : boolean;var error:integer) : tbinip;\r
  10 function winreverselookup(ip:tbinip;var error:integer):string;\r
  11 \r
  12 \r
  13 type\r
  14   //do not call destroy on a tdnswinasync instead call release and the\r
  15   //dnswinasync will be freed when appropriate. Calling destroy will block\r
  16   //the calling thread until the dns lookup completes.\r
  17   //release should only be called from the main thread\r
  18   tdnswinasync=class(tthread)\r
  19   private\r
  20     ipv6preffered : boolean;\r
  21     freverse : boolean;\r
  22     error : integer;\r
  23     freewhendone : boolean;\r
  24     hadevent : boolean;\r
  25   protected\r
  26     procedure execute; override;\r
  27   public\r
  28     onrequestdone:tsocketevent;\r
  29     name : string;\r
  30     ip : tbinip;\r
  31 \r
  32     procedure forwardlookup(name:string;ipv6preffered:boolean);\r
  33     procedure reverselookup(ip:tbinip);\r
  34     destructor destroy; override;\r
  35     procedure release;\r
  36     constructor create;\r
  37     property reverse : boolean read freverse;\r
  38 \r
  39   end;\r
  40 \r
  41 implementation\r
  42 uses\r
  43   lsocket,pgtypes,sysutils,winsock,windows,messages;\r
  44 \r
  45 type\r
  46   //taddrinfo = record; //forward declaration\r
  47   paddrinfo = ^taddrinfo;\r
  48   taddrinfo = packed record\r
  49     ai_flags : longint;\r
  50     ai_family : longint;\r
  51     ai_socktype : longint;\r
  52     ai_protocol : longint;\r
  53     ai_addrlen : taddrint;\r
  54     ai_canonname : pchar;\r
  55     ai_addr : pinetsockaddrv;\r
  56     ai_next : paddrinfo;\r
  57   end;\r
  58   ppaddrinfo = ^paddrinfo;\r
  59   tgetaddrinfo = function(nodename : pchar; servname : pchar; hints : paddrinfo;res : ppaddrinfo) : longint; stdcall;\r
  60   tfreeaddrinfo = procedure(ai : paddrinfo); stdcall;\r
  61   tgetnameinfo = function(sa:Pinetsockaddrv;salen : longint; host:pchar;hostlen : longint;serv:pchar;servlen:longint;flags:longint) : longint;stdcall;\r
  62 var\r
  63   getaddrinfo : tgetaddrinfo;\r
  64   freeaddrinfo : tfreeaddrinfo;\r
  65   getnameinfo : tgetnameinfo;\r
  66 procedure v4onlyfreeaddrinfo(ai : paddrinfo); stdcall;\r
  67 begin\r
  68   freemem(ai.ai_addr);\r
  69   freemem(ai);\r
  70 end;\r
  71 \r
  72 type\r
  73   plongint = ^longint;\r
  74   pplongint = ^plongint;\r
  75 \r
  76 function v4onlygetaddrinfo(nodename : pchar; servname : pchar; hints : paddrinfo;res : ppaddrinfo) : longint; stdcall;\r
  77 var\r
  78   output : paddrinfo;\r
  79   hostent : phostent;\r
  80 begin\r
  81   if hints.ai_family = af_inet then begin\r
  82     result := 0;\r
  83     getmem(output,sizeof(taddrinfo));\r
  84     getmem(output.ai_addr,sizeof(tinetsockaddr));\r
  85     output.ai_addr.InAddr.family := af_inet;\r
  86     if servname <> nil then output.ai_addr.InAddr.port := htons(strtoint(servname)) else output.ai_addr.InAddr.port := 0;\r
  87     hostent := gethostbyname(nodename);\r
  88     if hostent = nil then begin\r
  89       result := wsagetlasterror;\r
  90       v4onlyfreeaddrinfo(output);\r
  91       exit;\r
  92     end;\r
  93     output.ai_addr.InAddr.addr := pplongint(hostent.h_addr_list)^^;\r
  94     output.ai_flags := 0;\r
  95     output.ai_family := af_inet;\r
  96     output.ai_socktype := 0;\r
  97     output.ai_protocol := 0;\r
  98     output.ai_addrlen := sizeof(tinetsockaddr);\r
  99     output.ai_canonname := nil;\r
 100     output.ai_next := nil;\r
 101 \r
 102     res^ := output;\r
 103   end else begin\r
 104     result := WSANO_RECOVERY;\r
 105   end;\r
 106 end;\r
 107 \r
 108 function min(a,b : integer):integer;\r
 109 begin\r
 110   if a<b then result := a else result := b;\r
 111 end;\r
 112 \r
 113 function v4onlygetnameinfo(sa:Pinetsockaddrv;salen : longint; host:pchar;hostlen : longint;serv:pchar;servlen:longint;flags:longint) : longint;stdcall;\r
 114 var\r
 115   hostent : phostent;\r
 116   bytestocopy : integer;\r
 117 begin\r
 118   if sa.InAddr.family = af_inet then begin\r
 119     result := 0;\r
 120     hostent := gethostbyaddr(@(sa.inaddr.addr),4,AF_INET);\r
 121     if hostent = nil then begin\r
 122       result := wsagetlasterror;\r
 123       exit;\r
 124     end;\r
 125     bytestocopy := min(strlen(hostent.h_name)+1,hostlen);\r
 126     move((hostent.h_name)^,host^,bytestocopy);\r
 127 \r
 128 \r
 129   end else begin\r
 130     result := WSANO_RECOVERY;\r
 131   end;\r
 132 end;\r
 133 \r
 134 \r
 135 procedure populateprocvars;\r
 136 var\r
 137   libraryhandle : hmodule;\r
 138   i : integer;\r
 139   dllname : string;\r
 140 \r
 141 begin\r
 142   if assigned(getaddrinfo) then exit; //procvars already populated\r
 143   for i := 0 to 1 do begin\r
 144     if i=0 then dllname := 'Ws2_32.dll' else dllname := 'Wship6.dll';\r
 145     libraryhandle := LoadLibrary(pchar(dllname));\r
 146     getaddrinfo := getprocaddress(libraryhandle,'getaddrinfo');\r
 147     freeaddrinfo := getprocaddress(libraryhandle,'freeaddrinfo');\r
 148     getnameinfo := getprocaddress(libraryhandle,'getnameinfo');\r
 149     if assigned(getaddrinfo) and assigned(freeaddrinfo) and assigned(getnameinfo) then begin\r
 150       //writeln('found getaddrinfo and freeaddrinfo in'+dllname);\r
 151       exit; //success\r
 152     end;\r
 153 \r
 154   end;\r
 155   //writeln('could not find getaddrinfo and freeaddrinfo, falling back to ipv4 only lookup');\r
 156   getaddrinfo := v4onlygetaddrinfo;\r
 157   freeaddrinfo := v4onlyfreeaddrinfo;\r
 158   getnameinfo := v4onlygetnameinfo;\r
 159 end;\r
 160 \r
 161 \r
 162 function winforwardlookup(name : string;ipv6preffered : boolean;var error : integer) : tbinip;\r
 163 var\r
 164   hints: taddrinfo;\r
 165   res : paddrinfo;\r
 166   pass : boolean;\r
 167   ipv6 : boolean;\r
 168   getaddrinforesult : integer;\r
 169 begin\r
 170   populateprocvars;\r
 171 \r
 172   for pass := false to true do begin\r
 173     ipv6 := ipv6preffered xor pass;\r
 174     hints.ai_flags := 0;\r
 175     if ipv6 then begin\r
 176       hints.ai_family := AF_INET6;\r
 177     end else begin\r
 178       hints.ai_family := AF_INET;\r
 179     end;\r
 180     hints.ai_socktype := 0;\r
 181     hints.ai_protocol := 0;\r
 182     hints.ai_addrlen := 0;\r
 183     hints.ai_canonname := nil;\r
 184     hints.ai_addr := nil;\r
 185     hints.ai_next := nil;\r
 186     getaddrinforesult := getaddrinfo(pchar(name),'1',@hints,@res);\r
 187     if getaddrinforesult = 0 then begin\r
 188       if res.ai_family = af_inet then begin\r
 189         result.family := af_inet;\r
 190         result.ip := res.ai_addr.InAddr.addr;\r
 191       end else if res.ai_family = af_inet6 then begin\r
 192         result.family := af_inet6;\r
 193         result.ip6 := res.ai_addr.InAddr6.sin6_addr;\r
 194       end;\r
 195 \r
 196       freeaddrinfo(res);\r
 197       exit;\r
 198     end;\r
 199   end;\r
 200   if getaddrinforesult <> 0 then begin\r
 201     fillchar(result,0,sizeof(result));\r
 202     error := getaddrinforesult;\r
 203   end;\r
 204 end;\r
 205 \r
 206 function winreverselookup(ip:tbinip;var error : integer):string;\r
 207 var\r
 208   sa : tinetsockaddrv;\r
 209   getnameinforesult : integer;\r
 210 begin\r
 211 \r
 212   if ip.family = AF_INET then begin\r
 213     sa.InAddr.family := AF_INET;\r
 214     sa.InAddr.port := 1;\r
 215     sa.InAddr.addr := ip.ip;\r
 216   end else if ip.family = AF_INET6 then begin\r
 217     sa.InAddr6.sin6_family  := AF_INET6;\r
 218     sa.InAddr6.sin6_port := 1;\r
 219     sa.InAddr6.sin6_addr := ip.ip6;\r
 220   end else begin\r
 221     raise exception.create('unrecognised address family');\r
 222   end;\r
 223   populateprocvars;\r
 224   setlength(result,1025);\r
 225   getnameinforesult := getnameinfo(@sa,sizeof(tinetsockaddrv),pchar(result),length(result),nil,0,0);\r
 226   if getnameinforesult <> 0 then begin\r
 227     error := getnameinforesult;\r
 228     result := '';\r
 229     exit;\r
 230   end;\r
 231   if pos(#0,result) >= 0 then begin\r
 232     setlength(result,pos(#0,result)-1);\r
 233   end;\r
 234 end;\r
 235 \r
 236 var\r
 237   hwnddnswin : hwnd;\r
 238 \r
 239 function MyWindowProc(\r
 240     ahWnd   : HWND;\r
 241     auMsg   : Integer;\r
 242     awParam : WPARAM;\r
 243     alParam : LPARAM): Integer; stdcall;\r
 244 var\r
 245   dwas : tdnswinasync;\r
 246 begin\r
 247   if (ahwnd=hwnddnswin) and (aumsg=wm_user) then begin\r
 248     Dwas := tdnswinasync(alparam);\r
 249     dwas.hadevent := true;\r
 250     if assigned (dwas.onrequestdone) then dwas.onrequestdone(dwas,awparam);\r
 251     if dwas.freewhendone then dwas.free;\r
 252   end else begin\r
 253     //not passing unknown messages on to defwindowproc will cause window\r
 254     //creation to fail! --plugwash\r
 255     Result := DefWindowProc(ahWnd, auMsg, awParam, alParam)\r
 256   end;\r
 257 end;\r
 258 \r
 259 procedure tdnswinasync.forwardlookup(name:string;ipv6preffered:boolean);\r
 260 begin\r
 261   self.name := name;\r
 262   self.ipv6preffered := ipv6preffered;\r
 263   freverse := false;\r
 264   resume;\r
 265 end;\r
 266 procedure tdnswinasync.reverselookup(ip:tbinip);\r
 267 begin\r
 268   self.ip := ip;\r
 269   freverse := true;\r
 270   resume;\r
 271 end;\r
 272 procedure tdnswinasync.execute;\r
 273 var\r
 274   error : integer;\r
 275 begin\r
 276   error := 0;\r
 277   if reverse then begin\r
 278     name := winreverselookup(ip,error);\r
 279   end else begin\r
 280     ip := winforwardlookup(name,ipv6preffered,error);\r
 281 \r
 282   end;\r
 283 \r
 284   postmessage(hwnddnswin,wm_user,error,taddrint(self));\r
 285 end;\r
 286 \r
 287 destructor tdnswinasync.destroy; \r
 288 begin\r
 289   WaitFor;\r
 290   inherited destroy;\r
 291 end;\r
 292 procedure tdnswinasync.release;\r
 293 begin\r
 294   if hadevent then destroy else begin\r
 295     onrequestdone := nil;\r
 296     freewhendone := true;\r
 297   end;\r
 298 end;\r
 299 \r
 300 constructor tdnswinasync.create;\r
 301 begin\r
 302   inherited create(true);\r
 303 end;\r
 304 \r
 305 var\r
 306   MyWindowClass : TWndClass = (style         : 0;\r
 307                                  lpfnWndProc   : @MyWindowProc;\r
 308                                  cbClsExtra    : 0;\r
 309                                  cbWndExtra    : 0;\r
 310                                  hInstance     : 0;\r
 311                                  hIcon         : 0;\r
 312                                  hCursor       : 0;\r
 313                                  hbrBackground : 0;\r
 314                                  lpszMenuName  : nil;\r
 315                                  lpszClassName : 'dnswinClass');\r
 316 begin\r
 317 \r
 318     if Windows.RegisterClass(MyWindowClass) = 0 then halt;\r
 319   //writeln('about to create lcore handle, hinstance=',hinstance);\r
 320   hwnddnswin := CreateWindowEx(WS_EX_TOOLWINDOW,\r
 321                                MyWindowClass.lpszClassName,\r
 322                                '',        { Window name   }\r
 323                                WS_POPUP,  { Window Style  }\r
 324                                0, 0,      { X, Y          }\r
 325                                0, 0,      { Width, Height }\r
 326                                0,         { hWndParent    }\r
 327                                0,         { hMenu         }\r
 328                                HInstance, { hInstance     }\r
 329                                nil);      { CreateParam   }\r
 330   //writeln('dnswin hwnd is ',hwnddnswin);\r
 331   //writeln('last error is ',GetLastError);\r
 332 end.\r