windows.iphlpapi: Add a way to get interfaces, mac addrs, and ips on

windows.

diff --git a/basis/windows/iphlpapi/iphlpapi.factor b/basis/windows/iphlpapi/iphlpapi.factor
index 9beb3bd9a6fec2925289272c9b37d8aa8291ce12..a4c6aa17dd46bdb72dd2e98ca41ee67d53c96605 100644 (file)
--- a/basis/windows/iphlpapi/iphlpapi.factor
+++ b/basis/windows/iphlpapi/iphlpapi.factor
@@ -1,8 +1,10 @@
 ! Copyright (C) 2010 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien alien.c-types alien.data alien.syntax
-classes.struct io.encodings.string io.encodings.utf8 kernel
-make sequences windows.errors windows.types ;
+USING: accessors alien alien.c-types alien.data alien.strings
+alien.syntax arrays byte-arrays classes.struct combinators
+combinators.smart destructors io.encodings.string
+io.encodings.utf8 kernel libc make sequences sequences.extras
+windows.errors windows.kernel32 windows.types windows.winsock ;
 IN: windows.iphlpapi
 
 LIBRARY: iphlpapi
@@ -30,6 +32,18 @@ CONSTANT: IF_LOOPBACK_ADAPTERTYPE 5
 CONSTANT: MAX_DOMAIN_NAME_LEN+4 132
 CONSTANT: MAX_HOSTNAME_LEN+4 132
 CONSTANT: MAX_SCOPE_ID_LEN+4 260
+CONSTANT: MAX_ADAPTER_NAME_LENGTH+4 264
+CONSTANT: MAX_ADAPTER_DESCRIPTION_LENGTH+4 136
+CONSTANT: ERROR_BUFFER_OVERFLOW 111
+CONSTANT: MIB_IF_TYPE_ETHERNET 6
+CONSTANT: MIB_IF_TYPE_TOKENRING 9
+CONSTANT: MIB_IF_TYPE_FDDI 15
+CONSTANT: MIB_IF_TYPE_PPP 23
+CONSTANT: MIB_IF_TYPE_LOOPBACK 24
+CONSTANT: MIB_IF_TYPE_SLIP 28
+CONSTANT: MAX_DNS_SUFFIX_STRING_LENGTH 256 ! 246?
+CONSTANT: MAX_DHCPV6_DUID_LENGTH 130
+
 
 STRUCT: IP_ADDRESS_STRING
     { String char[16] } ;
@@ -58,8 +72,277 @@ STRUCT: FIXED_INFO
     { EnableDns UINT }
     { ExtraSpace char[4096] } ;
 
