1 ! Copyright (C) 2010 Doug Coleman.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors alien alien.c-types alien.data alien.strings
4 alien.syntax arrays byte-arrays classes.struct combinators
5 combinators.smart destructors io.encodings.string
6 io.encodings.utf8 io.sockets io.sockets.private kernel libc
7 make refs sequences sequences.extras windows.errors
8 windows.kernel32 windows.types windows.winsock fry ;
14 CONSTANT: DEFAULT_MINIMUM_ENTITIES 32
15 CONSTANT: MAX_ADAPTER_ADDRESS_LENGTH 8
16 CONSTANT: MAX_ADAPTER_DESCRIPTION_LENGTH 128
17 CONSTANT: MAX_ADAPTER_NAME_LENGTH 256
18 CONSTANT: MAX_DOMAIN_NAME_LEN 128
19 CONSTANT: MAX_HOSTNAME_LEN 128
20 CONSTANT: MAX_SCOPE_ID_LEN 256
21 CONSTANT: BROADCAST_NODETYPE 1
22 CONSTANT: PEER_TO_PEER_NODETYPE 2
23 CONSTANT: MIXED_NODETYPE 4
24 CONSTANT: HYBRID_NODETYPE 8
25 CONSTANT: IF_OTHER_ADAPTERTYPE 0
26 CONSTANT: IF_ETHERNET_ADAPTERTYPE 1
27 CONSTANT: IF_TOKEN_RING_ADAPTERTYPE 2
28 CONSTANT: IF_FDDI_ADAPTERTYPE 3
29 CONSTANT: IF_PPP_ADAPTERTYPE 4
30 CONSTANT: IF_LOOPBACK_ADAPTERTYPE 5
33 CONSTANT: MAX_DOMAIN_NAME_LEN+4 132
34 CONSTANT: MAX_HOSTNAME_LEN+4 132
35 CONSTANT: MAX_SCOPE_ID_LEN+4 260
36 CONSTANT: MAX_ADAPTER_NAME_LENGTH+4 264
37 CONSTANT: MAX_ADAPTER_DESCRIPTION_LENGTH+4 136
38 CONSTANT: ERROR_BUFFER_OVERFLOW 111
39 CONSTANT: MIB_IF_TYPE_ETHERNET 6
40 CONSTANT: MIB_IF_TYPE_TOKENRING 9
41 CONSTANT: MIB_IF_TYPE_FDDI 15
42 CONSTANT: MIB_IF_TYPE_PPP 23
43 CONSTANT: MIB_IF_TYPE_LOOPBACK 24
44 CONSTANT: MIB_IF_TYPE_SLIP 28
45 CONSTANT: MAX_DNS_SUFFIX_STRING_LENGTH 256 ! 246?
46 CONSTANT: MAX_DHCPV6_DUID_LENGTH 130
47 CONSTANT: MAX_ADAPTER_NAME 128
49 STRUCT: IP_ADDRESS_STRING
52 TYPEDEF: IP_ADDRESS_STRING* PIP_ADDRESS_STRING
53 TYPEDEF: IP_ADDRESS_STRING IP_MASK_STRING
54 TYPEDEF: IP_MASK_STRING* PIP_MASK_STRING
56 STRUCT: IP_ADDR_STRING
57 { Next IP_ADDR_STRING* }
58 { IpAddress IP_ADDRESS_STRING }
59 { IpMask IP_MASK_STRING }
62 TYPEDEF: IP_ADDR_STRING* PIP_ADDR_STRING
65 { HostName char[MAX_HOSTNAME_LEN+4] }
66 { DomainName char[MAX_DOMAIN_NAME_LEN+4] }
67 { CurrentDnsServer PIP_ADDR_STRING }
68 { DnsServerList IP_ADDR_STRING }
70 { ScopeId char[MAX_SCOPE_ID_LEN+4] }
71 { EnableRouting UINT }
74 { ExtraSpace char[4096] } ;
76 DEFER: IP_ADAPTER_INFO
80 TYPEDEF: uint NET_IF_COMPARTMENT_ID
81 TYPEDEF: GUID NET_IF_NETWORK_GUID
90 ENUM: IP_PREFIX_ORIGIN
93 IpPrefixOriginWellKnown,
95 IpPrefixOriginRouterAdvertisement,
96 { IpPrefixOriginUnchanged 16 } ;
98 ENUM: IP_SUFFIX_ORIGIN
100 IpSuffixOriginManual,
101 IpSuffixOriginWellKnown,
103 IpSuffixOriginLinkLayerAddress,
104 IpSuffixOriginRandom,
105 { IpSuffixOriginUnchanged 16 } ;
113 IfOperStatusNotPresent,
114 IfOperStatusLowerLayerDown ;
116 ENUM: NET_IF_CONNECTION_TYPE
117 { NET_IF_CONNECTION_DEDICATED 1 }
118 NET_IF_CONNECTION_PASSIVE,
119 NET_IF_CONNECTION_DEMAND,
120 NET_IF_CONNECTION_MAXIMUM ;
130 TUNNEL_TYPE_IPHTTPS ;
134 STRUCT: SOCKET_ADDRESS
135 { lpSockaddr LPSOCKADDR }
136 { iSockaddrLength INT } ;
138 ERROR: unknown-sockaddr-length sockaddr length ;
140 : SOCKET_ADDRESS>sockaddr ( obj -- sockaddr )
141 dup iSockaddrLength>> {
142 { 16 [ lpSockaddr>> sockaddr-in memory>struct ] }
143 { 28 [ lpSockaddr>> sockaddr-in6 memory>struct ] }
144 [ throw-unknown-sockaddr-length ]
147 TYPEDEF: SOCKET_ADDRESS* PSOCKET_ADDRESS
149 STRUCT: IP_ADAPTER_INFO
150 { Next IP_ADAPTER_INFO* }
152 { AdapterName char[MAX_ADAPTER_NAME_LENGTH+4] }
153 { Description char[MAX_ADAPTER_DESCRIPTION_LENGTH+4] }
154 { AddressLength UINT }
155 { Address BYTE[MAX_ADAPTER_ADDRESS_LENGTH] }
159 { CurrentIpAddress PIP_ADDR_STRING }
160 { IpAddressList IP_ADDR_STRING }
161 { GatewayList IP_ADDR_STRING }
162 { DhcpServer IP_ADDR_STRING }
164 { PrimaryWinsServer IP_ADDR_STRING }
165 { SecondaryWinsServer IP_ADDR_STRING }
166 { LeaseObtained time_t }
167 { LeaseExpires time_t } ;
169 TYPEDEF: IP_ADAPTER_INFO* PIP_ADAPTER_INFO
175 TYPEDEF: LengthIndex LengthFlags
177 UNION-STRUCT: AlignmentLenIndex
178 { Alignment ULONGLONG }
179 { LenIndex LengthIndex } ;
181 UNION-STRUCT: AlignmentLenFlags
182 { Alignment ULONGLONG }
183 { LenFlags LengthFlags } ;
186 { Reserved ULONG64 bits: 24 }
187 { NetLuidIndex ULONG64 bits: 24 }
188 { IfType ULONG64 bits: 16 } ;
190 UNION-STRUCT: NET_LUID
194 TYPEDEF: NET_LUID* PNET_LUID
195 TYPEDEF: NET_LUID IF_LUID
197 DEFER: IP_ADAPTER_ADDRESSES
198 DEFER: IP_ADAPTER_UNICAST_ADDRESS
199 STRUCT: IP_ADAPTER_UNICAST_ADDRESS
200 { Header LengthFlags }
201 { Next IP_ADAPTER_UNICAST_ADDRESS* }
202 { Address SOCKET_ADDRESS }
203 { PrefixOrigin IP_PREFIX_ORIGIN }
204 { SuffixOrigin IP_SUFFIX_ORIGIN }
205 { DadState IP_DAD_STATE }
206 { ValidLifetime ULONG }
207 { PreferredLifetime ULONG }
208 { LeaseLifeTime ULONG }
209 { OnLinkPrefixLength UINT8 } ;
211 TYPEDEF: IP_ADAPTER_UNICAST_ADDRESS* PIP_ADAPTER_UNICAST_ADDRESS
213 DEFER: IP_ADAPTER_ANYCAST_ADDRESS
214 STRUCT: IP_ADAPTER_ANYCAST_ADDRESS
215 { Header AlignmentLenFlags }
216 { Next IP_ADAPTER_ANYCAST_ADDRESS* }
217 { Address SOCKET_ADDRESS } ;
219 TYPEDEF: IP_ADAPTER_ANYCAST_ADDRESS* PIP_ADAPTER_ANYCAST_ADDRESS
222 DEFER: IP_ADAPTER_MULTICAST_ADDRESS
223 STRUCT: IP_ADAPTER_MULTICAST_ADDRESS
224 { Header AlignmentLenFlags }
225 { Next IP_ADAPTER_MULTICAST_ADDRESS* }
226 { Address SOCKET_ADDRESS } ;
228 TYPEDEF: IP_ADAPTER_MULTICAST_ADDRESS* PIP_ADAPTER_MULTICAST_ADDRESS
231 DEFER: IP_ADAPTER_DNS_SERVER_ADDRESS
232 STRUCT: IP_ADAPTER_DNS_SERVER_ADDRESS
233 { Header AlignmentLenFlags }
234 { Next IP_ADAPTER_DNS_SERVER_ADDRESS* }
235 { Address SOCKET_ADDRESS } ;
237 TYPEDEF: IP_ADAPTER_DNS_SERVER_ADDRESS* PIP_ADAPTER_DNS_SERVER_ADDRESS
240 DEFER: IP_ADAPTER_WINS_SERVER_ADDRESS
241 STRUCT: IP_ADAPTER_WINS_SERVER_ADDRESS
242 { Header AlignmentLenFlags }
243 { Next IP_ADAPTER_WINS_SERVER_ADDRESS* }
244 { Address SOCKET_ADDRESS } ;
246 TYPEDEF: IP_ADAPTER_WINS_SERVER_ADDRESS* PIP_ADAPTER_WINS_SERVER_ADDRESS
248 TYPEDEF: IP_ADAPTER_WINS_SERVER_ADDRESS* PIP_ADAPTER_WINS_SERVER_ADDRESS_LH
252 DEFER: IP_ADAPTER_GATEWAY_ADDRESS
253 STRUCT: IP_ADAPTER_GATEWAY_ADDRESS
254 { Header AlignmentLenFlags }
255 { Next IP_ADAPTER_GATEWAY_ADDRESS* }
256 { Address SOCKET_ADDRESS } ;
258 TYPEDEF: IP_ADAPTER_GATEWAY_ADDRESS* PIP_ADAPTER_GATEWAY_ADDRESS
260 TYPEDEF: IP_ADAPTER_GATEWAY_ADDRESS* PIP_ADAPTER_GATEWAY_ADDRESS_LH
262 DEFER: IP_ADAPTER_PREFIX
263 STRUCT: IP_ADAPTER_PREFIX
264 { Header AlignmentLenFlags }
265 { Next IP_ADAPTER_PREFIX* }
266 { Address SOCKET_ADDRESS }
267 { PrefixLength ULONG } ;
269 TYPEDEF: IP_ADAPTER_PREFIX* PIP_ADAPTER_PREFIX
272 DEFER: IP_ADAPTER_DNS_SUFFIX
273 STRUCT: IP_ADAPTER_DNS_SUFFIX
274 { Next IP_ADAPTER_DNS_SUFFIX* }
275 { String WCHAR[MAX_DNS_SUFFIX_STRING_LENGTH] } ;
277 TYPEDEF: IP_ADAPTER_DNS_SUFFIX* PIP_ADAPTER_DNS_SUFFIX
280 CONSTANT: GAA_FLAG_SKIP_UNICAST 0x0001
281 CONSTANT: GAA_FLAG_SKIP_ANYCAST 0x0002
282 CONSTANT: GAA_FLAG_SKIP_MULTICAST 0x0004
283 CONSTANT: GAA_FLAG_SKIP_DNS_SERVER 0x0008
284 CONSTANT: GAA_FLAG_INCLUDE_PREFIX 0x0010
285 CONSTANT: GAA_FLAG_SKIP_FRIENDLY_NAME 0x0020
286 CONSTANT: GAA_FLAG_INCLUDE_WINS_INFO 0x0040
287 CONSTANT: GAA_FLAG_INCLUDE_GATEWAYS 0x0080
288 CONSTANT: GAA_FLAG_INCLUDE_ALL_INTERFACES 0x0100
289 CONSTANT: GAA_FLAG_INCLUDE_ALL_COMPARTMENTS 0x0200
290 CONSTANT: GAA_FLAG_INCLUDE_TUNNEL_BINDINGORDER 0x0400
292 STRUCT: IP_ADAPTER_ADDRESSES
293 { Header AlignmentLenIndex }
294 { Next IP_ADAPTER_ADDRESSES* }
295 { AdapterName PCHAR }
296 { FirstUnicastAddress PIP_ADAPTER_UNICAST_ADDRESS }
297 { FirstAnycastAddress PIP_ADAPTER_ANYCAST_ADDRESS }
298 { FirstMulticastAddress PIP_ADAPTER_MULTICAST_ADDRESS }
299 { FirstDnsServerAddress PIP_ADAPTER_DNS_SERVER_ADDRESS }
301 { Description PWCHAR }
302 { FriendlyName PWCHAR }
303 { PhysicalAddress BYTE[MAX_ADAPTER_ADDRESS_LENGTH] }
304 { PhysicalAddressLength DWORD }
308 { OperStatus IF_OPER_STATUS }
309 { Ipv6IfIndex DWORD }
310 { ZoneIndices DWORD[16] }
311 { FirstPrefix PIP_ADAPTER_PREFIX }
312 { TransmitLinkSpeed ULONG64 }
313 { ReceiveLinkSpeed ULONG64 }
314 { FirstWinsServerAddress PIP_ADAPTER_WINS_SERVER_ADDRESS_LH }
315 { FirstGatewayAddress PIP_ADAPTER_GATEWAY_ADDRESS_LH }
319 { Dhcpv4Server SOCKET_ADDRESS }
320 { CompartmentId NET_IF_COMPARTMENT_ID }
321 { NetworkGuid NET_IF_NETWORK_GUID }
322 { ConnectionType NET_IF_CONNECTION_TYPE }
323 { TunnelType TUNNEL_TYPE }
324 { Dhcpv6Server SOCKET_ADDRESS }
325 { Dhcpv6ClientDuid BYTE[MAX_DHCPV6_DUID_LENGTH] }
326 { Dhcpv6ClientDuidLength ULONG }
328 { FirstDnsSuffix PIP_ADAPTER_DNS_SUFFIX } ;
330 TYPEDEF: IP_ADAPTER_ADDRESSES* PIP_ADAPTER_ADDRESSES
332 TYPEDEF: FIXED_INFO* PFIXED_INFO
354 STRUCT: IP_ADAPTER_INDEX_MAP
356 { Name WCHAR[MAX_ADAPTER_NAME] } ;
357 TYPEDEF: IP_ADAPTER_INDEX_MAP* PIP_ADAPTER_INDEX_MAP
359 FUNCTION: DWORD IpReleaseAddress ( PIP_ADAPTER_INDEX_MAP AdapterInfo )
360 FUNCTION: DWORD IpRenewAddress ( PIP_ADAPTER_INDEX_MAP AdapterInfo )
363 FUNCTION: DWORD GetBestInterface (
365 PDWORD pdwBestIfIndex
368 FUNCTION: DWORD GetBestInterfaceEx (
370 PDWORD pdwBestIfIndex
373 FUNCTION: ULONG GetAdaptersAddresses (
377 PIP_ADAPTER_ADDRESSES AdapterAddresses,
382 FUNCTION: DWORD GetAdaptersInfo (
383 PIP_ADAPTER_INFO pAdapterInfo,
386 FUNCTION: DWORD GetNetworkParams ( PFIXED_INFO pFixedInfo, PULONG pOutBufLen )
388 : get-fixed-info ( -- FIXED_INFO )
389 FIXED_INFO <struct> dup byte-length ulong <ref>
390 [ GetNetworkParams n>win32-error-check ] 2keep drop ;
392 : dns-server-ips ( -- sequence )
393 get-fixed-info DnsServerList>> [
395 [ IpAddress>> String>> [ 0 = ] trim-tail utf8 decode , ]
401 ! second struct starts at 720h
406 : loop-list ( obj -- seq )
407 [ [ dup [ Next>> ] when ] keep ] loop>array nip ;
409 ! Don't use this, use each/map-adapters
410 : iterate-interfaces ( -- seq )
411 AF_UNSPEC GAA_FLAG_INCLUDE_PREFIX 0 uint <ref>
412 65,536 [ malloc &free ] [ ULONG <ref> ] bi
413 [ GetAdaptersAddresses win32-error=0/f ] 2keep
415 IP_ADAPTER_ADDRESSES memory>struct loop-list ;
419 : interfaces-each ( quot -- seq )
420 [ [ iterate-interfaces ] dip each ] with-destructors ; inline
422 : interfaces-map ( quot -- seq )
423 [ [ iterate-interfaces ] dip { } map-as ] with-destructors ; inline
425 : interface-mac-addrs ( -- seq )
429 [ [ PhysicalAddress>> ] [ PhysicalAddressLength>> ] bi head ]
433 : interface-ips ( -- seq )
437 [ FirstUnicastAddress>> loop-list [ Address>> SOCKET_ADDRESS>sockaddr sockaddr>ip ] map ]
441 : get-best-interface ( inet -- interface )
442 make-sockaddr 0 DWORD <ref>
443 [ GetBestInterfaceEx win32-error=0/f ] keep DWORD deref ;