[Openmcl-devel] Useful code: get info about network interfaces on Windows.

[Kaz Kylheku]

I found that the IP helper API is not represented in the FFI database, 
so
I hacked this up. Share, criticize, improve ...

Is there a nicer way to handle the len-inout variable? I define it in 
a stack block as a region of the length of :unsigned-long and then set 
its initial value using (setf (%get-unsigned-long ...) ...).

I'd like to just RLET it to be of type #>ULONG and then assign to it 
without mentioning the type in the assignment.

Sample run:

? (get-network-interface-list)
(((144 230 186 208 255 3) (("192.168.1.103" "255.255.255.0"))
  "{BB3E5BE7-4409-4DCC-A96D-FCAD6F80CFBF}"
  "ASUS 802.11 g/b Wireless PCI Adapter")
 ((0 255 163 4 251 147) (("0.0.0.0" "0.0.0.0"))
  "{A304FB93-661E-4C64-BD4C-4988FFF93571}" "TAP-Win32 Adapter V8")
 ((0 255 217 143 238 242) (("0.0.0.0" "0.0.0.0"))
  "{D98FEEF2-3050-45C4-A819-13D583E29F24}" "TAP-Win32 Adapter V9")
 ((0 25 33 80 198 222) (("0.0.0.0" "0.0.0.0"))
  "{49C3B646-9DDD-48CC-9F72-73B8A4DFDF00}"
  "Marvell Yukon 88E8056 PCI-E Gigabit Ethernet Controller")
 ((0 80 86 192 0 1) (("169.254.205.164" "255.255.0.0"))
  "{78D5CAA7-B278-4358-BA60-B4403AB9F635}"
  "VMware Virtual Ethernet Adapter for VMnet1")
 ((0 80 86 192 0 8) (("192.168.206.1" "255.255.255.0"))
  "{31C44EA6-F6D8-44AE-8998-0469EF6FF32D}"
  "VMware Virtual Ethernet Adapter for VMnet8")
 ((8 0 39 0 20 110) (("192.168.56.1" "255.255.255.0"))
  "{B20AEB46-8C0B-4A34-8104-84968E222F89}"
  "VirtualBox Host-Only Ethernet Adapter"))


Microsoft consistency. IP addresses in text, link addresses in binary!


Source:

(eval-when (:compile-toplevel :load-toplevel :execute)
  (open-shared-library "iphlpapi.dll")
  (defconstant MAX_ADAPTER_NAME_LENGTH 256)
  (defconstant MAX_ADAPTER_DESCRIPTION_LENGTH 128)
  (defconstant MAX_ADAPTER_ADDRESS_LENGTH 8))


(def-foreign-type #>IP_ADDR_STRING
  (struct #>IP_ADDR_STRING
    (#>Next :address)
    (#>IpAddress (:array :char 16))
    (#>IpMask (:array :char 16))
    (#>Context #>DWORD)))

(def-foreign-type #>IP_ADAPTER_INFO
  (struct #>IP_ADAPTER_INFO
    (#>Next :address)
    (#>ComboIndex #>DWORD)
    (#>AdapterName (:array :char #.(+ MAX_ADAPTER_NAME_LENGTH 4)))
    (#>Description (:array :char #.(+ MAX_ADAPTER_DESCRIPTION_LENGTH 
4)))
    (#>AddressLength #>UINT)
    (#>Address (:array BYTE #.(+ MAX_ADAPTER_ADDRESS_LENGTH)))
    (#>Index #>DWORD)
    (#>Type #>UINT)
    (#>DhcpEnabled #>UINT)
    (#>CurrentIpAddress :address)
    (#>IpAddressList #>IP_ADDR_STRING)
    #| ... other members omitted ... |# ))


(defun get-ip-address-list (first)
  (loop for ptr = first then (pref ptr #>IP_ADDR_STRING.Next)
        until (%null-ptr-p ptr)
        collecting
          (let ((addr (pref ptr #>IP_ADDR_STRING.IpAddress))
                (mask (pref ptr #>IP_ADDR_STRING.IpMask)))
            (list (%get-cstring addr) (%get-cstring mask)))))


(defun get-network-interface-list ()
  (let ((blk-size 65536) ;; crude!
        (get-adapters-info (foreign-symbol-address 
"GetAdaptersInfo")))
      (if get-adapters-info
        (%stack-block ((blk blk-size)
                       (len-inout (ccl::record-length 
:unsigned-long)))
          (setf (%get-unsigned-long len-inout) blk-size)
          (if (zerop (ff-call get-adapters-info :address blk
                                                :address len-inout
                                                #>DWORD))
            (loop for ptr = blk then (pref ptr #>IP_ADAPTER_INFO.Next)
                  until (%null-ptr-p ptr)
                  collecting
                    (let ((alen (pref ptr 
#>IP_ADAPTER_INFO.AddressLength))
                          (addr (pref ptr #>IP_ADAPTER_INFO.Address))
                          (aname (pref ptr 
#>IP_ADAPTER_INFO.AdapterName))
                          (descr (pref ptr 
#>IP_ADAPTER_INFO.Description))
                          (iplist (pref ptr 
#>IP_ADAPTER_INFO.IpAddressList)))
                      (list (loop for i below alen
                                  collecting (%get-unsigned-byte addr 
i))
                            (get-ip-address-list iplist)
                            (%get-cstring aname)
                            (%get-cstring descr)))))))))