+DEFER: IP_ADAPTER_INFO
+
+TYPEDEF: ulong time_t
+TYPEDEF: uchar UINT8
+TYPEDEF: uint NET_IF_COMPARTMENT_ID
+TYPEDEF: GUID NET_IF_NETWORK_GUID
+
+ENUM: IP_DAD_STATE
+  IpDadStateInvalid
+  IpDadStateTentative,
+  IpDadStateDuplicate,
+  IpDadStateDeprecated,
+  IpDadStatePreferred ;
+  
+ENUM: IP_PREFIX_ORIGIN
+    IpPrefixOriginOther,
+    IpPrefixOriginManual,
+    IpPrefixOriginWellKnown,
+    IpPrefixOriginDhcp,
+    IpPrefixOriginRouterAdvertisement,
+    { IpPrefixOriginUnchanged 16 } ;
+    
+ENUM: IP_SUFFIX_ORIGIN
+    IpSuffixOriginOther
+    IpSuffixOriginManual,
+    IpSuffixOriginWellKnown,
+    IpSuffixOriginDhcp,
+    IpSuffixOriginLinkLayerAddress,
+    IpSuffixOriginRandom,
+    { IpSuffixOriginUnchanged 16 } ;
+    
+ENUM: IF_OPER_STATUS
+    { IfOperStatusUp 1 }
+    IfOperStatusDown,
+    IfOperStatusTesting,
+    IfOperStatusUnknown,
+    IfOperStatusDormant,
+    IfOperStatusNotPresent,
+    IfOperStatusLowerLayerDown ;
+
+ENUM: NET_IF_CONNECTION_TYPE
+    { NET_IF_CONNECTION_DEDICATED 1 }
+    NET_IF_CONNECTION_PASSIVE,
+    NET_IF_CONNECTION_DEMAND,
+    NET_IF_CONNECTION_MAXIMUM ;
+    
+    
+ENUM: TUNNEL_TYPE
+    TUNNEL_TYPE_NONE,
+    TUNNEL_TYPE_OTHER,
+    TUNNEL_TYPE_DIRECT,
+    TUNNEL_TYPE_6TO4, 
+    TUNNEL_TYPE_ISATAP,
+    TUNNEL_TYPE_TEREDO,
+    TUNNEL_TYPE_IPHTTPS ;
+
+  
+  
+STRUCT: SOCKET_ADDRESS
+    { lpSockaddr LPSOCKADDR }
+    { iSockaddrLength INT } ;
+    
+ERROR: unknown-sockaddr-length sockaddr length ;
+    
+: SOCKET_ADDRESS>sockaddr ( obj -- sockaddr )
+    dup iSockaddrLength>> {
+        { 16 [ lpSockaddr>> sockaddr-in memory>struct ] }
+        { 28 [ lpSockaddr>> sockaddr-in6 memory>struct ] }
+        [ unknown-sockaddr-length ]
+    } case ;
+    
+TYPEDEF: SOCKET_ADDRESS* PSOCKET_ADDRESS
+    
+STRUCT: IP_ADAPTER_INFO
+    { Next IP_ADAPTER_INFO* }
+    { ComboIndex DWORD }
+    { AdapterName char[MAX_ADAPTER_NAME_LENGTH+4] }
+    { Description char[MAX_ADAPTER_DESCRIPTION_LENGTH+4] }
+    { AddressLength UINT }
+    { Address BYTE[MAX_ADAPTER_ADDRESS_LENGTH] }
+    { Index DWORD }
+    { Type UINT }
+    { DhcpEnabled UINT }
+    { CurrentIpAddress PIP_ADDR_STRING }
+    { IpAddressList IP_ADDR_STRING }
+    { GatewayList IP_ADDR_STRING }
+    { DhcpServer IP_ADDR_STRING }
+    { HaveWins BOOL }
+    { PrimaryWinsServer IP_ADDR_STRING }
+    { SecondaryWinsServer IP_ADDR_STRING }
+    { LeaseObtained time_t }
+    { LeaseExpires time_t } ;
+
+TYPEDEF: IP_ADAPTER_INFO* PIP_ADAPTER_INFO
+
+STRUCT: LengthIndex
+    { Length ULONG }
+    { IfIndex DWORD } ;
+    
+TYPEDEF: LengthIndex LengthFlags
+
+UNION-STRUCT: AlignmentLenIndex
+    { Alignment ULONGLONG }
+    { LenIndex LengthIndex } ;
+    
+UNION-STRUCT: AlignmentLenFlags
+    { Alignment ULONGLONG }
+    { LenFlags LengthFlags } ;
+
+STRUCT: ResNetIf
+    { Reserved ULONG64 bits: 24 }
+    { NetLuidIndex ULONG64 bits: 24 }
+    { IfType ULONG64 bits: 16 } ;
+
+UNION-STRUCT: NET_LUID
+    { Value ULONG64 }
+    { Info ResNetIf } ;
+    
+TYPEDEF: NET_LUID* PNET_LUID
+TYPEDEF: NET_LUID IF_LUID
+
+DEFER: IP_ADAPTER_ADDRESSES
+DEFER: IP_ADAPTER_UNICAST_ADDRESS
+STRUCT: IP_ADAPTER_UNICAST_ADDRESS
+    { Header LengthFlags }
+    { Next IP_ADAPTER_UNICAST_ADDRESS* }
+    { Address SOCKET_ADDRESS }
+    { PrefixOrigin IP_PREFIX_ORIGIN }
+    { SuffixOrigin IP_SUFFIX_ORIGIN }
+    { DadState IP_DAD_STATE }
+    { ValidLifetime ULONG }
+    { PreferredLifetime ULONG }
+    { LeaseLifeTime ULONG }
+    { OnLinkPrefixLength UINT8 } ;
+    
+TYPEDEF: IP_ADAPTER_UNICAST_ADDRESS* PIP_ADAPTER_UNICAST_ADDRESS
+
+DEFER: IP_ADAPTER_ANYCAST_ADDRESS
+STRUCT: IP_ADAPTER_ANYCAST_ADDRESS
+    { Header AlignmentLenFlags }
+    { Next IP_ADAPTER_ANYCAST_ADDRESS* }
+    { Address SOCKET_ADDRESS } ;
+    
+TYPEDEF: IP_ADAPTER_ANYCAST_ADDRESS* PIP_ADAPTER_ANYCAST_ADDRESS
+
+
+DEFER: IP_ADAPTER_MULTICAST_ADDRESS
+STRUCT: IP_ADAPTER_MULTICAST_ADDRESS
+    { Header AlignmentLenFlags }
+    { Next IP_ADAPTER_MULTICAST_ADDRESS* }
+    { Address SOCKET_ADDRESS } ;
+   
+TYPEDEF: IP_ADAPTER_MULTICAST_ADDRESS* PIP_ADAPTER_MULTICAST_ADDRESS
+
+
+DEFER: IP_ADAPTER_DNS_SERVER_ADDRESS
+STRUCT: IP_ADAPTER_DNS_SERVER_ADDRESS
+    { Header AlignmentLenFlags }
+    { Next IP_ADAPTER_DNS_SERVER_ADDRESS* }
+    { Address SOCKET_ADDRESS } ;
+    
+TYPEDEF: IP_ADAPTER_DNS_SERVER_ADDRESS* PIP_ADAPTER_DNS_SERVER_ADDRESS
+
+
+DEFER: IP_ADAPTER_WINS_SERVER_ADDRESS
+STRUCT: IP_ADAPTER_WINS_SERVER_ADDRESS
+    { Header AlignmentLenFlags }
+    { Next IP_ADAPTER_WINS_SERVER_ADDRESS* }
+    { Address SOCKET_ADDRESS } ;
+    
+TYPEDEF: IP_ADAPTER_WINS_SERVER_ADDRESS* PIP_ADAPTER_WINS_SERVER_ADDRESS
+
+TYPEDEF: IP_ADAPTER_WINS_SERVER_ADDRESS* PIP_ADAPTER_WINS_SERVER_ADDRESS_LH
+
+
+
+DEFER: IP_ADAPTER_GATEWAY_ADDRESS
+STRUCT: IP_ADAPTER_GATEWAY_ADDRESS
+    { Header AlignmentLenFlags }
+    { Next IP_ADAPTER_GATEWAY_ADDRESS* }
+    { Address SOCKET_ADDRESS } ;
+    
+TYPEDEF: IP_ADAPTER_GATEWAY_ADDRESS* PIP_ADAPTER_GATEWAY_ADDRESS
+
+TYPEDEF: IP_ADAPTER_GATEWAY_ADDRESS* PIP_ADAPTER_GATEWAY_ADDRESS_LH
+
+DEFER: IP_ADAPTER_PREFIX
+STRUCT: IP_ADAPTER_PREFIX
+    { Header AlignmentLenFlags }
+    { Next IP_ADAPTER_PREFIX* }
+    { Address SOCKET_ADDRESS }
+    { PrefixLength ULONG } ;
+    
+TYPEDEF: IP_ADAPTER_PREFIX* PIP_ADAPTER_PREFIX
+
+
+DEFER: IP_ADAPTER_DNS_SUFFIX
+STRUCT: IP_ADAPTER_DNS_SUFFIX
+    { Next IP_ADAPTER_DNS_SUFFIX* }
+    { String WCHAR[MAX_DNS_SUFFIX_STRING_LENGTH] } ;
+    
+TYPEDEF: IP_ADAPTER_DNS_SUFFIX* PIP_ADAPTER_DNS_SUFFIX
+
+
+CONSTANT: GAA_FLAG_SKIP_UNICAST 0x0001
+CONSTANT: GAA_FLAG_SKIP_ANYCAST 0x0002
+CONSTANT: GAA_FLAG_SKIP_MULTICAST 0x0004
+CONSTANT: GAA_FLAG_SKIP_DNS_SERVER 0x0008
+CONSTANT: GAA_FLAG_INCLUDE_PREFIX 0x0010
+CONSTANT: GAA_FLAG_SKIP_FRIENDLY_NAME 0x0020
+CONSTANT: GAA_FLAG_INCLUDE_WINS_INFO 0x0040
+CONSTANT: GAA_FLAG_INCLUDE_GATEWAYS 0x0080
+CONSTANT: GAA_FLAG_INCLUDE_ALL_INTERFACES 0x0100
+CONSTANT: GAA_FLAG_INCLUDE_ALL_COMPARTMENTS 0x0200
+CONSTANT: GAA_FLAG_INCLUDE_TUNNEL_BINDINGORDER 0x0400
+
+STRUCT: IP_ADAPTER_ADDRESSES
+    { Header AlignmentLenIndex }
+    { Next IP_ADAPTER_ADDRESSES* }
+    { AdapterName PCHAR }
+    { FirstUnicastAddress PIP_ADAPTER_UNICAST_ADDRESS }
+    { FirstAnycastAddress PIP_ADAPTER_ANYCAST_ADDRESS }
+    { FirstMulticastAddress PIP_ADAPTER_MULTICAST_ADDRESS }
+    { FirstDnsServerAddress PIP_ADAPTER_DNS_SERVER_ADDRESS }
+    { DnsSuffix PWCHAR }
+    { Description PWCHAR }
+    { FriendlyName PWCHAR }
+    { PhysicalAddress BYTE[MAX_ADAPTER_ADDRESS_LENGTH] }
+    { PhysicalAddressLength DWORD }
+    { Flags DWORD }
+    { Mtu DWORD }
+    { IfType DWORD }
+    { OperStatus IF_OPER_STATUS }
+    { Ipv6IfIndex DWORD }
+    { ZoneIndices DWORD[16] }
+    { FirstPrefix PIP_ADAPTER_PREFIX }
+    { TransmitLinkSpeed ULONG64 }
+    { ReceiveLinkSpeed ULONG64 }
+    { FirstWinsServerAddress PIP_ADAPTER_WINS_SERVER_ADDRESS_LH }
+    { FirstGatewayAddress PIP_ADAPTER_GATEWAY_ADDRESS_LH }
+    { Ipv4Metric ULONG }
+    { Ipv6Metric ULONG }
+    { Luid IF_LUID }
+    { Dhcpv4Server SOCKET_ADDRESS }
+    { CompartmentId NET_IF_COMPARTMENT_ID }
+    { NetworkGuid NET_IF_NETWORK_GUID }
+    { ConnectionType NET_IF_CONNECTION_TYPE }
+    { TunnelType TUNNEL_TYPE }
+    { Dhcpv6Server SOCKET_ADDRESS }
+    { Dhcpv6ClientDuid BYTE[MAX_DHCPV6_DUID_LENGTH] }
+    { Dhcpv6ClientDuidLength ULONG }
+    { Dhcpv6Iaid ULONG }
+    { FirstDnsSuffix PIP_ADAPTER_DNS_SUFFIX } ;
+
+TYPEDEF: IP_ADAPTER_ADDRESSES* PIP_ADAPTER_ADDRESSES
+
 TYPEDEF: FIXED_INFO* PFIXED_INFO
 
+FUNCTION: ULONG GetAdaptersAddresses (
+    ULONG Family,
+    ULONG Flags,
+    PVOID Reserved,
+    PIP_ADAPTER_ADDRESSES AdapterAddresses,
+    PULONG SizePointer
+) ;
+
+! Deprecated
+FUNCTION: DWORD GetAdaptersInfo (
+    PIP_ADAPTER_INFO pAdapterInfo,
+    PULONG pOutBufLen ) ;
+    
 FUNCTION: DWORD GetNetworkParams ( PFIXED_INFO pFixedInfo, PULONG pOutBufLen ) ;
 
 : get-fixed-info ( -- FIXED_INFO )
@@ -73,3 +356,45 @@ FUNCTION: DWORD GetNetworkParams ( PFIXED_INFO pFixedInfo, PULONG pOutBufLen ) ;
             [ Next>> ] bi dup
         ] loop drop
     ] { } make ;
+    
+
+! second struct starts at 720h
+
+
+<PRIVATE
+
+: loop-list ( obj -- seq )
+    [ [ dup [ Next>> ] when ] keep ] loop>array nip ;
+
+! Don't use this, use each/map-adapters
+: iterate-interfaces ( -- seq )
+    AF_UNSPEC GAA_FLAG_INCLUDE_PREFIX 0 uint <ref>
+    65,536 [ malloc &free ] [ ULONG <ref> ] bi
+    [ GetAdaptersAddresses win32-error=0/f ] 2keep
+    uint deref drop
+    IP_ADAPTER_ADDRESSES memory>struct loop-list ;
+
+PRIVATE>
+
+
+: interfaces-each ( quot -- seq )
+    [ [ iterate-interfaces ] dip each ] with-destructors ; inline
+
+: interfaces-map ( quot -- seq )
+    [ [ iterate-interfaces ] dip { } map-as ] with-destructors ; inline
+
+: interface-mac-addrs ( -- seq )
+    [
+        {
+            [ Description>> ]
+            [ [ PhysicalAddress>> ] [ PhysicalAddressLength>> ] bi head ]
+        } cleave>array
+    ] interfaces-map ;
+    
+: interface-ips ( -- seq )
+    [
+        {
+            [ Description>> ]
+            [ FirstUnicastAddress>> loop-list [ Address>> SOCKET_ADDRESS>sockaddr sockaddr>ip ] map ]
+        } cleave>array
+    ] interfaces-map ;