Win32-dhcp-server 0.3 → 0.3.1
raw patch · 38 files changed
+1684/−1682 lines, 38 files
Files
- ChangeLog +6/−0
- Data/Ip.hs +0/−81
- Data/Mac.hs +0/−121
- System/Win32/DHCP.hs +0/−358
- System/Win32/DHCP/CLIENT_UID.hs +0/−55
- System/Win32/DHCP/Client.hs +0/−122
- System/Win32/DHCP/DhcpStructure.hs +0/−187
- System/Win32/DHCP/HOST_INFO.hs +0/−58
- System/Win32/DHCP/IP_CLUSTER.hs +0/−25
- System/Win32/DHCP/IP_RANGE.hs +0/−22
- System/Win32/DHCP/Internal.hs +0/−151
- System/Win32/DHCP/LengthBuffer.hs +0/−63
- System/Win32/DHCP/Reservation.hs +0/−81
- System/Win32/DHCP/SEARCH_INFO.hs +0/−68
- System/Win32/DHCP/SUBNET_CLIENT_INFO_ARRAY_V4.hs +0/−22
- System/Win32/DHCP/SUBNET_ELEMENT_DATA_V4.hs +0/−102
- System/Win32/DHCP/SUBNET_ELEMENT_INFO_ARRAY_V4.hs +0/−22
- System/Win32/DHCP/Types.hs +0/−76
- Utils.hs +0/−51
- Win32-dhcp-server.cabal +20/−17
- src/Data/Ip.hs +79/−0
- src/Data/Mac.hs +118/−0
- src/Import.hs +98/−0
- src/System/Win32/DHCP.hs +342/−0
- src/System/Win32/DHCP/CLIENT_UID.hs +56/−0
- src/System/Win32/DHCP/Client.hs +117/−0
- src/System/Win32/DHCP/DhcpStructure.hs +185/−0
- src/System/Win32/DHCP/HOST_INFO.hs +53/−0
- src/System/Win32/DHCP/IP_CLUSTER.hs +21/−0
- src/System/Win32/DHCP/IP_RANGE.hs +20/−0
- src/System/Win32/DHCP/Internal.hs +151/−0
- src/System/Win32/DHCP/LengthBuffer.hs +58/−0
- src/System/Win32/DHCP/Reservation.hs +78/−0
- src/System/Win32/DHCP/SEARCH_INFO.hs +67/−0
- src/System/Win32/DHCP/SUBNET_CLIENT_INFO_ARRAY_V4.hs +22/−0
- src/System/Win32/DHCP/SUBNET_ELEMENT_DATA_V4.hs +98/−0
- src/System/Win32/DHCP/SUBNET_ELEMENT_INFO_ARRAY_V4.hs +22/−0
- src/System/Win32/DHCP/Types.hs +73/−0
ChangeLog view
@@ -1,3 +1,9 @@+0.3.1+=====++* updated documentation+* internal refactoring+ 0.3 ===
− Data/Ip.hs
@@ -1,81 +0,0 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE OverloadedStrings #-}---- | This module was taken, with modifications, from the--- <http://hackage.haskell.org/package/maccatcher maccatcher> package.-module Data.Ip- ( Ip ()- -- * String conversions- , readIp- , showIp- -- * Octet conversions- , fromOctets- , toOctets- -- * Other conversions- , toWord32- ) where--import Control.Applicative-import Control.Monad (unless)-import Data.Bits-import Data.Text (Text)-import qualified Data.Text as T-import Data.Text.Read-import Data.Word-import Foreign--import Utils (fmapL, note)---- |An Ip can be used as an IP address or subnet address.------ A `Show` instance is omitted to avoid confusion. Use `showIp` and `readIp`--- to convert between `String`s.-newtype Ip = Ip {unIp :: Word32}- deriving (Eq, Ord, Bounded, Storable)---- |Represent an `Ip` as a `String`.------ >>> showIp $ fromOctets 192 168 1 100--- "192.168.1.100"-showIp :: Ip -> Text-showIp ip = T.intercalate "." . map (T.pack . show) $ [a, b, c, d]- where (a, b, c, d) = toOctets ip---- |Parse a `Text` value as an `Ip`. The string should be of the form--- "X.X.X.X" where each 'X' is a decimal value between 0 and 255 inclusive.------ >>> let Right ip = readIp "192.168.1.100"--- >>> toOctets ip--- (192, 168, 1, 100)-readIp :: Text -> Either String Ip-readIp s = fmapL (\e -> "Error parsing IP address: " ++ e) $ do- (a, s2) <- decimal s- (b, s3) <- dot s2 >>= decimal- (c, s4) <- dot s3 >>= decimal- (d, s5) <- dot s4 >>= decimal- unless (s5 == "") $ Left "exactly 4 octets were expected."- -- Confirm that all digits are in range- fromOctets <$> digit a <*> digit b <*> digit c <*> digit d- where- dot = note "Expected '.' character." . T.stripPrefix "."- digit :: Int -> Either String Word8- digit x | x < 0 || x > 255 = Left "digit out of range."- | otherwise = Right $ fromIntegral x---- |An IP address is 32-bits wide. This function will construct an `Ip` from--- 4 octets.-fromOctets :: Word8 -> Word8 -> Word8 -> Word8 -> Ip-fromOctets a b c d = Ip- $ (fromIntegral a `shiftL` 24)- .|. (fromIntegral b `shiftL` 16)- .|. (fromIntegral c `shiftL` 8)- .|. (fromIntegral d)---- |Extract each of the 4 octets from an `Ip`.-toOctets :: Ip -> (Word8, Word8, Word8, Word8)-toOctets (Ip word) = (byte 3 word, byte 2 word, byte 1 word, byte 0 word)- where- byte i w = fromIntegral (w `shiftR` (i * 8))--toWord32 :: Ip -> Word32-toWord32 = unIp
− Data/Mac.hs
@@ -1,121 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}---- | This module was taken, with modifications, from the--- <http://hackage.haskell.org/package/maccatcher maccatcher> package.-module Data.Mac- ( Mac ()- -- ** String conversions- , readMac- , showMac- -- ** Octet conversions- , fromOctets- , toOctets- -- ** Other conversions- , toWord64- ) where--import Control.Applicative-import Control.Monad (unless)-import Data.Bits-import Data.Monoid-import Data.Text (Text)-import qualified Data.Text as T-import qualified Data.Text.Lazy as L-import qualified Data.Text.Lazy.Builder as L-import qualified Data.Text.Lazy.Builder.Int as L-import Data.Text.Read-import Data.Word-import Foreign--import Utils---- |A Mac is a 6-byte unique identifier used in layer-two network addressing.--- Its `Storable` instance occupies 6 bytes of memory when `poke`d with the--- first byte occupying the lowest address, and the last byte occupying the--- highest address.------ A `Show` instance is omitted to avoid confusion. Use `showMac` and--- `readMac` to convert between `String`s.-newtype Mac = Mac { unMac :: Word64 }- deriving (Bounded, Eq, Ord)--instance Storable Mac where- sizeOf _ = 6- alignment _ = 1- peek p = fromOctets <$> (peek $ castPtr p) <*> peekByteOff p 1- <*> peekByteOff p 2 <*> peekByteOff p 3 <*> peekByteOff p 4- <*> peekByteOff p 5- poke p mac = do- poke (castPtr p) a- pokeByteOff p 1 b- pokeByteOff p 2 c- pokeByteOff p 3 d- pokeByteOff p 4 e- pokeByteOff p 5 f- where- (a, b, c, d, e, f) = toOctets mac--toWord64 :: Mac -> Word64-toWord64 = unMac---- |Represent a `Mac` as a `String`. The supplied separator will be placed--- between each octet in the final output.------ >>> showMac "" $ fromOctets 0xa 0xb 0xc 0xd 0xe 0xf--- "0a0b0c0d0e0f"------ >>> showMac ":" $ fromOctets 0x11 0x22 0x33 0x44 0x55 0x66--- "11:22:33:44:55:66"-showMac :: Text -> Mac -> Text-showMac sep mac = T.intercalate sep . map octet $ [a, b, c, d, e, f]- where- octet x = pad (2 :: Int) . L.toStrict . L.toLazyText . L.hexadecimal $ x- (a, b, c, d, e, f) = toOctets mac- pad n str = T.replicate (max 0 (n - T.length str)) "0" <> str---- |Parse a `Text` value as a `Mac`. The string should not use any--- separators between octets.------ >>> let Right mac = readMac "000102030405"--- >>> toOctets mac--- (0, 1, 2, 3, 4, 5)-readMac :: Text -> Either String Mac-readMac s = fmapL (\e -> "Error parsing MAC address: " ++ e) $ do- (a, s2) <- octet s- (b, s3) <- octet s2- (c, s4) <- octet s3- (d, s5) <- octet s4- (e, s6) <- octet s5- (f, s7) <- octet s6- unless (s7 == "") $ Left "exactly 6 octets were expected."- fromOctets <$> digit a <*> digit b <*> digit c- <*> digit d <*> digit e <*> digit f- where- octet :: Text -> Either String (Int, Text)- octet s0 = do- (a, s2) <- hexadecimal a0- unless (s2 == "") $ Left "invalid characters"- return (a, rest)- where- (a0, rest) = T.splitAt 2 s0- digit :: Int -> Either String Word8- digit x | x < 0 || x > 255 = Left "digit out of range."- | otherwise = Right $ fromIntegral x---- |A Mac address is 48-bits wide. This function will construct a `Mac` from--- 6 octets.-fromOctets :: Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Mac-fromOctets a b c d e f = Mac- $ (fromIntegral a `shiftL` 40)- .|. (fromIntegral b `shiftL` 32)- .|. (fromIntegral c `shiftL` 24)- .|. (fromIntegral d `shiftL` 16)- .|. (fromIntegral e `shiftL` 8)- .|. (fromIntegral f)---- |Extract each of the 6 octets from a `Mac`.-toOctets :: Mac -> (Word8, Word8, Word8, Word8, Word8, Word8)-toOctets (Mac word) = ( byte 5 word, byte 4 word, byte 3 word- , byte 2 word, byte 1 word, byte 0 word)- where- byte i w = fromIntegral (w `shiftR` (i * 8))
− System/Win32/DHCP.hs
@@ -1,358 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}---- |--- module: System.Win32.DHCP--- copyright: (c) Michael Steele, 2014--- license: BSD3--- maintainer: mikesteele81@gmail.com--- stability: experimental--- portability: Windows-module System.Win32.DHCP- ( DhcpApi ()- , loadDHCP- -- * General Types- , Context (..)- , ClientType (..)- , DATE_TIME (..)- , HOST_INFO (..)- , SEARCH_INFO (..)- -- * Leases- , Client (..)- , enumClients- , lookupClient- , deleteClient- -- * Reservations- , Mapping (..)- , Reservation(..)- , addReservation- , enumReservations- , removeReservation- ) where--import Control.Applicative-import Control.Monad (unless)-import Data.Char (chr)-import Data.Maybe (fromMaybe)-import Data.Text (Text)-import qualified Data.Text as T-import qualified Data.Text.Foreign as T-import Foreign-import Foreign.C.Types--import System.Win32.Types hiding (withTString, withTStringLen)-import qualified System.Win32.Error as E-import qualified System.Win32.Error.Foreign as E--import Data.Ip-import System.Win32.DHCP.DhcpStructure-import System.Win32.DHCP.HOST_INFO-import System.Win32.DHCP.Internal-import System.Win32.DHCP.Client-import System.Win32.DHCP.LengthBuffer-import System.Win32.DHCP.Reservation-import System.Win32.DHCP.SEARCH_INFO-import System.Win32.DHCP.SUBNET_CLIENT_INFO_ARRAY_V4-import System.Win32.DHCP.SUBNET_ELEMENT_DATA_V4-import System.Win32.DHCP.SUBNET_ELEMENT_INFO_ARRAY_V4-import System.Win32.DHCP.Types-import Utils---- | A Context defines which server and scope within that server a command--- refers to. Microsoft's DHCP server supports multiple scopes. This allows--- different configurations to be sent to devices based on their hardware--- (MAC) address. Scopes are identified by their network address.-data Context = Context- { -- | The DHCP server management API uses an RPC mechanism to control the- -- server.- contextServer :: !Text- , -- | Scopes are identified by a subnet identifier. This is useful in- -- cases where multiple scopes are defined, but still required in the- -- common case of a single scope.- contextSubnet :: !Ip- } deriving (Eq, Ord)---- | Delete an active DHCP lease from the server.--- The `SEARCH_INFO` argument determines which search criteria--- to use. Searching by name will delete all active leases--- with that name. This action corresponds to MSDN's DhcpDeleteClientInfoV4--- function.-deleteClient :: DhcpApi- -> Text- -- ^ String which specifies the IP address or hostname of the DHCP- -- server.- -> SEARCH_INFO- -- ^ Define how to lookup a client to delete. Only deleting based on- -- IP addresses have been tested.- -> IO ()- -- ^ This function will throw an 'E.Win32Exception' when the internal Win32- -- call returnes an error condition. MSDN lists the following exceptions,- -- but others might be thrown as well:- --- -- ['E.DhcpReservedClient'] The specified DHCP client is a reserved DHCP- -- client.- --- -- ['E.DhcpJetError'] An error occurred while accessing the DHCP server- -- database, or the client entry is not present in the database.-deleteClient api server si =- withTString server $ \pserver ->- withSearchInfo si $ \psi ->- E.failUnlessSuccess "DeleteClientInfo"- $ c_DeleteClientInfo api pserver psi---- | Perform a lookup operation for all client lease records within a--- scope. This action corresponds to MSDN's DhcpEnumSubnetClientsV4 function.-enumClients :: DhcpApi- -> Context- -- ^ Specify which server and scope to search for client leases.- -> IO [Client]- -- ^ The empty list means that no client records exist for the provided- -- subnet. This function will throw an 'E.Win32Exception' when the- -- internal Win32 call returnes an error condition. MSDN lists the- -- following exceptions, but others might be thrown as well:- --- -- ['E.DhcpJetError'] An error occurred while accessing the DHCP server- -- database.-enumClients dhcp (Context server subnet) =- enumSubnetClientsV4 dhcp server subnet---- | Search the DHCP server for a lease matching the given search criteria.--- `Nothing` is returned when no lease was found. This corresponds to MSDN's--- DhcpGetClientInfoV4 function.-lookupClient :: DhcpApi- -> Text- -- ^ According to MSDN this must specify the IP address of the server.- -- Other functions (including this one) may or may not also accept- -- a Unicode host name.- -> SEARCH_INFO- -- ^ Define how to lookup a client. Only searching based on an- -- IP addresses has been tested.- -> IO (Maybe Client)- -- ^ A `Nothing` indicates that no client was found. This function will throw an 'E.Win32Exception' when the- -- internal Win32 call returnes an error condition. MSDN lists the- -- following exceptions, but others might be thrown as well:- --- -- ['E.DhcpJetError'] An error occurred while accessing the DHCP server- -- database.-lookupClient api serverip si =- withTString serverip $ \pserverip ->- withSearchInfo si $ \psi ->- with nullPtr $ \ppclientinfo -> do- -- DhcpGetClientInfo takes a structure on the stack.- siType <- peek (castPtr psi :: Ptr CInt)- siPayload <- peekElemOff (castPtr psi :: Ptr (Ptr ())) 4- E.failUnlessSuccess "GetClientInfoV4"- $ c_GetClientInfoV4 api pserverip siType siPayload ppclientinfo-- -- Extract client information from out parameter and free the memory- -- 'Nothing' will be returned the case where GetClientInfoV4 returns a- -- null pointer.- scrubWith ppclientinfo $ \pclientinfo -> do- clientinfo <- peekDhcp clientInfo pclientinfo- freeDhcp clientInfo (rpcFreeMemory api) pclientinfo- return clientinfo--addReservation :: DhcpApi -> Context -> Mapping- -> IO ()- -- ^ This function will throw an 'E.Win32Exception' when the internal Win32- -- call returnes an error condition. MSDN lists the following exceptions,- -- but others might be thrown as well:- --- -- ['E.DhcpSubnetNotPresent'] The specified IPv4 subnet does not exist- -- on the DHCP server.- --- -- ['E.DhcpJetError'] An error occurred while accessing the DHCP server- -- database.- --- -- ['E.DhcpNotReservedClient'] The specified DHCP client is not a- -- reserved client.- --- -- ['E.DhcpInvalidRange'] The specified IPv4 range does not match an- -- existing IPv4 range.- --- -- ['E.ScopeRangePolicyChangeConflict'] An IP address range is- -- configured for a policy in this scope. This operation cannot be- -- performed on the scope IP address range until the policy IP address- -- range is suitably modified.-addReservation dhcp (Context server subnet) mapping =- addSubnetElementV4 dhcp server subnet- $ ReservedIps (Reservation mapping Both)--enumReservations :: DhcpApi -> Context -> IO [Reservation]-enumReservations dhcp (Context server subnet) = do- ex <- enumSubnetElementsV4 dhcp server subnet 2- res <- flip mapM ex $ \element -> do- case element of- ReservedIps res -> return res- _ -> error "bug in Win32 API."- return res---- | Remove a reservation from the server-removeReservation :: DhcpApi -> Context -> Mapping- -> ClientType- -- ^ Specify a DHCP reservation, BOOTP reservation, or both. This is untested.- -> Bool- -- ^ Specify whether any active leases for the reservation should be- -- removed as well.- -> IO ()- -- ^ This function will throw an 'E.Win32Exception' when the internal Win32- -- call returnes an error condition. MSDN lists the following exceptions,- -- but others might be thrown as well:- --- -- ['E.DhcpSubnetNotPresent'] The specified IPv4 subnet does not exist- -- on the DHCP server.- --- -- ['E.DhcpElementCantRemove'] Failure can occur for any number of- -- reasons.- --- -- ['E.DhcpJetError'] An error occurred while accessing the DHCP server- -- database.- --- -- ['E.DhcpInvalidRange'] The specified IPv4 range does not match an- -- existing IPv4 range.- --- -- ['E.ScopeRangePolicyChangeConflict'] An IP address range is- -- configured for a policy in this scope. This operation cannot be- -- performed on the scope IP address range until the policy IP address- -- range is suitably modified.-removeReservation dhcp (Context server subnet) mapping ct force =- removeSubnetElementV4 dhcp server subnet- (ReservedIps $ Reservation mapping ct) fForce- where- fForce = if force then FullForce else NoForce--enumSubnetClientsV4 :: DhcpApi -> Text -> Ip -> IO [Client]-enumSubnetClientsV4 dhcp server subnet =- withTString server $ \pServer ->- -- inout parameter. Supply on successive calls to retreive more elements- with 0 $ \pResumeHandle ->- alloca $ \pElementsRead ->- alloca $ \pElementsTotal ->- with nullPtr $ \ppInfoArray -> do- -- We have to call enumSubnetElementsV4 at least twice for a sucessfull run.- -- Failure to use the returned resumeHandle may result in an internal access- -- violation within RPCRT4.dll.- let loop acc = do- ret <- E.fromDWORD <$> c_EnumSubnetClientsV4 dhcp pServer (toWord32 subnet)- pResumeHandle 0xFFFFFFFF ppInfoArray- pElementsRead pElementsTotal- unless (elem ret [E.Success, E.MoreData, E.NoMoreItems])- $ E.failWith "EnumSubnetClientsV4" ret-- melems <- scrubWith ppInfoArray $ \pInfoArray -> do- SUBNET_CLIENT_INFO_ARRAY_V4 (LengthBuffer _ elems) <- peekDhcp clientInfoArray pInfoArray- freeDhcp clientInfoArray (rpcFreeMemory dhcp) pInfoArray- return elems- let elems = fromMaybe [] melems-- if (ret == E.NoMoreItems || ret == E.Success)- then return (elems:acc)- else loop (elems:acc)-- revelemss <- loop []- return $ concat $ reverse revelemss--enumSubnetElementsV4 :: DhcpApi -> Text -> Ip -> CInt- -> IO [SUBNET_ELEMENT_DATA_V4]-enumSubnetElementsV4 dhcp server subnet elementType =- withTString server $ \pServer ->- -- inout parameter. Supply on successive calls to retreive more elements- with 0 $ \pResumeHandle ->- alloca $ \pElementsRead ->- alloca $ \pElementsTotal ->- with nullPtr $ \ppInfoArray -> do- -- We have to call enumSubnetElementsV4 at least twice for a sucessfull run.- -- Failure to use the returned resumeHandle may result in an internal access- -- violation within RPCRT4.dll.- let loop acc = do- ret <- E.fromDWORD <$> c_EnumSubnetElementsV4 dhcp pServer (toWord32 subnet) elementType- pResumeHandle 0xFFFFFFFF ppInfoArray- pElementsRead pElementsTotal- unless (elem ret [E.Success, E.MoreData, E.NoMoreItems])- $ E.failWith "EnumSubnetElementsV4" ret-- melems <- scrubWith ppInfoArray $ \pInfoArray -> do- SUBNET_ELEMENT_INFO_ARRAY_V4 (LengthBuffer _ elems) <- peekDhcp infoArray pInfoArray- freeDhcp infoArray (rpcFreeMemory dhcp) pInfoArray- return elems- let elems = fromMaybe [] melems-- -- Intentionally ignore elementsTotal. Microsoft's documentation- -- on how this should work doesn't seem right. In my testing- -- elementsTotal always returns 0x7fffffff until the last loop, at- -- which time it always matches elementsRead.- if (ret == E.NoMoreItems || ret == E.Success)- then return (elems:acc)- else loop (elems:acc)-- revelemss <- loop []- return $ concat $ reverse revelemss--addSubnetElementV4 :: DhcpApi -> Text -> Ip -> SUBNET_ELEMENT_DATA_V4 -> IO ()-addSubnetElementV4 dhcp server subnet elementData =- withTString server $ \pServer ->- withDhcp subnetElementData elementData $ \pElementData ->- E.failUnlessSuccess "AddSubnetElementsV4"- $ c_AddSubnetElementV4 dhcp pServer (toWord32 subnet) pElementData---- | Remove an IPv4 subnet element from an IPv4 subnet defined on the DHCPv4--- server.-removeSubnetElementV4- :: DhcpApi- -> Text -- ^ Unicode string that specifies the IP address, such as- -- \"123.456.789.012\", or hostname, such as \"server\",- -- of the DHCP server.- -> Ip -- ^ 'DWORD' value that specifies the IP address of the- -- subnet gateway and uniquely identifies it. As an- -- example, with the above IP address and a subnet mask- -- of 255.255.255.0, the subnet would be 123.456.789.0.- -- This must then be converted to a 'DWORD' value of- -- 2,093,683,968.- -> SUBNET_ELEMENT_DATA_V4 -- ^ 'DHCP_SUBNET_ELEMENT_DATA_V4' structure- -- that contains information used to find the- -- element that will be removed from subnet- -- specified in SubnetAddress.- -> FORCE_FLAG -- ^ DHCP_FORCE_FLAG enumeration value that indicates- -- whether or not the clients affected by the removal of- -- the subnet element should also be deleted.- --- -- Note If the flag is set to DhcpNoForce and this subnet- -- has served an IPv4 address to DHCPv4/BOOTP clients, the- -- IPv4 range is not deleted; conversely, if the flag is- -- set to DhcpFullForce, the IPv4 range is deleted along- -- with the DHCPv4 client lease record on the DHCPv4- -- server.- -> IO ()- -- ^ This function will throw an 'E.Win32Exception' when the internal Win32- -- call returnes an error condition. MSDN lists the following exceptions,- -- but others might be thrown as well:- --- -- ['E.DhcpSubnetNotPresent'] The specified IPv4 subnet does not exist- -- on the DHCP server.- --- -- ['E.DhcpElementCantRemove'] Failure can occur for any number of- -- reasons.- --- -- ['E.DhcpJetError'] An error occurred while accessing the DHCP server- -- database.- --- -- ['E.DhcpInvalidRange'] The specified IPv4 range does not match an- -- existing IPv4 range.- --- -- ['E.ScopeRangePolicyChangeConflict'] An IP address range is- -- configured for a policy in this scope. This operation cannot be- -- performed on the scope IP address range until the policy IP address- -- range is suitably modified.-removeSubnetElementV4 dhcp server subnet elementData forceFlag =- withTString server $ \pServer ->- withDhcp subnetElementData elementData $ \pElementData ->- E.failUnlessSuccess "RemoveSubnetElementV4"- $ c_RemoveSubnetElementV4 dhcp pServer (toWord32 subnet) pElementData- (fromIntegral . fromEnum $ forceFlag)--withTStringLen :: Text -> (LPTSTR -> T.I16 -> IO a) -> IO a-withTStringLen text act = T.useAsPtr (T.snoc text (chr 0x0)) $ \ptr len ->- act (castPtr ptr) len--withTString :: Text -> (LPTSTR -> IO a) -> IO a-withTString text act = withTStringLen text $ \ptr _ -> do- act ptr
− System/Win32/DHCP/CLIENT_UID.hs
@@ -1,55 +0,0 @@-module System.Win32.DHCP.CLIENT_UID - ( CLIENT_UID (..) - , clientUid - , macCuid - , macCuidDrop5 - , withMac - ) where - -import Foreign -import System.Win32.Types - -import Data.Mac -import System.Win32.DHCP.DhcpStructure -import System.Win32.DHCP.LengthBuffer --- typedef struct _DHCP_BINARY_DATA { --- DWORD DataLength; --- BYTE *Data; --- } DHCP_BINARY_DATA, *LPDHCP_BINARY_DATA, DHCP_CLIENT_UID; - --- Byte 0 - 3: The result of a binary AND on the IP address and the subnet --- mask in reverse order. --- Byte 4: Hardware identifier. This value is always 0x01. --- Byte 5 - 10: The Mac address of the client. -newtype CLIENT_UID = CLIENT_UID (LengthBuffer BYTE) - -unwrap :: CLIENT_UID -> LengthBuffer BYTE -unwrap (CLIENT_UID uid) = uid - -clientUid :: DhcpStructure CLIENT_UID -clientUid = newtypeDhcpStructure CLIENT_UID unwrap - $ lengthBuffer (basicDhcpArray storableDhcpStructure) - --- Functions returning a CLIENT_UID often have the first 5 bytes hold --- information about the subnet being used. -macCuidDrop5 :: CLIENT_UID -> Mac -macCuidDrop5 (CLIENT_UID (LengthBuffer _ bytes)) = fromOctets a b c d e f - where - [a, b, c, d, e, f] = drop 5 bytes - -macCuid :: CLIENT_UID -> Mac -macCuid (CLIENT_UID (LengthBuffer _ bytes)) = fromOctets a b c d e f - where - [a, b, c, d, e, f] = bytes - -fromMac :: Mac -> CLIENT_UID -fromMac mac = CLIENT_UID (LengthBuffer 6 [a, b, c, d, e, f]) - where - (a, b, c, d, e, f) = toOctets mac - --- |When creating CLIENT_UID structures in memory we only need 6 bytes --- representing the Mac address. This is contrary to MSDN documentation, which --- states that there should be 11 bytes, with the first 5 being constructed --- from the IP and subnet. -withMac :: Mac -> (Ptr CLIENT_UID -> IO b) -> IO b -withMac mac f = withDhcp clientUid (fromMac mac) f
− System/Win32/DHCP/Client.hs
@@ -1,122 +0,0 @@-{-# LANGUAGE RankNTypes #-}--module System.Win32.DHCP.Client- ( Client (..)- , clientInfo- ) where--import Control.Applicative-import Foreign--import System.Win32.Types--import Data.Ip-import Data.Mac-import System.Win32.DHCP.CLIENT_UID-import System.Win32.DHCP.DhcpStructure-import System.Win32.DHCP.HOST_INFO-import System.Win32.DHCP.Types-import Utils---- | Information about an active lease. This type corresponds to--- MSDN's DHCP_CLIENT_INFO_V4 structure.------ > typedef struct _DHCP_CLIENT_INFO_V4 {--- > DHCP_IP_ADDRESS ClientIpAddress;--- > DHCP_IP_MASK SubnetMask;--- > DHCP_CLIENT_UID ClientHardwareAddress;--- > LPWSTR ClientName;--- > LPWSTR ClientComment;--- > DATE_TIME ClientLeaseExpires;--- > DHCP_HOST_INFO OwnerHost;--- > BYTE bClientType;--- > } DHCP_CLIENT_INFO_V4, *LPDHCP_CLIENT_INFO_V4;-data Client = Client- { clientIp :: !Ip- , clientSubnetMask :: !Ip- , clientHardwareAddress :: !Mac- , clientName :: Maybe String- , clientComment :: Maybe String- , clientLeaseExpires :: !DATE_TIME- -- ^ MSDN: The date and time the DHCP client lease will expire, in UTC- -- time.- --- -- I don't know of any available functions to work with a `DATE_TIME`.- , clientOwnerHost :: !HOST_INFO- -- ^ Information on the DHCP server that assigned the lease to the client.- , clientType :: !ClientType- }- -clientInfo :: DhcpStructure Client-clientInfo = DhcpStructure- { peekDhcp = peekClientInfoV4- , freeDhcpChildren = freeClientInfoV4- , withDhcp' = withClientInfo'- -- 12-byte alignment because of the inlined HOST_INFO struct- , sizeDhcp = 48- }--withClientInfo' :: Client -> Ptr Client -> IO r -> IO r-withClientInfo' c ptr f = - -- The Mac is inlined, so we'll need to copy pmacsrc into pmac- withMac (clientHardwareAddress c) $ \pcuidsrc ->- withMaybeTString (clientName c) $ \pclientName ->- withMaybeTString (clientComment c) $ \pclientComment ->- withDhcp' hostInfo (clientOwnerHost c) (pownerHost ptr) $ do- poke (pclientIP ptr) $ clientIp c- poke (psubnetMask ptr) $ clientSubnetMask c- -- we can't use the Storable instance for Mac here.- copyBytes (pmac ptr) pcuidsrc $ sizeDhcp clientUid- poke (ppclientName ptr) pclientName- poke (ppclientComment ptr) pclientComment- poke (pleaseExpires ptr) $ clientLeaseExpires c- -- Owner host has already been poked- poke (pclientType ptr) $ clientType c- f--peekClientInfoV4 :: Ptr Client -> IO Client-peekClientInfoV4 ptr = Client- <$> (peek $ pclientIP ptr)- <*> (peek $ psubnetMask ptr)- <*> (macCuid <$> peekDhcp clientUid (pmac ptr))- <*> (peek (ppclientName ptr) >>= peekMaybeTString)- <*> (peek (ppclientComment ptr) >>= peekMaybeTString)- <*> (peek $ pleaseExpires ptr)- <*> (peekDhcp hostInfo $ pownerHost ptr)- <*> (peek $ pclientType ptr)--freeClientInfoV4 :: (forall a. Ptr a -> IO ()) -> Ptr Client -> IO ()-freeClientInfoV4 freefunc ptr = do- -- The client_uid is inlined into the client_info structure.- freeDhcpChildren clientUid freefunc $ pmac ptr- freefunc `scrubbing_` ppclientName ptr- freefunc `scrubbing_` ppclientComment ptr- -- The HOST_INFO structure is inlined within the ClientInfoV4, so we don't- -- have to free its main pointer.- freeDhcpChildren hostInfo freefunc $ pownerHost ptr--pclientIP :: Ptr Client -> Ptr Ip-pclientIP = castPtr--psubnetMask :: Ptr Client -> Ptr Ip-psubnetMask ptr = castPtr ptr `plusPtr` 4---- The client_uid is inlined into the client_info structure.-pmac :: Ptr Client -> Ptr CLIENT_UID-pmac ptr = castPtr ptr `plusPtr` 8--ppclientName :: Ptr Client -> Ptr LPWSTR-ppclientName ptr = castPtr ptr `plusPtr` 16--ppclientComment :: Ptr Client -> Ptr LPWSTR-ppclientComment ptr = castPtr ptr `plusPtr` 20--pleaseExpires :: Ptr Client -> Ptr DATE_TIME-pleaseExpires ptr = castPtr ptr `plusPtr` 24---- the HOST_INFO is inlined into the CLIENT_INFO structure-pownerHost :: Ptr Client -> Ptr HOST_INFO-pownerHost ptr = castPtr ptr `plusPtr` 32--pclientType :: Ptr Client -> Ptr ClientType-pclientType ptr = castPtr ptr `plusPtr` 44
− System/Win32/DHCP/DhcpStructure.hs
@@ -1,187 +0,0 @@-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE RankNTypes #-}--module System.Win32.DHCP.DhcpStructure where--import Control.Applicative-import Control.Monad (when)-import Foreign.Marshal.Alloc (allocaBytes)-import Foreign.Ptr-import Foreign.Storable--import Utils---- |Function dictionary for objects used with the DHCP api.--- * Ability to peek from a pointer to that object.--- * Ability to properly free an object using Win32's rpcFreeMemory--- created by the DHCP api.--- * Ability to use the with* metaphor to temporarily poke an--- object into C memory, call a continuation on it, and then--- free the memory from Haskell's heap.------ Extra features made possible by the typeclass--- * Ability to turn any Storable instance into a DhpcStructure instance--- by wrapping it into a StorableDhcpStructure.--- * Ability to peek an array of DHCP structures into a list.--- * Ability to poke a list of objects into contiguous memory, then--- call a continuation on that block of memory.-data DhcpStructure a = DhcpStructure- { peekDhcp :: Ptr a -> IO a- -- |Cleaning up memory is the responsibility of the client of this- -- library. Most out parameters return compound structures which need to- -- be recursively navigated, freeing all children, before freeing the main- -- pointer.- --- -- This function only frees child objects without freeing the pointer- -- itself. It's necessary because some structures contained inline- -- structures instead of the usual pointer. A separate 'freeDhcp' function- -- will call this one before freeing its supplied pointer.- , freeDhcpChildren :: (forall x. Ptr x -> IO ()) -> Ptr a -> IO ()- -- |Like `withDhcp`, but without any allocation or cleanup of memory.- -- The continuation is not automatically given a pointer because- -- the caller should already have it.- , withDhcp' :: forall r. a -> Ptr a -> IO r -> IO r- , sizeDhcp :: Int- }--freeDhcp :: DhcpStructure a -> (forall x. Ptr x -> IO ()) -> Ptr a -> IO ()-freeDhcp dict free ptr = do- freeDhcpChildren dict free ptr- free ptr---- |Allocate memory for a structure, poke it into memory, apply--- a function, and then clean up the memory.-withDhcp :: DhcpStructure a -> a -> (Ptr a -> IO r) -> IO r-withDhcp dict a f = allocaBytes (sizeDhcp dict) $ \ptr ->- withDhcp' dict a ptr $ f ptr---- |Convert a DhcpStructure so that it can be used with a newtype--- wrapper.-newtypeDhcpStructure :: (a -> nt) -> (nt -> a)- -> DhcpStructure a -> DhcpStructure nt-newtypeDhcpStructure wrap unwrap dict =- DhcpStructure peekNt freeNt withNt' (sizeDhcp dict)- where- peekNt ptr = wrap <$> peekDhcp dict (castPtr ptr)- freeNt :: (forall x. Ptr x -> IO ()) -> Ptr a -> IO ()- freeNt f ptr = freeDhcpChildren dict f (castPtr ptr)- withNt' a ptr f = withDhcp' dict (unwrap a) (castPtr ptr) f---- |This is used in cases like 'CLIENT_UID' where we want to treat it like--- a 'LengthArray' but individual elements of the array are simple values.--- We reuse the 'Storable' instances peek and poke functions.-storableDhcpStructure :: forall a. (Storable a) => DhcpStructure a-storableDhcpStructure = DhcpStructure- { peekDhcp = peek- , freeDhcpChildren = \freeFunc ptr -> freeFunc ptr- , withDhcp' = withStorable'- , sizeDhcp = sizeOf (undefined :: a)- }- where- withStorable' x ptr f = poke ptr x >> f--data DhcpArray a = DhcpArray- { peekDhcpArray :: Int -> Ptr a -> IO [a]- , freeDhcpArray :: (forall x. Ptr x -> IO ()) -> Int -> Ptr a -> IO ()- , withDhcpArray' :: forall r. [a] -> Ptr a -> IO r -> IO r- , dhcpStructure :: DhcpStructure a- }---- |Allocate enough contiguous memory for each element. Recursively--- free all memory once the supplied function returns.--- The continuation receives a length argument. This is because--- the length must be calculated in the course of execution, and will--- likely be needed again by the caller.-withDhcpArray :: DhcpArray a -> [a] -> (Int -> Ptr a -> IO r) -> IO r-withDhcpArray dict elems f =- allocaBytes (stride * size) $ \ptr ->- -- `f` is meant to be called on the array as a whole; not individual elements.- -- It's supplied its pointer here because we want it called on position 0.- withDhcpArray' dict elems ptr $ f size ptr- where- size = length elems- stride = sizeDhcp . dhcpStructure $ dict---- |This dictionary is a default set to "base" other versions on.--- Scanning through the buffer happens dhcpSize bytes at a time. Memory--- is freed by calling the freeing function on every element in the buffer.-baseDhcpArray :: DhcpStructure a -> DhcpArray a-baseDhcpArray s = DhcpArray- { peekDhcpArray = basePeekArray s- , freeDhcpArray = baseFreeArray s- , withDhcpArray' = baseWithArray' s- , dhcpStructure = s- }---- |This differs from `baseDhcpArray` in that the entire buffer--- is freed with a single call to the freeing function.-basicDhcpArray :: DhcpStructure a -> DhcpArray a-basicDhcpArray dict = (baseDhcpArray dict)- { freeDhcpArray = basicFreeArray dict- }--ptrDhcpArray :: DhcpStructure a -> DhcpArray a-ptrDhcpArray dict = (baseDhcpArray dict)- { peekDhcpArray = ptrPeekArray dict- , freeDhcpArray = ptrFreeArray dict- , withDhcpArray' = ptrWithArray' dict- }--basePeekArray :: DhcpStructure a -> Int -> Ptr a -> IO [a]-basePeekArray dict len ptr0 = mapM (peekDhcp dict) ptrs- where- ptrs = take len . iterate (`plusPtr` sizeDhcp dict) $ ptr0---- |Elements are arranged end to end in a buffer. The buffer is freed--- at once after each element's children are freed.-baseFreeArray :: DhcpStructure a- -> (forall x. Ptr x -> IO ()) -> Int -> Ptr a -> IO ()-baseFreeArray dict freefunc len ptr- | len <= 0 = return ()- | otherwise = do- f (len - 1)- freefunc ptr- where- f 0 = freeDhcpChildren dict freefunc ptr- f n = do- freeDhcpChildren dict freefunc $ ptr `plusPtr` (n * sizeDhcp dict)- f (n - 1)--baseWithArray' :: DhcpStructure a -> [a] -> Ptr a -> IO r -> IO r-baseWithArray' _ [] _ f = f-baseWithArray' dict (e:es) ptr f =- -- We're not concerned with the individual element.- withDhcp' dict e ptr- $ baseWithArray' dict es (ptr `plusPtr` sizeDhcp dict) f--basicFreeArray :: DhcpStructure a -> (forall x. Ptr x -> IO ())- -> Int -> Ptr a -> IO ()-basicFreeArray dict freefunc _ ptr = freeDhcp dict freefunc ptr--ptrPeekArray :: DhcpStructure a -> Int -> Ptr a -> IO [a]-ptrPeekArray dict len ptr = mapM peekElement pptrs- where- --Each element is a pointer to the real data- pptrs = take len . iterate (`plusPtr` sizeOf nullPtr) $ castPtr ptr- peekElement pptr = peek pptr >>= peekDhcp dict--ptrFreeArray :: DhcpStructure a- -> (forall x. Ptr x -> IO ()) -> Int -> Ptr a -> IO ()-ptrFreeArray dict freefunc len ptr = do- mapM (freeDhcp dict freefunc `scrubbing_`) pptrs- -- Len may very well be 0 in which case there's really nothing to free.- when (len > 0) $ freefunc ptr- where- --Each element is a pointer to the real data- pptrs = take len . iterate (`plusPtr` sizeOf nullPtr) $ castPtr ptr--ptrWithArray' :: DhcpStructure a -> [a] -> Ptr a -> IO r -> IO r-ptrWithArray' _ [] _ f = f-ptrWithArray' dict (e:es) ptr f =- -- We're not concerned with the individual element.- withDhcp dict e $ \pe -> do- poke pptr pe- ptrWithArray' dict es (ptr `plusPtr` sizeOf nullPtr) f- where- --Each element is a pointer to the real data- pptr = castPtr ptr
− System/Win32/DHCP/HOST_INFO.hs
@@ -1,58 +0,0 @@-{-# LANGUAGE RankNTypes #-}--module System.Win32.DHCP.HOST_INFO- ( HOST_INFO (..)- , hostInfo- ) where--import Control.Applicative-import Foreign--import System.Win32.Types--import Data.Ip-import System.Win32.DHCP.DhcpStructure-import Utils---- typedef struct _DHCP_HOST_INFO {--- DHCP_IP_ADDRESS IpAddress;--- LPWSTR NetBiosName;--- LPWSTR HostName;--- } DHCP_HOST_INFO, *LPDHCP_HOST_INFO;-data HOST_INFO = HOST_INFO !Ip (Maybe String) (Maybe String)---hostInfo :: DhcpStructure HOST_INFO-hostInfo = DhcpStructure- { peekDhcp = peekHostInfo- , freeDhcpChildren = freeHostInfoChildren- , withDhcp' = withHostInfo'- , sizeDhcp = 12- }--peekHostInfo :: Ptr HOST_INFO -> IO HOST_INFO-peekHostInfo ptr = do- pnetBiosName <- peek $ ppnetBiosName ptr- phostName <- peek $ pphostName ptr- HOST_INFO <$> peek (castPtr ptr) <*> peekMaybeTString pnetBiosName- <*> peekMaybeTString phostName--withHostInfo' :: HOST_INFO -> Ptr HOST_INFO -> IO r -> IO r-withHostInfo' (HOST_INFO ip netbiosname hostname) ptr f =- withMaybeTString netbiosname $ \pnetbiosname ->- withMaybeTString hostname $ \phostname -> do- poke (castPtr ptr) ip- pokeByteOff (castPtr ptr) 4 pnetbiosname- pokeByteOff (castPtr ptr) 8 phostname- f--freeHostInfoChildren :: (forall x. Ptr x -> IO ()) -> Ptr HOST_INFO -> IO ()-freeHostInfoChildren rpcfree phi = do- rpcfree `scrubbing_` ppnetBiosName phi- rpcfree `scrubbing_` pphostName phi--ppnetBiosName :: Ptr HOST_INFO -> Ptr LPWSTR-ppnetBiosName ptr = castPtr ptr `plusPtr` 4--pphostName :: Ptr HOST_INFO -> Ptr LPWSTR-pphostName ptr = castPtr ptr `plusPtr` 8
− System/Win32/DHCP/IP_CLUSTER.hs
@@ -1,25 +0,0 @@-module System.Win32.DHCP.IP_CLUSTER- ( IP_CLUSTER (..)- ) where--import Control.Applicative-import Foreign--import System.Win32.Types--import Data.Ip---- typedef struct _DHCP_IP_CLUSTER {--- DHCP_IP_ADDRESS ClusterAddress;--- DWORD ClusterMask;--- } DHCP_IP_CLUSTER, *LPDHCP_IP_CLUSTER;-data IP_CLUSTER = IP_CLUSTER !Ip !DWORD--instance Storable IP_CLUSTER where- sizeOf _ = 8- alignment _ = 1- peek ptr = IP_CLUSTER <$> (peek . castPtr $ ptr)- <*> (castPtr ptr `peekByteOff` 4)- poke ptr (IP_CLUSTER ip cmask) = do- poke (castPtr ptr) ip- pokeByteOff (castPtr ptr) 4 cmask
− System/Win32/DHCP/IP_RANGE.hs
@@ -1,22 +0,0 @@-module System.Win32.DHCP.IP_RANGE- ( IP_RANGE (..)- ) where--import Control.Applicative-import Foreign--import Data.Ip--data IP_RANGE = IP_RANGE !Ip !Ip--instance Storable IP_RANGE where- sizeOf _ = 8- alignment _ = 1- peek ptr = IP_RANGE- <$> (peek . castPtr) ptr- <*> castPtr ptr `peekByteOff` 4- poke ptr (IP_RANGE start end) = do- pokeElemOff addrPtr 0 start- pokeElemOff addrPtr 1 end- where- addrPtr = castPtr ptr :: Ptr Ip
− System/Win32/DHCP/Internal.hs
@@ -1,151 +0,0 @@-{-# LANGUAGE ForeignFunctionInterface #-}--module System.Win32.DHCP.Internal where--import Foreign-import Foreign.C-import System.Win32.DLL-import System.Win32.Types--import System.Win32.DHCP.Client-import System.Win32.DHCP.SEARCH_INFO-import System.Win32.DHCP.SUBNET_CLIENT_INFO_ARRAY_V4-import System.Win32.DHCP.SUBNET_ELEMENT_INFO_ARRAY_V4-import System.Win32.DHCP.SUBNET_ELEMENT_DATA_V4-import System.Win32.DHCP.Types---- DWORD DHCP_API_FUNCTION DhcpDeleteClientInfo(--- _In_ DHCP_CONST WCHAR *ServerIpAddress,--- _In_ DHCP_CONST DHCP_SEARCH_INFO *ClientInfo--- );-type DeleteClientInfo = CWString -> Ptr SEARCH_INFO -> IO DWORD-foreign import stdcall "dynamic"- mkDeleteClientInfo :: FunPtr DeleteClientInfo -> DeleteClientInfo---- DWORD DHCP_API_FUNCTION DhcpEnumSubnetClientsV4(--- _In_ DHCP_CONST WCHAR *ServerIpAddress,--- _In_ DHCP_IP_ADDRESS SubnetAddress,--- _Inout_ DHCP_RESUME_HANDLE *ResumeHandle,--- _In_ DWORD PreferredMaximum,--- _Out_ LPDHCP_CLIENT_INFO_ARRAY_V4 *ClientInfo,--- _Out_ DWORD *ClientsRead,--- _Out_ DWORD *ClientsTotal--- );-type EnumSubnetClientsV4 = CWString -> Word32 -> Ptr RESUME_HANDLE- -> DWORD -> Ptr (Ptr SUBNET_CLIENT_INFO_ARRAY_V4) -> Ptr DWORD- -> Ptr DWORD -> IO DWORD-foreign import stdcall "dynamic"- mkEnumSubnetClientsV4 :: FunPtr EnumSubnetClientsV4- -> EnumSubnetClientsV4---- DWORD DHCP_API_FUNCTION DhcpEnumSubnetElementsV4(--- __in DHCP_CONST WCHAR *ServerIpAddress,--- __in DHCP_IP_ADDRESS SubnetAddress,--- __in DHCP_SUBNET_ELEMENT_TYPE EnumElementType,--- __inout DHCP_RESUME_HANDLE *ResumeHandle,--- __in DWORD PreferredMaximum,--- __out LPDHCP_SUBNET_ELEMENT_INFO_ARRAY_V4 *EnumElementInfo,--- __out DWORD *ElementsRead,--- __out DWORD *ElementsTotal--- );-type EnumSubnetElementsV4 = CWString -> Word32 -> CInt -> Ptr RESUME_HANDLE- -> DWORD -> Ptr (Ptr SUBNET_ELEMENT_INFO_ARRAY_V4) -> Ptr DWORD- -> Ptr DWORD -> IO DWORD-foreign import stdcall "dynamic"- mkEnumSubnetElementsV4 :: FunPtr EnumSubnetElementsV4- -> EnumSubnetElementsV4---- DWORD DHCP_API_FUNCTION DhcpGetClientInfoV4(--- _In_ DHCP_CONST WCHAR ServerIpAddress,--- _In_ DHCP_CONST DHCP_SEARCH_INFO SearchInfo,--- _Out_ LPDHCP_CLIENT_INFO_V4 *ClientInfo--- );-type GetClientInfoV4 = CWString -> SEARCH_INFO_TYPE -> Ptr ()- -> Ptr (Ptr Client) -> IO DWORD-foreign import stdcall "dynamic"- mkGetClientInfoV4 :: FunPtr GetClientInfoV4 -> GetClientInfoV4---- | Foreign wrapper to DhcpRemoveSubnetElementV4.--- --- The DhcpRemoveSubnetElementV4 function removes an IPv4 subnet element--- from an IPv4 subnet defined on the DHCPv4 server. The function extends--- the functionality provided by DhcpRemoveSubnetElement by allowing the--- specification of a subnet that contains client type (DHCP or BOOTP)--- information.--- --- See <http://msdn.microsoft.com/en-us/library/ee309533(v=VS.85).aspx> for--- official documentation.--- --- @--- DWORD DHCP_API_FUNCTION DhcpRemoveSubnetElementV4(--- __in DHCP_CONST WCHAR *ServerIpAddress,--- __in DHCP_IP_ADDRESS SubnetAddress,--- __in DHCP_CONST DHCP_SUBNET_ELEMENT_DATA_V4 *RemoveElementInfo,--- __in DHCP_FORCE_FLAG ForceFlag--- );--- @-type RemoveSubnetElementV4 = CWString -> Word32 -> Ptr SUBNET_ELEMENT_DATA_V4- -> CInt -> IO DWORD-foreign import stdcall "dynamic"- mkRemoveSubnetElementV4 :: FunPtr RemoveSubnetElementV4- -> RemoveSubnetElementV4---- DWORD DhcpAddSubnetElementV4(--- __in DHCP_CONST WCHAR *ServerIpAddress,--- __in DHCP_IP_ADDRESS SubnetAddress,--- __in DHCP_CONST DHCP_SUBNET_ELEMENT_DATA_V4 AddElementInfo--- );-type AddSubnetElementV4 = CWString -> Word32 -> Ptr SUBNET_ELEMENT_DATA_V4- -> IO DWORD-foreign import stdcall "dynamic"- mkAddSubnetElementV4 :: FunPtr AddSubnetElementV4 -> AddSubnetElementV4---- VOID DHCP_API_FUNCTION DhcpRpcFreeMemory(--- PVOID BufferPointer--- );-type RpcFreeMemory = Ptr () -> IO ()-foreign import stdcall "dynamic"- mkRpcFreeMemory :: FunPtr RpcFreeMemory -> RpcFreeMemory---- | In an effort to avoid potential compile-time linker errors this package--- uses runtime dynamic linking. Internally a `DhcpApi` is a dictionary of--- dynamically bound foreign calls. Most actions require one to be passed.--- Simply call `loadDhcp` to obtain one.-data DhcpApi = DhcpApi- { c_DeleteClientInfo :: DeleteClientInfo- , c_EnumSubnetClientsV4 :: EnumSubnetClientsV4- , c_EnumSubnetElementsV4 :: EnumSubnetElementsV4- , c_GetClientInfoV4 :: GetClientInfoV4- , c_RemoveSubnetElementV4 :: RemoveSubnetElementV4- , c_AddSubnetElementV4 :: AddSubnetElementV4- , c_RpcFreeMemory :: RpcFreeMemory- }---- | Calling this function performs runtime dynamic linking for every internal--- foreign call into the Dhcp Server Management Api. It is safe to call this--- action multiple times. I recommend calling this function once as the part--- of a process's initialization, and then pass the returned `DhcpApi` to--- functions that need it.-loadDHCP :: IO DhcpApi-loadDHCP = do- lib <- loadLibrary "dhcpsapi"- deleteclient <- getProcAddress lib "DhcpDeleteClientInfo"- enumClients <- getProcAddress lib "DhcpEnumSubnetClientsV4"- enumElements <- getProcAddress lib "DhcpEnumSubnetElementsV4"- getclient <- getProcAddress lib "DhcpGetClientInfoV4"- remove <- getProcAddress lib "DhcpRemoveSubnetElementV4"- add <- getProcAddress lib "DhcpAddSubnetElementV4"- rpcfree <- getProcAddress lib "DhcpRpcFreeMemory"- return $ DhcpApi (mkDeleteClientInfo . castPtrToFunPtr $ deleteclient)- (mkEnumSubnetClientsV4 . castPtrToFunPtr $ enumClients)- (mkEnumSubnetElementsV4 . castPtrToFunPtr $ enumElements)- (mkGetClientInfoV4 . castPtrToFunPtr $ getclient)- (mkRemoveSubnetElementV4 . castPtrToFunPtr $ remove)- (mkAddSubnetElementV4 . castPtrToFunPtr $ add)- (mkRpcFreeMemory . castPtrToFunPtr $ rpcfree)---- |Free a block of memory created by DHCP's api.--- MSDN only mensions this function in DhcpEnumSubnetElementsV5. The original,--- v4, and v6 variants of the function don't say how memory should be freed.-rpcFreeMemory :: DhcpApi -> Ptr a -> IO ()-rpcFreeMemory api ptr = c_RpcFreeMemory api $ castPtr ptr
− System/Win32/DHCP/LengthBuffer.hs
@@ -1,63 +0,0 @@-{-# LANGUAGE RankNTypes #-}--module System.Win32.DHCP.LengthBuffer- ( LengthBuffer (..)- , lengthBuffer- ) where--import Control.Applicative-import Foreign.Ptr-import Foreign.Storable-import System.Win32.Types (DWORD)--import System.Win32.DHCP.DhcpStructure--import Utils---- |A LengthBuffer is a list of items which can be marshalled in and out--- of memory with a `DhcpArray` instance. A C structure that can be used--- with this looks something like the following:--- --- typedef struct Structure {--- DWORD NumElements;--- LPElementData Elements;--- } Structure, *LPStructure;-data LengthBuffer a = LengthBuffer- { lbLength :: !Int- , buffer :: [a]- }--lengthBuffer :: DhcpArray a -> DhcpStructure (LengthBuffer a)-lengthBuffer dict = DhcpStructure- { peekDhcp = peekLb dict- , freeDhcpChildren = freeLb dict- , withDhcp' = withLb' dict- , sizeDhcp = 8- }--peekLb :: DhcpArray a -> Ptr (LengthBuffer a) -> IO (LengthBuffer a)-peekLb dict ptr = do- len <- fromIntegral <$> peek (pNumElements ptr)- pElements <- peek $ ppElements ptr- LengthBuffer len <$> peekDhcpArray dict len pElements--freeLb :: DhcpArray a -> (forall x. Ptr x -> IO ())- -> Ptr (LengthBuffer a) -> IO ()-freeLb dict freefunc ptr = do- len <- fromIntegral <$> peek (pNumElements ptr)- -- A LengthBuffer contain a pointer to the buffer; not the start of the- -- buffer itself.- freeDhcpArray dict freefunc len `scrubbing_` ppElements ptr--withLb' :: DhcpArray a -> LengthBuffer a -> Ptr (LengthBuffer a) -> IO r -> IO r-withLb' dict (LengthBuffer _ elems) ptr f =- withDhcpArray dict elems $ \size pelems -> do- pokeByteOff ptr 0 (fromIntegral size :: DWORD)- poke (ppElements ptr) (castPtr pelems)- f--pNumElements :: Ptr (LengthBuffer a) -> Ptr DWORD-pNumElements ptr = castPtr ptr--ppElements :: Ptr (LengthBuffer a) -> Ptr (Ptr a)-ppElements ptr = castPtr ptr `plusPtr` 4
− System/Win32/DHCP/Reservation.hs
@@ -1,81 +0,0 @@-{-# LANGUAGE RankNTypes #-}--module System.Win32.DHCP.Reservation- ( Mapping (..)- , Reservation (..)- , reservation- ) where--import Control.Applicative-import Foreign--import Data.Ip-import Data.Mac-import System.Win32.DHCP.CLIENT_UID-import System.Win32.DHCP.DhcpStructure-import System.Win32.DHCP.Types (ClientType)-import Utils (scrubbing_)---- | A Reservation guarantees that a device with a given Mac address will--- always be assigned to a particular IP address. A reservation is not the--- same thing as a lease, and there are separate calls to work with both--- objects.------ This type corresponds to MSDN's DHCP_IP_RESERVATION_V4 structure.------ > typedef struct _DHCP_IP_RESERVATION_V4 {--- > DHCP_IP_ADDRESS ReservedIpAddress;--- > DHCP_CLIENT_UID *ReservedForClient;--- > BYTE bAllowedClientTypes;--- > } DHCP_IP_RESERVATION_V4, *LPDHCP_IP_RESERVATION_V4;-data Reservation = Reservation- { reservationMapping :: !Mapping- , reservationType :: !ClientType- } deriving (Eq)---- | A mapping between an IP and a MAC address. Each IP number may map to--- only one MAC address, and each MAC address may map to only one IP number.------ This is a separate type from `Reservation` for practical reasons. When--- writing software to work with a DHCP server, `Reservation`'s--- `ClientType` field is often not important. Without the `Mapping` type--- defined here it would often be necessary to define a custom type in--- each project.-data Mapping = Mapping- { mappingMac :: !Mac- , mappingIp :: !Ip- } deriving (Eq, Ord)--reservation :: DhcpStructure Reservation-reservation = DhcpStructure- { peekDhcp = peekReservation- , freeDhcpChildren = freeReservation- , withDhcp' = withReservation'- , sizeDhcp = 10- }--peekReservation :: Ptr Reservation -> IO Reservation-peekReservation ptr = do- pCuid <- peek $ ppCuid ptr- mac <- macCuidDrop5 <$> peekDhcp clientUid pCuid- addr <- peek pAddress- clientType <- peekByteOff (castPtr ptr) 8- return $ Reservation (Mapping mac addr) clientType- where- pAddress = castPtr ptr :: Ptr Ip--freeReservation :: (forall x. Ptr x -> IO ()) -> Ptr Reservation -> IO ()-freeReservation freefunc ptr = do- freeDhcp clientUid freefunc `scrubbing_` ppCuid ptr--ppCuid :: Ptr Reservation -> Ptr (Ptr CLIENT_UID)-ppCuid ptr = castPtr ptr `plusPtr` 4--withReservation' :: Reservation -> Ptr Reservation- -> IO r -> IO r-withReservation' (Reservation (Mapping mac address) clientType) ptr f =- withMac mac $ \pCuid -> do- poke (castPtr ptr) address- pokeByteOff (castPtr ptr) 4 pCuid- pokeByteOff (castPtr ptr) 8 clientType- f
− System/Win32/DHCP/SEARCH_INFO.hs
@@ -1,68 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--module System.Win32.DHCP.SEARCH_INFO- ( SEARCH_INFO_TYPE- , SEARCH_INFO (..)- , withSearchInfo- ) where--import Data.Monoid ((<>))-import qualified Data.Text as T-import Foreign-import Foreign.C.Types--import System.Win32.Types--import Data.Ip-import Data.Mac-import System.Win32.DHCP.CLIENT_UID---- typedef enum _DHCP_CLIENT_SEARCH_TYPE { --- DhcpClientIpAddress,--- DhcpClientHardwareAddress,--- DhcpClientName--- } DHCP_SEARCH_INFO_TYPE, *LPDHCP_SEARCH_INFO_TYPE;-type SEARCH_INFO_TYPE = CInt---- | Filter criteria used in actions that look up reservation or lease--- records.------ > typedef struct _DHCP_CLIENT_SEARCH_INFO {--- > DHCP_SEARCH_INFO_TYPE SearchType;--- > union {--- > DHCP_IP_ADDRESS ClientIpAddress;--- > DHCP_CLIENT_UID ClientHardwareAddress;--- > LPWSTR ClientName;--- > } SearchInfo;--- > } DHCP_SEARCH_INFO, *LPDHCP_SEARCH_INFO;-data SEARCH_INFO- -- | Search based on an IP address. All scopes are searched. It should- -- not be possible for multiple records to exist.- = ClientIpAddress !Ip- -- | Search based on a subnet and MAC address. This method of searching- -- has not been tested.- | ClientHardwareAddress !Mac- -- | Search based on a client's name. Multiple records may exist, and- -- what happens in that case will depend on the function being called.- -- This method of searching has not been tested.- | ClientName !String--instance Show SEARCH_INFO where- show (ClientIpAddress ip) = T.unpack $ "ClientIpAddress " <> showIp ip- show (ClientHardwareAddress mac) = T.unpack $ "ClientHardwareAddress " <> showMac ":" mac- show (ClientName name) = "ClientName " ++ name--siTypeOf :: SEARCH_INFO -> SEARCH_INFO_TYPE-siTypeOf (ClientIpAddress _) = 0-siTypeOf (ClientHardwareAddress _) = 1-siTypeOf (ClientName _) = 2---- Allocate 12 because a SEARCH_INFO.SearchInfo member's in-structure alignment is 4 with a size of 8.-withSearchInfo :: SEARCH_INFO -> (Ptr SEARCH_INFO -> IO r) -> IO r-withSearchInfo si f = allocaBytes 12 $ \ptr -> do- let pX = ptr `plusPtr` 4- poke (castPtr ptr) $ siTypeOf si- case si of- ClientIpAddress x -> poke (castPtr pX) x >> f ptr- ClientHardwareAddress m -> withMac m $ \pm -> copyBytes (castPtr pX) pm 8 >> f ptr- ClientName str -> withTString str $ \pstr -> copyBytes (castPtr pX) pstr 4 >> f ptr
− System/Win32/DHCP/SUBNET_CLIENT_INFO_ARRAY_V4.hs
@@ -1,22 +0,0 @@-module System.Win32.DHCP.SUBNET_CLIENT_INFO_ARRAY_V4 - ( SUBNET_CLIENT_INFO_ARRAY_V4 (..) - , clientInfoArray - ) where - -import System.Win32.DHCP.Client -import System.Win32.DHCP.DhcpStructure -import System.Win32.DHCP.LengthBuffer - --- typedef struct _DHCP_CLIENT_INFO_ARRAY_V4 { --- DWORD NumElements; --- LPDHCP_CLIENT_INFO_V4 *Clients; --- } DHCP_CLIENT_INFO_ARRAY_V4, *LPDHCP_CLIENT_INFO_ARRAY_V4; -newtype SUBNET_CLIENT_INFO_ARRAY_V4 - = SUBNET_CLIENT_INFO_ARRAY_V4 (LengthBuffer Client) - -unwrap :: SUBNET_CLIENT_INFO_ARRAY_V4 -> LengthBuffer Client -unwrap (SUBNET_CLIENT_INFO_ARRAY_V4 ia) = ia - -clientInfoArray :: DhcpStructure SUBNET_CLIENT_INFO_ARRAY_V4 -clientInfoArray = newtypeDhcpStructure SUBNET_CLIENT_INFO_ARRAY_V4 unwrap - $ lengthBuffer (ptrDhcpArray clientInfo)
− System/Win32/DHCP/SUBNET_ELEMENT_DATA_V4.hs
@@ -1,102 +0,0 @@-{-# LANGUAGE RankNTypes #-}--module System.Win32.DHCP.SUBNET_ELEMENT_DATA_V4- ( SUBNET_ELEMENT_DATA_V4 (..)- , SUBNET_ELEMENT_TYPE- , elementTypeOf- , subnetElementData- ) where--import Control.Applicative-import Foreign-import Foreign.C.Types--import System.Win32.DHCP.DhcpStructure-import System.Win32.DHCP.HOST_INFO-import System.Win32.DHCP.IP_CLUSTER-import System.Win32.DHCP.IP_RANGE-import System.Win32.DHCP.Reservation-import Utils---- typedef struct _DHCP_SUBNET_ELEMENT_DATA_V4 {--- DHCP_SUBNET_ELEMENT_TYPE ElementType;--- union {--- DHCP_IP_RANGE *IpRange;--- DHCP_HOST_INFO *SecondaryHost;--- DHCP_IP_RESERVATION_V4 *ReservedIp;--- DHCP_IP_RANGE *ExcludeIpRange;--- DHCP_IP_CLUSTER *IpUsedCluster;--- } Element;--- } DHCP_SUBNET_ELEMENT_DATA_V4, *LPDHCP_SUBNET_ELEMENT_DATA_V4;-data SUBNET_ELEMENT_DATA_V4- = IpRanges !IP_RANGE- | SecondaryHosts !HOST_INFO- | ReservedIps !Reservation- | ExcludedIpRanges !IP_RANGE- | IpUsedCluster !IP_CLUSTER---- typedef enum _DHCP_SUBNET_ELEMENT_TYPE_V5 {--- DhcpIpRanges,--- DhcpSecondaryHosts,--- DhcpReservedIps,--- DhcpExcludedIpRanges,--- DhcpIpRangesDhcpOnly,--- DhcpIpRangesDhcpBootp,--- DhcpIpRangesBootpOnly--- } DHCP_SUBNET_ELEMENT_TYPE, *LPDHCP_SUBNET_ELEMENT_TYPE;-type SUBNET_ELEMENT_TYPE = CInt--subnetElementData :: DhcpStructure SUBNET_ELEMENT_DATA_V4-subnetElementData = DhcpStructure- { peekDhcp = peekSubnetElementData- , freeDhcpChildren = freeSubnetElementData- , withDhcp' = withSubnetElementData'- , sizeDhcp = 8- }--peekSubnetElementData :: Ptr SUBNET_ELEMENT_DATA_V4 -> IO SUBNET_ELEMENT_DATA_V4-peekSubnetElementData ptr = do- elementType <- (peek . castPtr) ptr :: IO SUBNET_ELEMENT_TYPE- pElement <- peekByteOff ptr 4- case elementType of- 0 -> IpRanges <$> peek (castPtr pElement)- 1 -> SecondaryHosts <$> peekDhcp hostInfo (castPtr pElement)- 2 -> ReservedIps <$> peekDhcp reservation (castPtr pElement)- 3 -> ExcludedIpRanges <$> peek (castPtr pElement)- 4 -> IpUsedCluster <$> peek (castPtr pElement)- _ -> error "Invalid element type found in SUBNET_ELEMENT_DATA_V4."--freeSubnetElementData :: (forall x. Ptr x -> IO ())- -> Ptr SUBNET_ELEMENT_DATA_V4 -> IO ()-freeSubnetElementData freefunc ptr = do- elementType <- (peek . castPtr) ptr :: IO SUBNET_ELEMENT_TYPE- scrubWith_ (ppElement ptr) $ \pElement -> do- case elementType of- 0 -> return ()- 1 -> freeDhcp hostInfo freefunc $ castPtr pElement- 2 -> freeDhcp reservation freefunc $ castPtr pElement- 3 -> return ()- 4 -> return ()- _ -> error "Invalid element type found in SUBNET_ELEMENT_DATA_V4."---- Also used by withSubnetElementDataArray.-withSubnetElementData' :: SUBNET_ELEMENT_DATA_V4 -> Ptr SUBNET_ELEMENT_DATA_V4- -> IO r -> IO r-withSubnetElementData' elementData ptr f = do- castPtr ptr `poke` elementTypeOf elementData- case elementData of- IpRanges x -> with x $ \pX -> poke (ppElement ptr) pX >> f- SecondaryHosts x -> withDhcp hostInfo x $ \pX -> poke (ppElement ptr) pX >> f- ReservedIps x -> withDhcp reservation x $ \pX -> poke (ppElement ptr) pX >> f- ExcludedIpRanges x -> with x $ \pX -> poke (ppElement ptr) pX >> f- IpUsedCluster x -> with x $ \pX -> poke (ppElement ptr) pX >> f--ppElement :: Ptr SUBNET_ELEMENT_DATA_V4 -> Ptr a-ppElement ptr = castPtr $ ptr `plusPtr` 4--elementTypeOf :: SUBNET_ELEMENT_DATA_V4 -> SUBNET_ELEMENT_TYPE-elementTypeOf (IpRanges _) = 0-elementTypeOf (SecondaryHosts _) = 1-elementTypeOf (ReservedIps _) = 2-elementTypeOf (ExcludedIpRanges _) = 3-elementTypeOf (IpUsedCluster _) = 4
− System/Win32/DHCP/SUBNET_ELEMENT_INFO_ARRAY_V4.hs
@@ -1,22 +0,0 @@-module System.Win32.DHCP.SUBNET_ELEMENT_INFO_ARRAY_V4 - ( SUBNET_ELEMENT_INFO_ARRAY_V4 (..) - , infoArray - ) where - -import System.Win32.DHCP.DhcpStructure -import System.Win32.DHCP.LengthBuffer -import System.Win32.DHCP.SUBNET_ELEMENT_DATA_V4 - --- typedef struct _DHCP_SUBNET_ELEMENT_INFO_ARRAY_V4 { --- DWORD NumElements; --- LPDHCP_SUBNET_ELEMENT_DATA_V4 Elements; --- } DHCP_SUBNET_ELEMENT_INFO_ARRAY_V4, *LPDHCP_SUBNET_ELEMENT_INFO_ARRAY_V4; -newtype SUBNET_ELEMENT_INFO_ARRAY_V4 - = SUBNET_ELEMENT_INFO_ARRAY_V4 (LengthBuffer SUBNET_ELEMENT_DATA_V4) - -unwrap :: SUBNET_ELEMENT_INFO_ARRAY_V4 -> LengthBuffer SUBNET_ELEMENT_DATA_V4 -unwrap (SUBNET_ELEMENT_INFO_ARRAY_V4 ia) = ia - -infoArray :: DhcpStructure SUBNET_ELEMENT_INFO_ARRAY_V4 -infoArray = newtypeDhcpStructure SUBNET_ELEMENT_INFO_ARRAY_V4 unwrap - $ lengthBuffer (baseDhcpArray subnetElementData)
− System/Win32/DHCP/Types.hs
@@ -1,76 +0,0 @@-module System.Win32.DHCP.Types- ( ClientType (..)- , DATE_TIME (..)- , FORCE_FLAG (..)- , RESUME_HANDLE- ) where--import Control.Applicative-import Foreign--import System.Win32.Types---- | Microsoft's DHCP server supports DHCP and BOOTP. Both protocols server--- similar purposes, but DHCP is more widely used. Lease and reservation--- records contain a flag field indicating which protocol the record is valid--- for. In most cases this flag will be `Both`, because that is the default--- behavior.-data ClientType = Unspecified | Dhcp | Bootp | Both | ReservationFlag | None- deriving (Eq)--instance Enum ClientType where- toEnum 0x00 = Unspecified- toEnum 0x01 = Dhcp- toEnum 0x02 = Bootp- toEnum 0x03 = Both- toEnum 0x04 = ReservationFlag- toEnum 0x64 = None- toEnum x = error $ "invalid ClientType: " ++ show x- fromEnum Unspecified = 0x00- fromEnum Dhcp = 0x01- fromEnum Bootp = 0x02- fromEnum Both = 0x03- fromEnum ReservationFlag = 0x04- fromEnum None = 0x64--instance Storable ClientType where- sizeOf _ = sizeOf (undefined :: BYTE)- alignment _ = alignment (undefined :: BYTE)- peek ptr = toEnum . fromIntegral <$> peek (pbyte ptr)- poke ptr ct = poke (pbyte ptr) . fromIntegral . fromEnum $ ct--pbyte :: Ptr ClientType -> Ptr BYTE-pbyte = castPtr---- | The number of ticks (100-nanosecond increments) since 12:00 midnight,--- January 1, 1 C.E. in the Gregorian calendar.------ Microsoft does not provide any functions I know of for converting this--- value into something more convenient to work with.------ > typedef struct _DATE_TIME {--- > DWORD dwLowDateTime;--- > DWORD dwHighDateTime;--- > } DATE_TIME,*PDATE_TIME, *LPDATE_TIME;-data DATE_TIME = DATE_TIME !DWORD !DWORD--instance Storable DATE_TIME where- sizeOf _ = 8- alignment _ = 4- peek ptr = DATE_TIME <$> peekElemOff (pdword ptr) 0- <*> peekElemOff (pdword ptr) 1- poke ptr (DATE_TIME l h) = do- pokeElemOff (pdword ptr) 0 l- pokeElemOff (pdword ptr) 1 h--pdword :: Ptr DATE_TIME -> Ptr DWORD-pdword ptr = castPtr ptr---- typedef enum _DHCP_FORCE_FLAG {--- DhcpFullForce,--- DhcpNoForce--- } DHCP_FORCE_FLAG, *LPDHCP_FORCE_FLAG;-data FORCE_FLAG = FullForce | NoForce- deriving (Enum)--type RESUME_HANDLE = DWORD
− Utils.hs
@@ -1,51 +0,0 @@-module Utils where--import Control.Applicative-import Foreign--import System.Win32.Types---- | Perform an action over a double pointer, and then zero it out. If the--- double pointer is already zeroed out, do nothing and return 'Nothing'.-scrubbing :: (Ptr a -> IO b) -> Ptr (Ptr a) -> IO (Maybe b)-scrubbing f pptr = do- ptr <- peek pptr- if ptr == nullPtr- then return Nothing- else do- ret <- f ptr- poke pptr nullPtr- return $ Just ret---- |Perform a cleanup operation on memory.-scrubbing_ :: (Ptr a -> IO ()) -> Ptr (Ptr a) -> IO ()-scrubbing_ f pptr = do- _ <- scrubbing f pptr- return ()--scrubWith :: Ptr (Ptr a) -> (Ptr a -> IO b) -> IO (Maybe b)-scrubWith = flip scrubbing--scrubWith_ :: Ptr (Ptr a) -> (Ptr a -> IO ()) -> IO ()-scrubWith_ pptr f = do- _ <-scrubWith pptr f- return ()---- |Peek a string that might be null. Null pointers become Nothing-peekMaybeTString :: LPTSTR -> IO (Maybe String)-peekMaybeTString ptr- | ptr == nullPtr = return Nothing- | otherwise = Just <$> peekTString ptr---- |Temporarily marshal a Maybe String. A nothing becomes a null pointer.-withMaybeTString :: Maybe String -> (LPTSTR -> IO a) -> IO a-withMaybeTString Nothing f = f nullPtr-withMaybeTString (Just str) f = withTString str f--note :: e -> Maybe a -> Either e a-note e Nothing = Left e-note _ (Just x) = Right x--fmapL :: (a -> b) -> Either a r -> Either b r-fmapL f (Left x) = Left (f x)-fmapL _ (Right x) = (Right x)
Win32-dhcp-server.cabal view
@@ -1,6 +1,6 @@ Name: Win32-dhcp-server Synopsis: Win32 DHCP Server Management API-Version: 0.3+Version: 0.3.1 License: BSD3 License-file: LICENSE Author: Michael Steele@@ -17,7 +17,8 @@ This package provides a partial binding to the Win32 DHCP Server Management API. Its purpose is to query and control a Microsoft DHCP server. Enough functionality is defined so so that Ipv4 client lease and reservation- records can be manipulated programmatically.+ records can be manipulated programmatically._Only 32-bit versions of GHC are+ supported at this time._ . Here are a few notes on the required environment: .@@ -58,22 +59,24 @@ , Win32 >= 2.2 && < 2.4 , Win32-errors >= 0.2 && < 0.3 default-language: Haskell2010+ hs-source-dirs: src Exposed-modules: Data.Ip , Data.Mac , System.Win32.DHCP Ghc-Options: -funbox-strict-fields -Wall- other-modules: Utils- , System.Win32.DHCP.Internal- , System.Win32.DHCP.Client- , System.Win32.DHCP.CLIENT_UID- , System.Win32.DHCP.DhcpStructure- , System.Win32.DHCP.HOST_INFO- , System.Win32.DHCP.IP_CLUSTER- , System.Win32.DHCP.IP_RANGE- , System.Win32.DHCP.LengthBuffer- , System.Win32.DHCP.SEARCH_INFO- , System.Win32.DHCP.Reservation- , System.Win32.DHCP.SUBNET_CLIENT_INFO_ARRAY_V4- , System.Win32.DHCP.SUBNET_ELEMENT_DATA_V4- , System.Win32.DHCP.SUBNET_ELEMENT_INFO_ARRAY_V4- , System.Win32.DHCP.Types+ other-modules:+ Import+ , System.Win32.DHCP.Internal+ , System.Win32.DHCP.Client+ , System.Win32.DHCP.CLIENT_UID+ , System.Win32.DHCP.DhcpStructure+ , System.Win32.DHCP.HOST_INFO+ , System.Win32.DHCP.IP_CLUSTER+ , System.Win32.DHCP.IP_RANGE+ , System.Win32.DHCP.LengthBuffer+ , System.Win32.DHCP.SEARCH_INFO+ , System.Win32.DHCP.Reservation+ , System.Win32.DHCP.SUBNET_CLIENT_INFO_ARRAY_V4+ , System.Win32.DHCP.SUBNET_ELEMENT_DATA_V4+ , System.Win32.DHCP.SUBNET_ELEMENT_INFO_ARRAY_V4+ , System.Win32.DHCP.Types
+ src/Data/Ip.hs view
@@ -0,0 +1,79 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverloadedStrings #-}++-- | This module was taken, with modifications, from the+-- <http://hackage.haskell.org/package/maccatcher maccatcher> package.+module Data.Ip+ ( Ip ()+ -- * String conversions+ , readIp+ , showIp+ -- * Octet conversions+ , fromOctets+ , toOctets+ -- * Other conversions+ , toWord32+ ) where++import Control.Monad (unless)+import Data.Bits+import Data.Text (Text)+import qualified Data.Text as T+import Data.Text.Read+import Data.Word++import Import++-- |An Ip can be used as an IP address or subnet address.+--+-- A `Show` instance is omitted to avoid confusion. Use `showIp` and `readIp`+-- to convert between `String`s.+newtype Ip = Ip {unIp :: Word32}+ deriving (Eq, Ord, Bounded, Storable)++-- |Represent an `Ip` as a `String`.+--+-- >>> showIp $ fromOctets 192 168 1 100+-- "192.168.1.100"+showIp :: Ip -> Text+showIp ip = T.intercalate "." . map (T.pack . show) $ [a, b, c, d]+ where (a, b, c, d) = toOctets ip++-- |Parse a `Text` value as an `Ip`. The string should be of the form+-- "X.X.X.X" where each 'X' is a decimal value between 0 and 255 inclusive.+--+-- >>> let Right ip = readIp "192.168.1.100"+-- >>> toOctets ip+-- (192, 168, 1, 100)+readIp :: Text -> Either String Ip+readIp s = fmapL (\e -> "Error parsing IP address: " ++ e) $ do+ (a, s2) <- decimal s+ (b, s3) <- dot s2 >>= decimal+ (c, s4) <- dot s3 >>= decimal+ (d, s5) <- dot s4 >>= decimal+ unless (s5 == "") $ Left "exactly 4 octets were expected."+ -- Confirm that all digits are in range+ fromOctets <$> digit a <*> digit b <*> digit c <*> digit d+ where+ dot = note "Expected '.' character." . T.stripPrefix "."+ digit :: Int -> Either String Word8+ digit x | x < 0 || x > 255 = Left "digit out of range."+ | otherwise = Right $ fromIntegral x++-- |An IP address is 32-bits wide. This function will construct an `Ip` from+-- 4 octets.+fromOctets :: Word8 -> Word8 -> Word8 -> Word8 -> Ip+fromOctets a b c d = Ip+ $ (fromIntegral a `shiftL` 24)+ .|. (fromIntegral b `shiftL` 16)+ .|. (fromIntegral c `shiftL` 8)+ .|. (fromIntegral d)++-- |Extract each of the 4 octets from an `Ip`.+toOctets :: Ip -> (Word8, Word8, Word8, Word8)+toOctets (Ip word) = (byte 3 word, byte 2 word, byte 1 word, byte 0 word)+ where+ byte i w = fromIntegral (w `shiftR` (i * 8))++toWord32 :: Ip -> Word32+toWord32 = unIp
+ src/Data/Mac.hs view
@@ -0,0 +1,118 @@+{-# LANGUAGE OverloadedStrings #-}++-- | This module was taken, with modifications, from the+-- <http://hackage.haskell.org/package/maccatcher maccatcher> package.+module Data.Mac+ ( Mac ()+ -- ** String conversions+ , readMac+ , showMac+ -- ** Octet conversions+ , fromOctets+ , toOctets+ -- ** Other conversions+ , toWord64+ ) where++import Control.Monad (unless)+import Data.Bits+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.Lazy as L+import qualified Data.Text.Lazy.Builder as L+import qualified Data.Text.Lazy.Builder.Int as L+import Data.Text.Read+import Data.Word++import Import++-- |A Mac is a 6-byte unique identifier used in layer-two network addressing.+-- Its `Storable` instance occupies 6 bytes of memory when `poke`d with the+-- first byte occupying the lowest address, and the last byte occupying the+-- highest address.+--+-- A `Show` instance is omitted to avoid confusion. Use `showMac` and+-- `readMac` to convert between `String`s.+newtype Mac = Mac { unMac :: Word64 }+ deriving (Bounded, Eq, Ord)++instance Storable Mac where+ sizeOf _ = 6+ alignment _ = 1+ peek p = fromOctets <$> (peek $ castPtr p) <*> peekByteOff p 1+ <*> peekByteOff p 2 <*> peekByteOff p 3 <*> peekByteOff p 4+ <*> peekByteOff p 5+ poke p mac = do+ poke (castPtr p) a+ pokeByteOff p 1 b+ pokeByteOff p 2 c+ pokeByteOff p 3 d+ pokeByteOff p 4 e+ pokeByteOff p 5 f+ where+ (a, b, c, d, e, f) = toOctets mac++toWord64 :: Mac -> Word64+toWord64 = unMac++-- |Represent a `Mac` as a `String`. The supplied separator will be placed+-- between each octet in the final output.+--+-- >>> showMac "" $ fromOctets 0xa 0xb 0xc 0xd 0xe 0xf+-- "0a0b0c0d0e0f"+--+-- >>> showMac ":" $ fromOctets 0x11 0x22 0x33 0x44 0x55 0x66+-- "11:22:33:44:55:66"+showMac :: Text -> Mac -> Text+showMac sep mac = T.intercalate sep . map octet $ [a, b, c, d, e, f]+ where+ octet x = pad (2 :: Int) . L.toStrict . L.toLazyText . L.hexadecimal $ x+ (a, b, c, d, e, f) = toOctets mac+ pad n str = T.replicate (max 0 (n - T.length str)) "0" <> str++-- |Parse a `Text` value as a `Mac`. The string should not use any+-- separators between octets.+--+-- >>> let Right mac = readMac "000102030405"+-- >>> toOctets mac+-- (0, 1, 2, 3, 4, 5)+readMac :: Text -> Either String Mac+readMac s = fmapL (\e -> "Error parsing MAC address: " ++ e) $ do+ (a, s2) <- octet s+ (b, s3) <- octet s2+ (c, s4) <- octet s3+ (d, s5) <- octet s4+ (e, s6) <- octet s5+ (f, s7) <- octet s6+ unless (s7 == "") $ Left "exactly 6 octets were expected."+ fromOctets <$> digit a <*> digit b <*> digit c+ <*> digit d <*> digit e <*> digit f+ where+ octet :: Text -> Either String (Int, Text)+ octet s0 = do+ (a, s2) <- hexadecimal a0+ unless (s2 == "") $ Left "invalid characters"+ return (a, rest)+ where+ (a0, rest) = T.splitAt 2 s0+ digit :: Int -> Either String Word8+ digit x | x < 0 || x > 255 = Left "digit out of range."+ | otherwise = Right $ fromIntegral x++-- |A Mac address is 48-bits wide. This function will construct a `Mac` from+-- 6 octets.+fromOctets :: Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Mac+fromOctets a b c d e f = Mac+ $ (fromIntegral a `shiftL` 40)+ .|. (fromIntegral b `shiftL` 32)+ .|. (fromIntegral c `shiftL` 24)+ .|. (fromIntegral d `shiftL` 16)+ .|. (fromIntegral e `shiftL` 8)+ .|. (fromIntegral f)++-- |Extract each of the 6 octets from a `Mac`.+toOctets :: Mac -> (Word8, Word8, Word8, Word8, Word8, Word8)+toOctets (Mac word) = ( byte 5 word, byte 4 word, byte 3 word+ , byte 2 word, byte 1 word, byte 0 word)+ where+ byte i w = fromIntegral (w `shiftR` (i * 8))
+ src/Import.hs view
@@ -0,0 +1,98 @@+{-# LANGUAGE CPP #-} + +module Import + ( module X + -- * Utilities borrowed from 'errors' + , hush + , note + , fmapL + -- * Text-based string marshallers + , withTString + , withTStringLen + , withMaybeTString + , peekMaybeTString + -- * memory cleanup + , scrubbing + , scrubbing_ + , scrubWith_ + , scrubWith + ) where + +#if MIN_VERSION_base(4,8,0) +#else +import Control.Applicative as X +#endif +import Data.Char (chr) +import Data.Monoid as X +import Foreign as X +import Foreign.C.Types as X + +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Foreign as T +import System.Win32.Error as X +import System.Win32.Error.Foreign as X +import System.Win32.Types as X + hiding ( ErrCode, failIfNull, failWith, failUnlessSuccess + , failIfFalse_, failIf, errorWin, withTString, withTStringLen) +import qualified System.Win32.Types as W32 + + +-- |Peek a string that might be null. Null pointers become Nothing +peekMaybeTString :: LPTSTR -> IO (Maybe String) +peekMaybeTString ptr + | ptr == nullPtr = return Nothing + | otherwise = Just <$> peekTString ptr + +-- |Temporarily marshal a Maybe String. A nothing becomes a null pointer. +withMaybeTString :: Maybe String -> (LPTSTR -> IO a) -> IO a +withMaybeTString Nothing f = f nullPtr +withMaybeTString (Just str) f = W32.withTString str f + +withTStringLen :: Text -> (LPTSTR -> T.I16 -> IO a) -> IO a +withTStringLen text act = T.useAsPtr (T.snoc text (chr 0x0)) $ \ptr len -> + act (castPtr ptr) len + +withTString :: Text -> (LPTSTR -> IO a) -> IO a +withTString text act = withTStringLen text $ \ptr _ -> act ptr + +-- | Suppress the 'Left' value of an 'Either' +-- taken from the errors package +hush :: Either a b -> Maybe b +hush = either (const Nothing) Just + +-- taken from the errors package +note :: e -> Maybe a -> Either e a +note e Nothing = Left e +note _ (Just x) = Right x + +-- taken from the errors package +fmapL :: (a -> b) -> Either a r -> Either b r +fmapL f (Left x) = Left (f x) +fmapL _ (Right x) = (Right x) + +-- | Perform an action over a double pointer, and then zero it out. If the +-- double pointer is already zeroed out, do nothing and return 'Nothing'. +scrubbing :: (Ptr a -> IO b) -> Ptr (Ptr a) -> IO (Maybe b) +scrubbing f pptr = do + ptr <- peek pptr + if ptr == nullPtr + then return Nothing + else do + ret <- f ptr + poke pptr nullPtr + return $ Just ret + +-- |Perform a cleanup operation on memory. +scrubbing_ :: (Ptr a -> IO ()) -> Ptr (Ptr a) -> IO () +scrubbing_ f pptr = do + _ <- scrubbing f pptr + return () + +scrubWith :: Ptr (Ptr a) -> (Ptr a -> IO b) -> IO (Maybe b) +scrubWith = flip scrubbing + +scrubWith_ :: Ptr (Ptr a) -> (Ptr a -> IO ()) -> IO () +scrubWith_ pptr f = do + _ <-scrubWith pptr f + return ()
+ src/System/Win32/DHCP.hs view
@@ -0,0 +1,342 @@+{-# LANGUAGE OverloadedStrings #-}++-- |+-- module: System.Win32.DHCP+-- copyright: (c) Michael Steele, 2014+-- license: BSD3+-- maintainer: mikesteele81@gmail.com+-- stability: experimental+-- portability: Windows+module System.Win32.DHCP+ ( DhcpApi ()+ , loadDHCP+ -- * General Types+ , Context (..)+ , ClientType (..)+ , DATE_TIME (..)+ , HOST_INFO (..)+ , SEARCH_INFO (..)+ -- * Leases+ , Client (..)+ , enumClients+ , lookupClient+ , deleteClient+ -- * Reservations+ , Mapping (..)+ , Reservation(..)+ , addReservation+ , enumReservations+ , removeReservation+ ) where++import Control.Monad (unless)+import Data.Maybe (fromMaybe)+import Data.Text (Text)++import Import+import Data.Ip+import System.Win32.DHCP.DhcpStructure+import System.Win32.DHCP.HOST_INFO+import System.Win32.DHCP.Internal+import System.Win32.DHCP.Client+import System.Win32.DHCP.LengthBuffer+import System.Win32.DHCP.Reservation+import System.Win32.DHCP.SEARCH_INFO+import System.Win32.DHCP.SUBNET_CLIENT_INFO_ARRAY_V4+import System.Win32.DHCP.SUBNET_ELEMENT_DATA_V4+import System.Win32.DHCP.SUBNET_ELEMENT_INFO_ARRAY_V4+import System.Win32.DHCP.Types++-- | A Context defines which server and scope within that server a command+-- refers to. Microsoft's DHCP server supports multiple scopes. This allows+-- different configurations to be sent to devices based on their hardware+-- (MAC) address. Scopes are identified by their network address.+data Context = Context+ { -- | The DHCP server management API uses an RPC mechanism to control the+ -- server.+ contextServer :: !Text+ , -- | Scopes are identified by a subnet identifier. This is useful in+ -- cases where multiple scopes are defined, but still required in the+ -- common case of a single scope.+ contextSubnet :: !Ip+ } deriving (Eq, Ord)++-- | Delete an active DHCP lease from the server.+-- The `SEARCH_INFO` argument determines which search criteria+-- to use. Searching by name will delete all active leases+-- with that name. This action corresponds to MSDN's DhcpDeleteClientInfoV4+-- function.+deleteClient :: DhcpApi+ -> Text+ -- ^ String which specifies the IP address or hostname of the DHCP+ -- server.+ -> SEARCH_INFO+ -- ^ Define how to lookup a client to delete. Only deleting based on+ -- IP addresses have been tested.+ -> IO ()+ -- ^ This function will throw an 'Win32Exception' when the internal Win32+ -- call returnes an error condition. MSDN lists the following exceptions,+ -- but others might be thrown as well:+ --+ -- ['DhcpReservedClient'] The specified DHCP client is a reserved DHCP+ -- client.+ --+ -- ['DhcpJetError'] An error occurred while accessing the DHCP server+ -- database, or the client entry is not present in the database.+deleteClient api server si =+ withTString server $ \pserver ->+ withSearchInfo si $ \psi ->+ failUnlessSuccess "DeleteClientInfo"+ $ c_DeleteClientInfo api pserver psi++-- | Perform a lookup operation for all client lease records within a+-- scope. This action corresponds to MSDN's DhcpEnumSubnetClientsV4 function.+enumClients :: DhcpApi+ -> Context+ -- ^ Specify which server and scope to search for client leases.+ -> IO [Client]+ -- ^ The empty list means that no client records exist for the provided+ -- subnet. This function will throw an 'Win32Exception' when the+ -- internal Win32 call returnes an error condition. MSDN lists the+ -- following exceptions, but others might be thrown as well:+ --+ -- ['DhcpJetError'] An error occurred while accessing the DHCP server+ -- database.+enumClients dhcp (Context server subnet) =+ enumSubnetClientsV4 dhcp server subnet++-- | Search the DHCP server for a lease matching the given search criteria.+-- `Nothing` is returned when no lease was found. This corresponds to MSDN's+-- DhcpGetClientInfoV4 function.+lookupClient :: DhcpApi+ -> Text+ -- ^ According to MSDN this must specify the IP address of the server.+ -- Other functions (including this one) may or may not also accept+ -- a Unicode host name.+ -> SEARCH_INFO+ -- ^ Define how to lookup a client. Only searching based on an+ -- IP addresses has been tested.+ -> IO (Maybe Client)+ -- ^ A 'Nothing' indicates that no client was found. This function will+ -- throw an 'Win32Exception' when the internal Win32 call returnes an+ -- error condition. MSDN lists the following exceptions, but others might+ -- be thrown as well:+ --+ -- ['DhcpJetError'] An error occurred while accessing the DHCP server+ -- database.+lookupClient api serverip si =+ withTString serverip $ \pserverip ->+ withSearchInfo si $ \psi ->+ with nullPtr $ \ppclientinfo -> do+ -- DhcpGetClientInfo takes a structure on the stack.+ siType <- peek (castPtr psi :: Ptr CInt)+ siPayload <- peekElemOff (castPtr psi :: Ptr (Ptr ())) 4+ failUnlessSuccess "GetClientInfoV4"+ $ c_GetClientInfoV4 api pserverip siType siPayload ppclientinfo++ -- Extract client information from out parameter and free the memory+ -- 'Nothing' will be returned the case where GetClientInfoV4 returns a+ -- null pointer.+ scrubWith ppclientinfo $ \pclientinfo -> do+ clientinfo <- peekDhcp clientInfo pclientinfo+ freeDhcp clientInfo (rpcFreeMemory api) pclientinfo+ return clientinfo++addReservation :: DhcpApi -> Context -> Mapping+ -> IO ()+ -- ^ This function will throw an 'Win32Exception' when the internal Win32+ -- call returnes an error condition. MSDN lists the following exceptions,+ -- but others might be thrown as well:+ --+ -- ['DhcpSubnetNotPresent'] The specified IPv4 subnet does not exist+ -- on the DHCP server.+ --+ -- ['DhcpJetError'] An error occurred while accessing the DHCP server+ -- database.+ --+ -- ['DhcpNotReservedClient'] The specified DHCP client is not a+ -- reserved client.+ --+ -- ['DhcpInvalidRange'] The specified IPv4 range does not match an+ -- existing IPv4 range.+ --+ -- ['ScopeRangePolicyChangeConflict'] An IP address range is+ -- configured for a policy in this scope. This operation cannot be+ -- performed on the scope IP address range until the policy IP address+ -- range is suitably modified.+addReservation dhcp (Context server subnet) mapping =+ addSubnetElementV4 dhcp server subnet+ $ ReservedIps (Reservation mapping Both)++enumReservations :: DhcpApi -> Context -> IO [Reservation]+enumReservations dhcp (Context server subnet) = do+ ex <- enumSubnetElementsV4 dhcp server subnet 2+ res <- flip mapM ex $ \element -> do+ case element of+ ReservedIps res -> return res+ _ -> error "bug in Win32 API."+ return res++-- | Remove a reservation from the server+removeReservation :: DhcpApi -> Context -> Mapping+ -> ClientType+ -- ^ Specify a DHCP reservation, BOOTP reservation, or both. This is+ -- untested.+ -> Bool+ -- ^ Specify whether any active leases for the reservation should be+ -- removed as well.+ -> IO ()+ -- ^ This function will throw an 'Win32Exception' when the internal Win32+ -- call returnes an error condition. MSDN lists the following exceptions,+ -- but others might be thrown as well:+ --+ -- ['DhcpSubnetNotPresent'] The specified IPv4 subnet does not exist+ -- on the DHCP server.+ --+ -- ['DhcpElementCantRemove'] Failure can occur for any number of+ -- reasons.+ --+ -- ['DhcpJetError'] An error occurred while accessing the DHCP server+ -- database.+ --+ -- ['DhcpInvalidRange'] The specified IPv4 range does not match an+ -- existing IPv4 range.+ --+ -- ['ScopeRangePolicyChangeConflict'] An IP address range is+ -- configured for a policy in this scope. This operation cannot be+ -- performed on the scope IP address range until the policy IP address+ -- range is suitably modified.+removeReservation dhcp (Context server subnet) mapping ct force =+ removeSubnetElementV4 dhcp server subnet+ (ReservedIps $ Reservation mapping ct) fForce+ where+ fForce = if force then FullForce else NoForce++enumSubnetClientsV4 :: DhcpApi -> Text -> Ip -> IO [Client]+enumSubnetClientsV4 dhcp server subnet =+ withTString server $ \pServer ->+ -- inout parameter. Supply on successive calls to retreive more elements+ with 0 $ \pResumeHandle ->+ alloca $ \pElementsRead ->+ alloca $ \pElementsTotal ->+ with nullPtr $ \ppInfoArray -> do+ -- We have to call enumSubnetElementsV4 at least twice for a sucessfull+ -- run. Failure to use the returned resumeHandle may result in an+ -- internal access violation within RPCRT4.dll.+ let loop acc = do+ ret <- fromDWORD <$> c_EnumSubnetClientsV4 dhcp pServer (toWord32 subnet)+ pResumeHandle 0xFFFFFFFF ppInfoArray+ pElementsRead pElementsTotal+ unless (elem ret [Success, MoreData, NoMoreItems])+ $ failWith "EnumSubnetClientsV4" ret++ melems <- scrubWith ppInfoArray $ \pInfoArray -> do+ SUBNET_CLIENT_INFO_ARRAY_V4 (LengthBuffer _ elems) <- peekDhcp clientInfoArray pInfoArray+ freeDhcp clientInfoArray (rpcFreeMemory dhcp) pInfoArray+ return elems+ let elems = fromMaybe [] melems++ if (ret == NoMoreItems || ret == Success)+ then return (elems:acc)+ else loop (elems:acc)++ revelemss <- loop []+ return $ concat $ reverse revelemss++enumSubnetElementsV4 :: DhcpApi -> Text -> Ip -> CInt+ -> IO [SUBNET_ELEMENT_DATA_V4]+enumSubnetElementsV4 dhcp server subnet elementType =+ withTString server $ \pServer ->+ -- inout parameter. Supply on successive calls to retreive more elements+ with 0 $ \pResumeHandle ->+ alloca $ \pElementsRead ->+ alloca $ \pElementsTotal ->+ with nullPtr $ \ppInfoArray -> do+ -- We have to call enumSubnetElementsV4 at least twice for a sucessfull+ -- run. Failure to use the returned resumeHandle may result in an+ -- internal access violation within RPCRT4.dll.+ let loop acc = do+ ret <- fromDWORD <$> c_EnumSubnetElementsV4 dhcp pServer (toWord32 subnet) elementType+ pResumeHandle 0xFFFFFFFF ppInfoArray+ pElementsRead pElementsTotal+ unless (elem ret [Success, MoreData, NoMoreItems])+ $ failWith "EnumSubnetElementsV4" ret++ melems <- scrubWith ppInfoArray $ \pInfoArray -> do+ SUBNET_ELEMENT_INFO_ARRAY_V4 (LengthBuffer _ elems) <- peekDhcp infoArray pInfoArray+ freeDhcp infoArray (rpcFreeMemory dhcp) pInfoArray+ return elems+ let elems = fromMaybe [] melems++ -- Intentionally ignore elementsTotal. Microsoft's documentation+ -- on how this should work doesn't seem right. In my testing+ -- elementsTotal always returns 0x7fffffff until the last loop, at+ -- which time it always matches elementsRead.+ if (ret == NoMoreItems || ret == Success)+ then return (elems:acc)+ else loop (elems:acc)++ revelemss <- loop []+ return $ concat $ reverse revelemss++addSubnetElementV4 :: DhcpApi -> Text -> Ip -> SUBNET_ELEMENT_DATA_V4 -> IO ()+addSubnetElementV4 dhcp server subnet elementData =+ withTString server $ \pServer ->+ withDhcp subnetElementData elementData $ \pElementData ->+ failUnlessSuccess "AddSubnetElementsV4"+ $ c_AddSubnetElementV4 dhcp pServer (toWord32 subnet) pElementData++-- | Remove an IPv4 subnet element from an IPv4 subnet defined on the DHCPv4+-- server.+removeSubnetElementV4+ :: DhcpApi+ -> Text -- ^ Unicode string that specifies the IP address, such as+ -- \"123.456.789.012\", or hostname, such as \"server\",+ -- of the DHCP server.+ -> Ip -- ^ 'DWORD' value that specifies the IP address of the+ -- subnet gateway and uniquely identifies it. As an+ -- example, with the above IP address and a subnet mask+ -- of 255.255.255.0, the subnet would be 123.456.789.0.+ -- This must then be converted to a 'DWORD' value of+ -- 2,093,683,968.+ -> SUBNET_ELEMENT_DATA_V4 -- ^ 'DHCP_SUBNET_ELEMENT_DATA_V4' structure+ -- that contains information used to find the+ -- element that will be removed from subnet+ -- specified in SubnetAddress.+ -> FORCE_FLAG -- ^ DHCP_FORCE_FLAG enumeration value that indicates+ -- whether or not the clients affected by the removal of+ -- the subnet element should also be deleted.+ --+ -- Note If the flag is set to DhcpNoForce and this subnet+ -- has served an IPv4 address to DHCPv4/BOOTP clients, the+ -- IPv4 range is not deleted; conversely, if the flag is+ -- set to DhcpFullForce, the IPv4 range is deleted along+ -- with the DHCPv4 client lease record on the DHCPv4+ -- server.+ -> IO ()+ -- ^ This function will throw an 'Win32Exception' when the internal Win32+ -- call returnes an error condition. MSDN lists the following exceptions,+ -- but others might be thrown as well:+ --+ -- ['DhcpSubnetNotPresent'] The specified IPv4 subnet does not exist+ -- on the DHCP server.+ --+ -- ['DhcpElementCantRemove'] Failure can occur for any number of+ -- reasons.+ --+ -- ['DhcpJetError'] An error occurred while accessing the DHCP server+ -- database.+ --+ -- ['DhcpInvalidRange'] The specified IPv4 range does not match an+ -- existing IPv4 range.+ --+ -- ['ScopeRangePolicyChangeConflict'] An IP address range is+ -- configured for a policy in this scope. This operation cannot be+ -- performed on the scope IP address range until the policy IP address+ -- range is suitably modified.+removeSubnetElementV4 dhcp server subnet elementData forceFlag =+ withTString server $ \pServer ->+ withDhcp subnetElementData elementData $ \pElementData ->+ failUnlessSuccess "RemoveSubnetElementV4"+ $ c_RemoveSubnetElementV4 dhcp pServer (toWord32 subnet) pElementData+ (fromIntegral . fromEnum $ forceFlag)
+ src/System/Win32/DHCP/CLIENT_UID.hs view
@@ -0,0 +1,56 @@+module System.Win32.DHCP.CLIENT_UID+ ( CLIENT_UID (..)+ , clientUid+ , macCuid+ , macCuidDrop5+ , withMac+ ) where++import Foreign+import System.Win32.Types++import Data.Mac+import System.Win32.DHCP.DhcpStructure+import System.Win32.DHCP.LengthBuffer++-- typedef struct _DHCP_BINARY_DATA {+-- DWORD DataLength;+-- BYTE *Data;+-- } DHCP_BINARY_DATA, *LPDHCP_BINARY_DATA, DHCP_CLIENT_UID;++-- Byte 0 - 3: The result of a binary AND on the IP address and the subnet+-- mask in reverse order.+-- Byte 4: Hardware identifier. This value is always 0x01.+-- Byte 5 - 10: The Mac address of the client.+newtype CLIENT_UID = CLIENT_UID (LengthBuffer BYTE)++unwrap :: CLIENT_UID -> LengthBuffer BYTE+unwrap (CLIENT_UID uid) = uid++clientUid :: DhcpStructure CLIENT_UID+clientUid = newtypeDhcpStructure CLIENT_UID unwrap+ $ lengthBuffer (basicDhcpArray storableDhcpStructure)++-- Functions returning a CLIENT_UID often have the first 5 bytes hold+-- information about the subnet being used.+macCuidDrop5 :: CLIENT_UID -> Mac+macCuidDrop5 (CLIENT_UID (LengthBuffer _ bytes)) = fromOctets a b c d e f+ where+ [a, b, c, d, e, f] = drop 5 bytes++macCuid :: CLIENT_UID -> Mac+macCuid (CLIENT_UID (LengthBuffer _ bytes)) = fromOctets a b c d e f+ where+ [a, b, c, d, e, f] = bytes++fromMac :: Mac -> CLIENT_UID+fromMac mac = CLIENT_UID (LengthBuffer 6 [a, b, c, d, e, f])+ where+ (a, b, c, d, e, f) = toOctets mac++-- |When creating CLIENT_UID structures in memory we only need 6 bytes+-- representing the Mac address. This is contrary to MSDN documentation, which+-- states that there should be 11 bytes, with the first 5 being constructed+-- from the IP and subnet.+withMac :: Mac -> (Ptr CLIENT_UID -> IO b) -> IO b+withMac mac f = withDhcp clientUid (fromMac mac) f
+ src/System/Win32/DHCP/Client.hs view
@@ -0,0 +1,117 @@+{-# LANGUAGE RankNTypes #-}++module System.Win32.DHCP.Client+ ( Client (..)+ , clientInfo+ ) where++import Data.Ip+import Data.Mac+import Import+import System.Win32.DHCP.CLIENT_UID+import System.Win32.DHCP.DhcpStructure+import System.Win32.DHCP.HOST_INFO+import System.Win32.DHCP.Types++-- | Information about an active lease. This type corresponds to+-- MSDN's DHCP_CLIENT_INFO_V4 structure.+--+-- > typedef struct _DHCP_CLIENT_INFO_V4 {+-- > DHCP_IP_ADDRESS ClientIpAddress;+-- > DHCP_IP_MASK SubnetMask;+-- > DHCP_CLIENT_UID ClientHardwareAddress;+-- > LPWSTR ClientName;+-- > LPWSTR ClientComment;+-- > DATE_TIME ClientLeaseExpires;+-- > DHCP_HOST_INFO OwnerHost;+-- > BYTE bClientType;+-- > } DHCP_CLIENT_INFO_V4, *LPDHCP_CLIENT_INFO_V4;+data Client = Client+ { clientIp :: !Ip+ , clientSubnetMask :: !Ip+ , clientHardwareAddress :: !Mac+ , clientName :: Maybe String+ , clientComment :: Maybe String+ , clientLeaseExpires :: !DATE_TIME+ -- ^ MSDN: The date and time the DHCP client lease will expire, in UTC+ -- time.+ --+ -- I don't know of any available functions to work with a `DATE_TIME`.+ , clientOwnerHost :: !HOST_INFO+ -- ^ Information on the DHCP server that assigned the lease to the client.+ , clientType :: !ClientType+ }+ +clientInfo :: DhcpStructure Client+clientInfo = DhcpStructure+ { peekDhcp = peekClientInfoV4+ , freeDhcpChildren = freeClientInfoV4+ , withDhcp' = withClientInfo'+ -- 12-byte alignment because of the inlined HOST_INFO struct+ , sizeDhcp = 48+ }++withClientInfo' :: Client -> Ptr Client -> IO r -> IO r+withClientInfo' c ptr f = + -- The Mac is inlined, so we'll need to copy pmacsrc into pmac+ withMac (clientHardwareAddress c) $ \pcuidsrc ->+ withMaybeTString (clientName c) $ \pclientName ->+ withMaybeTString (clientComment c) $ \pclientComment ->+ withDhcp' hostInfo (clientOwnerHost c) (pownerHost ptr) $ do+ poke (pclientIP ptr) $ clientIp c+ poke (psubnetMask ptr) $ clientSubnetMask c+ -- we can't use the Storable instance for Mac here.+ copyBytes (pmac ptr) pcuidsrc $ sizeDhcp clientUid+ poke (ppclientName ptr) pclientName+ poke (ppclientComment ptr) pclientComment+ poke (pleaseExpires ptr) $ clientLeaseExpires c+ -- Owner host has already been poked+ poke (pclientType ptr) $ clientType c+ f++peekClientInfoV4 :: Ptr Client -> IO Client+peekClientInfoV4 ptr = Client+ <$> (peek $ pclientIP ptr)+ <*> (peek $ psubnetMask ptr)+ <*> (macCuid <$> peekDhcp clientUid (pmac ptr))+ <*> (peek (ppclientName ptr) >>= peekMaybeTString)+ <*> (peek (ppclientComment ptr) >>= peekMaybeTString)+ <*> (peek $ pleaseExpires ptr)+ <*> (peekDhcp hostInfo $ pownerHost ptr)+ <*> (peek $ pclientType ptr)++freeClientInfoV4 :: (forall a. Ptr a -> IO ()) -> Ptr Client -> IO ()+freeClientInfoV4 freefunc ptr = do+ -- The client_uid is inlined into the client_info structure.+ freeDhcpChildren clientUid freefunc $ pmac ptr+ freefunc `scrubbing_` ppclientName ptr+ freefunc `scrubbing_` ppclientComment ptr+ -- The HOST_INFO structure is inlined within the ClientInfoV4, so we don't+ -- have to free its main pointer.+ freeDhcpChildren hostInfo freefunc $ pownerHost ptr++pclientIP :: Ptr Client -> Ptr Ip+pclientIP = castPtr++psubnetMask :: Ptr Client -> Ptr Ip+psubnetMask ptr = castPtr ptr `plusPtr` 4++-- The client_uid is inlined into the client_info structure.+pmac :: Ptr Client -> Ptr CLIENT_UID+pmac ptr = castPtr ptr `plusPtr` 8++ppclientName :: Ptr Client -> Ptr LPWSTR+ppclientName ptr = castPtr ptr `plusPtr` 16++ppclientComment :: Ptr Client -> Ptr LPWSTR+ppclientComment ptr = castPtr ptr `plusPtr` 20++pleaseExpires :: Ptr Client -> Ptr DATE_TIME+pleaseExpires ptr = castPtr ptr `plusPtr` 24++-- the HOST_INFO is inlined into the CLIENT_INFO structure+pownerHost :: Ptr Client -> Ptr HOST_INFO+pownerHost ptr = castPtr ptr `plusPtr` 32++pclientType :: Ptr Client -> Ptr ClientType+pclientType ptr = castPtr ptr `plusPtr` 44
+ src/System/Win32/DHCP/DhcpStructure.hs view
@@ -0,0 +1,185 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE RankNTypes #-}++module System.Win32.DHCP.DhcpStructure where++import Control.Monad (when)++import Import++-- |Function dictionary for objects used with the DHCP api.+-- * Ability to peek from a pointer to that object.+-- * Ability to properly free an object using Win32's rpcFreeMemory+-- created by the DHCP api.+-- * Ability to use the with* metaphor to temporarily poke an+-- object into C memory, call a continuation on it, and then+-- free the memory from Haskell's heap.+--+-- Extra features made possible by the typeclass+-- * Ability to turn any Storable instance into a DhpcStructure instance+-- by wrapping it into a 'storableDhcpStructure'.+-- * Ability to peek an array of DHCP structures into a list.+-- * Ability to poke a list of objects into contiguous memory, then+-- call a continuation on that block of memory.+data DhcpStructure a = DhcpStructure+ { peekDhcp :: Ptr a -> IO a+ -- |Cleaning up memory is the responsibility of the client of this+ -- library. Most out parameters return compound structures which need to+ -- be recursively navigated, freeing all children, before freeing the main+ -- pointer.+ --+ -- This function only frees child objects without freeing the pointer+ -- itself. It's necessary because some structures contained inline+ -- structures instead of the usual pointer. A separate 'freeDhcp' function+ -- will call this one before freeing its supplied pointer.+ , freeDhcpChildren :: (forall x. Ptr x -> IO ()) -> Ptr a -> IO ()+ -- |Like `withDhcp`, but without any allocation or cleanup of memory.+ -- The continuation is not automatically given a pointer because+ -- the caller should already have it.+ , withDhcp' :: forall r. a -> Ptr a -> IO r -> IO r+ , sizeDhcp :: Int+ }++freeDhcp :: DhcpStructure a -> (forall x. Ptr x -> IO ()) -> Ptr a -> IO ()+freeDhcp dict free ptr = do+ freeDhcpChildren dict free ptr+ free ptr++-- |Allocate memory for a structure, poke it into memory, apply+-- a function, and then clean up the memory.+withDhcp :: DhcpStructure a -> a -> (Ptr a -> IO r) -> IO r+withDhcp dict a f = allocaBytes (sizeDhcp dict) $ \ptr ->+ withDhcp' dict a ptr $ f ptr++-- |Convert a DhcpStructure so that it can be used with a newtype+-- wrapper.+newtypeDhcpStructure :: (a -> nt) -> (nt -> a)+ -> DhcpStructure a -> DhcpStructure nt+newtypeDhcpStructure wrap unwrap dict =+ DhcpStructure peekNt freeNt withNt' (sizeDhcp dict)+ where+ peekNt ptr = wrap <$> peekDhcp dict (castPtr ptr)+ freeNt :: (forall x. Ptr x -> IO ()) -> Ptr a -> IO ()+ freeNt f ptr = freeDhcpChildren dict f (castPtr ptr)+ withNt' a ptr f = withDhcp' dict (unwrap a) (castPtr ptr) f++-- |This is used in cases like 'CLIENT_UID' where we want to treat it like+-- a 'LengthArray' but individual elements of the array are simple values that+-- do not need to be freed individually. An example of this (and the only+-- place where it is used) is 'CLIENT_UID'. We reuse the 'Storable' instances+-- peek and poke functions.+storableDhcpStructure :: forall a. (Storable a) => DhcpStructure a+storableDhcpStructure = DhcpStructure+ { peekDhcp = peek+ , freeDhcpChildren = \freeFunc ptr -> freeFunc ptr+ , withDhcp' = withStorable'+ , sizeDhcp = sizeOf (undefined :: a)+ }+ where+ withStorable' x ptr f = poke ptr x >> f++data DhcpArray a = DhcpArray+ { peekDhcpArray :: Int -> Ptr a -> IO [a]+ , freeDhcpArray :: (forall x. Ptr x -> IO ()) -> Int -> Ptr a -> IO ()+ , withDhcpArray' :: forall r. [a] -> Ptr a -> IO r -> IO r+ , dhcpStructure :: DhcpStructure a+ }++-- |Allocate enough contiguous memory for each element. Recursively+-- free all memory once the supplied function returns.+-- The continuation receives a length argument. This is because+-- the length must be calculated in the course of execution, and will+-- likely be needed again by the caller.+withDhcpArray :: DhcpArray a -> [a] -> (Int -> Ptr a -> IO r) -> IO r+withDhcpArray dict elems f =+ allocaBytes (stride * size) $ \ptr ->+ -- `f` is meant to be called on the array as a whole; not individual elements.+ -- It's supplied its pointer here because we want it called on position 0.+ withDhcpArray' dict elems ptr $ f size ptr+ where+ size = length elems+ stride = sizeDhcp . dhcpStructure $ dict++-- |This dictionary is a default set to "base" other versions on.+-- Scanning through the buffer happens dhcpSize bytes at a time. Memory+-- is freed by calling the freeing function on every element in the buffer.+baseDhcpArray :: DhcpStructure a -> DhcpArray a+baseDhcpArray s = DhcpArray+ { peekDhcpArray = basePeekArray s+ , freeDhcpArray = baseFreeArray s+ , withDhcpArray' = baseWithArray' s+ , dhcpStructure = s+ }++-- |This differs from `baseDhcpArray` in that the entire buffer+-- is freed with a single call to the freeing function.+basicDhcpArray :: DhcpStructure a -> DhcpArray a+basicDhcpArray dict = (baseDhcpArray dict)+ { freeDhcpArray = basicFreeArray dict+ }++ptrDhcpArray :: DhcpStructure a -> DhcpArray a+ptrDhcpArray dict = (baseDhcpArray dict)+ { peekDhcpArray = ptrPeekArray dict+ , freeDhcpArray = ptrFreeArray dict+ , withDhcpArray' = ptrWithArray' dict+ }++basePeekArray :: DhcpStructure a -> Int -> Ptr a -> IO [a]+basePeekArray dict len ptr0 = mapM (peekDhcp dict) ptrs+ where+ ptrs = take len . iterate (`plusPtr` sizeDhcp dict) $ ptr0++-- |Elements are arranged end to end in a buffer. The buffer is freed+-- at once after each element's children are freed.+baseFreeArray :: DhcpStructure a+ -> (forall x. Ptr x -> IO ()) -> Int -> Ptr a -> IO ()+baseFreeArray dict freefunc len ptr+ | len <= 0 = return ()+ | otherwise = do+ f (len - 1)+ freefunc ptr+ where+ f 0 = freeDhcpChildren dict freefunc ptr+ f n = do+ freeDhcpChildren dict freefunc $ ptr `plusPtr` (n * sizeDhcp dict)+ f (n - 1)++baseWithArray' :: DhcpStructure a -> [a] -> Ptr a -> IO r -> IO r+baseWithArray' _ [] _ f = f+baseWithArray' dict (e:es) ptr f =+ -- We're not concerned with the individual element.+ withDhcp' dict e ptr+ $ baseWithArray' dict es (ptr `plusPtr` sizeDhcp dict) f++basicFreeArray :: DhcpStructure a -> (forall x. Ptr x -> IO ())+ -> Int -> Ptr a -> IO ()+basicFreeArray dict freefunc _ ptr = freeDhcp dict freefunc ptr++ptrPeekArray :: DhcpStructure a -> Int -> Ptr a -> IO [a]+ptrPeekArray dict len ptr = mapM peekElement pptrs+ where+ --Each element is a pointer to the real data+ pptrs = take len . iterate (`plusPtr` sizeOf nullPtr) $ castPtr ptr+ peekElement pptr = peek pptr >>= peekDhcp dict++ptrFreeArray :: DhcpStructure a+ -> (forall x. Ptr x -> IO ()) -> Int -> Ptr a -> IO ()+ptrFreeArray dict freefunc len ptr = do+ mapM (freeDhcp dict freefunc `scrubbing_`) pptrs+ -- Len may very well be 0 in which case there's really nothing to free.+ when (len > 0) $ freefunc ptr+ where+ --Each element is a pointer to the real data+ pptrs = take len . iterate (`plusPtr` sizeOf nullPtr) $ castPtr ptr++ptrWithArray' :: DhcpStructure a -> [a] -> Ptr a -> IO r -> IO r+ptrWithArray' _ [] _ f = f+ptrWithArray' dict (e:es) ptr f =+ -- We're not concerned with the individual element.+ withDhcp dict e $ \pe -> do+ poke pptr pe+ ptrWithArray' dict es (ptr `plusPtr` sizeOf nullPtr) f+ where+ --Each element is a pointer to the real data+ pptr = castPtr ptr
+ src/System/Win32/DHCP/HOST_INFO.hs view
@@ -0,0 +1,53 @@+{-# LANGUAGE RankNTypes #-}++module System.Win32.DHCP.HOST_INFO+ ( HOST_INFO (..)+ , hostInfo+ ) where++import Data.Ip+import Import+import System.Win32.DHCP.DhcpStructure++-- typedef struct _DHCP_HOST_INFO {+-- DHCP_IP_ADDRESS IpAddress;+-- LPWSTR NetBiosName;+-- LPWSTR HostName;+-- } DHCP_HOST_INFO, *LPDHCP_HOST_INFO;+data HOST_INFO = HOST_INFO !Ip (Maybe String) (Maybe String)+++hostInfo :: DhcpStructure HOST_INFO+hostInfo = DhcpStructure+ { peekDhcp = peekHostInfo+ , freeDhcpChildren = freeHostInfoChildren+ , withDhcp' = withHostInfo'+ , sizeDhcp = 12+ }++peekHostInfo :: Ptr HOST_INFO -> IO HOST_INFO+peekHostInfo ptr = do+ pnetBiosName <- peek $ ppnetBiosName ptr+ phostName <- peek $ pphostName ptr+ HOST_INFO <$> peek (castPtr ptr) <*> peekMaybeTString pnetBiosName+ <*> peekMaybeTString phostName++withHostInfo' :: HOST_INFO -> Ptr HOST_INFO -> IO r -> IO r+withHostInfo' (HOST_INFO ip netbiosname hostname) ptr f =+ withMaybeTString netbiosname $ \pnetbiosname ->+ withMaybeTString hostname $ \phostname -> do+ poke (castPtr ptr) ip+ pokeByteOff (castPtr ptr) 4 pnetbiosname+ pokeByteOff (castPtr ptr) 8 phostname+ f++freeHostInfoChildren :: (forall x. Ptr x -> IO ()) -> Ptr HOST_INFO -> IO ()+freeHostInfoChildren rpcfree phi = do+ rpcfree `scrubbing_` ppnetBiosName phi+ rpcfree `scrubbing_` pphostName phi++ppnetBiosName :: Ptr HOST_INFO -> Ptr LPWSTR+ppnetBiosName ptr = castPtr ptr `plusPtr` 4++pphostName :: Ptr HOST_INFO -> Ptr LPWSTR+pphostName ptr = castPtr ptr `plusPtr` 8
+ src/System/Win32/DHCP/IP_CLUSTER.hs view
@@ -0,0 +1,21 @@+module System.Win32.DHCP.IP_CLUSTER+ ( IP_CLUSTER (..)+ ) where++import Data.Ip+import Import++-- typedef struct _DHCP_IP_CLUSTER {+-- DHCP_IP_ADDRESS ClusterAddress;+-- DWORD ClusterMask;+-- } DHCP_IP_CLUSTER, *LPDHCP_IP_CLUSTER;+data IP_CLUSTER = IP_CLUSTER !Ip !DWORD++instance Storable IP_CLUSTER where+ sizeOf _ = 8+ alignment _ = 1+ peek ptr = IP_CLUSTER <$> (peek . castPtr $ ptr)+ <*> (castPtr ptr `peekByteOff` 4)+ poke ptr (IP_CLUSTER ip cmask) = do+ poke (castPtr ptr) ip+ pokeByteOff (castPtr ptr) 4 cmask
+ src/System/Win32/DHCP/IP_RANGE.hs view
@@ -0,0 +1,20 @@+module System.Win32.DHCP.IP_RANGE+ ( IP_RANGE (..)+ ) where++import Data.Ip+import Import++data IP_RANGE = IP_RANGE !Ip !Ip++instance Storable IP_RANGE where+ sizeOf _ = 8+ alignment _ = 1+ peek ptr = IP_RANGE+ <$> (peek . castPtr) ptr+ <*> castPtr ptr `peekByteOff` 4+ poke ptr (IP_RANGE start end) = do+ pokeElemOff addrPtr 0 start+ pokeElemOff addrPtr 1 end+ where+ addrPtr = castPtr ptr :: Ptr Ip
+ src/System/Win32/DHCP/Internal.hs view
@@ -0,0 +1,151 @@+{-# LANGUAGE ForeignFunctionInterface #-}++module System.Win32.DHCP.Internal where++import Foreign+import Foreign.C+import System.Win32.DLL+import System.Win32.Types++import System.Win32.DHCP.Client+import System.Win32.DHCP.SEARCH_INFO+import System.Win32.DHCP.SUBNET_CLIENT_INFO_ARRAY_V4+import System.Win32.DHCP.SUBNET_ELEMENT_INFO_ARRAY_V4+import System.Win32.DHCP.SUBNET_ELEMENT_DATA_V4+import System.Win32.DHCP.Types++-- DWORD DHCP_API_FUNCTION DhcpDeleteClientInfo(+-- _In_ DHCP_CONST WCHAR *ServerIpAddress,+-- _In_ DHCP_CONST DHCP_SEARCH_INFO *ClientInfo+-- );+type DeleteClientInfo = CWString -> Ptr SEARCH_INFO -> IO DWORD+foreign import stdcall "dynamic"+ mkDeleteClientInfo :: FunPtr DeleteClientInfo -> DeleteClientInfo++-- DWORD DHCP_API_FUNCTION DhcpEnumSubnetClientsV4(+-- _In_ DHCP_CONST WCHAR *ServerIpAddress,+-- _In_ DHCP_IP_ADDRESS SubnetAddress,+-- _Inout_ DHCP_RESUME_HANDLE *ResumeHandle,+-- _In_ DWORD PreferredMaximum,+-- _Out_ LPDHCP_CLIENT_INFO_ARRAY_V4 *ClientInfo,+-- _Out_ DWORD *ClientsRead,+-- _Out_ DWORD *ClientsTotal+-- );+type EnumSubnetClientsV4 = CWString -> Word32 -> Ptr RESUME_HANDLE+ -> DWORD -> Ptr (Ptr SUBNET_CLIENT_INFO_ARRAY_V4) -> Ptr DWORD+ -> Ptr DWORD -> IO DWORD+foreign import stdcall "dynamic"+ mkEnumSubnetClientsV4 :: FunPtr EnumSubnetClientsV4+ -> EnumSubnetClientsV4++-- DWORD DHCP_API_FUNCTION DhcpEnumSubnetElementsV4(+-- __in DHCP_CONST WCHAR *ServerIpAddress,+-- __in DHCP_IP_ADDRESS SubnetAddress,+-- __in DHCP_SUBNET_ELEMENT_TYPE EnumElementType,+-- __inout DHCP_RESUME_HANDLE *ResumeHandle,+-- __in DWORD PreferredMaximum,+-- __out LPDHCP_SUBNET_ELEMENT_INFO_ARRAY_V4 *EnumElementInfo,+-- __out DWORD *ElementsRead,+-- __out DWORD *ElementsTotal+-- );+type EnumSubnetElementsV4 = CWString -> Word32 -> CInt -> Ptr RESUME_HANDLE+ -> DWORD -> Ptr (Ptr SUBNET_ELEMENT_INFO_ARRAY_V4) -> Ptr DWORD+ -> Ptr DWORD -> IO DWORD+foreign import stdcall "dynamic"+ mkEnumSubnetElementsV4 :: FunPtr EnumSubnetElementsV4+ -> EnumSubnetElementsV4++-- DWORD DHCP_API_FUNCTION DhcpGetClientInfoV4(+-- _In_ DHCP_CONST WCHAR ServerIpAddress,+-- _In_ DHCP_CONST DHCP_SEARCH_INFO SearchInfo,+-- _Out_ LPDHCP_CLIENT_INFO_V4 *ClientInfo+-- );+type GetClientInfoV4 = CWString -> SEARCH_INFO_TYPE -> Ptr ()+ -> Ptr (Ptr Client) -> IO DWORD+foreign import stdcall "dynamic"+ mkGetClientInfoV4 :: FunPtr GetClientInfoV4 -> GetClientInfoV4++-- | Foreign wrapper to DhcpRemoveSubnetElementV4.+-- +-- The DhcpRemoveSubnetElementV4 function removes an IPv4 subnet element+-- from an IPv4 subnet defined on the DHCPv4 server. The function extends+-- the functionality provided by DhcpRemoveSubnetElement by allowing the+-- specification of a subnet that contains client type (DHCP or BOOTP)+-- information.+-- +-- See <http://msdn.microsoft.com/en-us/library/ee309533(v=VS.85).aspx> for+-- official documentation.+-- +-- @+-- DWORD DHCP_API_FUNCTION DhcpRemoveSubnetElementV4(+-- __in DHCP_CONST WCHAR *ServerIpAddress,+-- __in DHCP_IP_ADDRESS SubnetAddress,+-- __in DHCP_CONST DHCP_SUBNET_ELEMENT_DATA_V4 *RemoveElementInfo,+-- __in DHCP_FORCE_FLAG ForceFlag+-- );+-- @+type RemoveSubnetElementV4 = CWString -> Word32 -> Ptr SUBNET_ELEMENT_DATA_V4+ -> CInt -> IO DWORD+foreign import stdcall "dynamic"+ mkRemoveSubnetElementV4 :: FunPtr RemoveSubnetElementV4+ -> RemoveSubnetElementV4++-- DWORD DhcpAddSubnetElementV4(+-- __in DHCP_CONST WCHAR *ServerIpAddress,+-- __in DHCP_IP_ADDRESS SubnetAddress,+-- __in DHCP_CONST DHCP_SUBNET_ELEMENT_DATA_V4 AddElementInfo+-- );+type AddSubnetElementV4 = CWString -> Word32 -> Ptr SUBNET_ELEMENT_DATA_V4+ -> IO DWORD+foreign import stdcall "dynamic"+ mkAddSubnetElementV4 :: FunPtr AddSubnetElementV4 -> AddSubnetElementV4++-- VOID DHCP_API_FUNCTION DhcpRpcFreeMemory(+-- PVOID BufferPointer+-- );+type RpcFreeMemory = Ptr () -> IO ()+foreign import stdcall "dynamic"+ mkRpcFreeMemory :: FunPtr RpcFreeMemory -> RpcFreeMemory++-- | In an effort to avoid potential compile-time linker errors this package+-- uses runtime dynamic linking. Internally a `DhcpApi` is a dictionary of+-- dynamically bound foreign calls. Most actions require one to be passed.+-- Simply call `loadDhcp` to obtain one.+data DhcpApi = DhcpApi+ { c_DeleteClientInfo :: DeleteClientInfo+ , c_EnumSubnetClientsV4 :: EnumSubnetClientsV4+ , c_EnumSubnetElementsV4 :: EnumSubnetElementsV4+ , c_GetClientInfoV4 :: GetClientInfoV4+ , c_RemoveSubnetElementV4 :: RemoveSubnetElementV4+ , c_AddSubnetElementV4 :: AddSubnetElementV4+ , c_RpcFreeMemory :: RpcFreeMemory+ }++-- | Calling this function performs runtime dynamic linking for every internal+-- foreign call into the Dhcp Server Management Api. It is safe to call this+-- action multiple times. I recommend calling this function once as the part+-- of a process's initialization, and then pass the returned `DhcpApi` to+-- functions that need it.+loadDHCP :: IO DhcpApi+loadDHCP = do+ lib <- loadLibrary "dhcpsapi"+ deleteclient <- getProcAddress lib "DhcpDeleteClientInfo"+ enumClients <- getProcAddress lib "DhcpEnumSubnetClientsV4"+ enumElements <- getProcAddress lib "DhcpEnumSubnetElementsV4"+ getclient <- getProcAddress lib "DhcpGetClientInfoV4"+ remove <- getProcAddress lib "DhcpRemoveSubnetElementV4"+ add <- getProcAddress lib "DhcpAddSubnetElementV4"+ rpcfree <- getProcAddress lib "DhcpRpcFreeMemory"+ return $ DhcpApi (mkDeleteClientInfo . castPtrToFunPtr $ deleteclient)+ (mkEnumSubnetClientsV4 . castPtrToFunPtr $ enumClients)+ (mkEnumSubnetElementsV4 . castPtrToFunPtr $ enumElements)+ (mkGetClientInfoV4 . castPtrToFunPtr $ getclient)+ (mkRemoveSubnetElementV4 . castPtrToFunPtr $ remove)+ (mkAddSubnetElementV4 . castPtrToFunPtr $ add)+ (mkRpcFreeMemory . castPtrToFunPtr $ rpcfree)++-- |Free a block of memory created by DHCP's api.+-- MSDN only mensions this function in DhcpEnumSubnetElementsV5. The original,+-- v4, and v6 variants of the function don't say how memory should be freed.+rpcFreeMemory :: DhcpApi -> Ptr a -> IO ()+rpcFreeMemory api ptr = c_RpcFreeMemory api $ castPtr ptr
+ src/System/Win32/DHCP/LengthBuffer.hs view
@@ -0,0 +1,58 @@+{-# LANGUAGE RankNTypes #-}++module System.Win32.DHCP.LengthBuffer+ ( LengthBuffer (..)+ , lengthBuffer+ ) where++import System.Win32.DHCP.DhcpStructure++import Import++-- |A LengthBuffer is a list of items which can be marshalled in and out+-- of memory with a `DhcpArray` instance. A C structure that can be used+-- with this looks something like the following:+-- +-- typedef struct Structure {+-- DWORD NumElements;+-- LPElementData Elements;+-- } Structure, *LPStructure;+data LengthBuffer a = LengthBuffer+ { lbLength :: !Int+ , buffer :: [a]+ }++lengthBuffer :: DhcpArray a -> DhcpStructure (LengthBuffer a)+lengthBuffer dict = DhcpStructure+ { peekDhcp = peekLb dict+ , freeDhcpChildren = freeLb dict+ , withDhcp' = withLb' dict+ , sizeDhcp = 8+ }++peekLb :: DhcpArray a -> Ptr (LengthBuffer a) -> IO (LengthBuffer a)+peekLb dict ptr = do+ len <- fromIntegral <$> peek (pNumElements ptr)+ pElements <- peek $ ppElements ptr+ LengthBuffer len <$> peekDhcpArray dict len pElements++freeLb :: DhcpArray a -> (forall x. Ptr x -> IO ())+ -> Ptr (LengthBuffer a) -> IO ()+freeLb dict freefunc ptr = do+ len <- fromIntegral <$> peek (pNumElements ptr)+ -- A LengthBuffer contain a pointer to the buffer; not the start of the+ -- buffer itself.+ freeDhcpArray dict freefunc len `scrubbing_` ppElements ptr++withLb' :: DhcpArray a -> LengthBuffer a -> Ptr (LengthBuffer a) -> IO r -> IO r+withLb' dict (LengthBuffer _ elems) ptr f =+ withDhcpArray dict elems $ \size pelems -> do+ pokeByteOff ptr 0 (fromIntegral size :: DWORD)+ poke (ppElements ptr) (castPtr pelems)+ f++pNumElements :: Ptr (LengthBuffer a) -> Ptr DWORD+pNumElements ptr = castPtr ptr++ppElements :: Ptr (LengthBuffer a) -> Ptr (Ptr a)+ppElements ptr = castPtr ptr `plusPtr` 4
+ src/System/Win32/DHCP/Reservation.hs view
@@ -0,0 +1,78 @@+{-# LANGUAGE RankNTypes #-}++module System.Win32.DHCP.Reservation+ ( Mapping (..)+ , Reservation (..)+ , reservation+ ) where++import Data.Ip+import Data.Mac+import Import+import System.Win32.DHCP.CLIENT_UID+import System.Win32.DHCP.DhcpStructure+import System.Win32.DHCP.Types (ClientType)++-- | A Reservation guarantees that a device with a given Mac address will+-- always be assigned to a particular IP address. A reservation is not the+-- same thing as a lease, and there are separate calls to work with both+-- objects.+--+-- This type corresponds to MSDN's DHCP_IP_RESERVATION_V4 structure.+--+-- > typedef struct _DHCP_IP_RESERVATION_V4 {+-- > DHCP_IP_ADDRESS ReservedIpAddress;+-- > DHCP_CLIENT_UID *ReservedForClient;+-- > BYTE bAllowedClientTypes;+-- > } DHCP_IP_RESERVATION_V4, *LPDHCP_IP_RESERVATION_V4;+data Reservation = Reservation+ { reservationMapping :: !Mapping+ , reservationType :: !ClientType+ } deriving (Eq)++-- | A mapping between an IP and a MAC address. Each IP number may map to+-- only one MAC address, and each MAC address may map to only one IP number.+--+-- This is a separate type from `Reservation` for practical reasons. When+-- writing software to work with a DHCP server, `Reservation`'s+-- `ClientType` field is often not important. Without the `Mapping` type+-- defined here it would often be necessary to define a custom type in+-- each project.+data Mapping = Mapping+ { mappingMac :: !Mac+ , mappingIp :: !Ip+ } deriving (Eq, Ord)++reservation :: DhcpStructure Reservation+reservation = DhcpStructure+ { peekDhcp = peekReservation+ , freeDhcpChildren = freeReservation+ , withDhcp' = withReservation'+ , sizeDhcp = 10+ }++peekReservation :: Ptr Reservation -> IO Reservation+peekReservation ptr = do+ pCuid <- peek $ ppCuid ptr+ mac <- macCuidDrop5 <$> peekDhcp clientUid pCuid+ addr <- peek pAddress+ clientType <- peekByteOff (castPtr ptr) 8+ return $ Reservation (Mapping mac addr) clientType+ where+ pAddress = castPtr ptr :: Ptr Ip++freeReservation :: (forall x. Ptr x -> IO ()) -> Ptr Reservation -> IO ()+freeReservation freefunc ptr = do+ freeDhcp clientUid freefunc `scrubbing_` ppCuid ptr++ppCuid :: Ptr Reservation -> Ptr (Ptr CLIENT_UID)+ppCuid ptr = castPtr ptr `plusPtr` 4++withReservation' :: Reservation -> Ptr Reservation+ -> IO r -> IO r+withReservation' (Reservation (Mapping mac address) clientType) ptr f =+ withMac mac $ \pCuid -> do+ poke (castPtr ptr) address+ pokeByteOff (castPtr ptr) 4 pCuid+ pokeByteOff (castPtr ptr) 8 clientType+ f
+ src/System/Win32/DHCP/SEARCH_INFO.hs view
@@ -0,0 +1,67 @@+{-# LANGUAGE OverloadedStrings #-}++module System.Win32.DHCP.SEARCH_INFO+ ( SEARCH_INFO_TYPE+ , SEARCH_INFO (..)+ , withSearchInfo+ ) where++import qualified Data.Text as T++import Data.Ip+import Data.Mac+import Import+import System.Win32.DHCP.CLIENT_UID++-- typedef enum _DHCP_CLIENT_SEARCH_TYPE { +-- DhcpClientIpAddress,+-- DhcpClientHardwareAddress,+-- DhcpClientName+-- } DHCP_SEARCH_INFO_TYPE, *LPDHCP_SEARCH_INFO_TYPE;+type SEARCH_INFO_TYPE = CInt++-- | Filter criteria used in actions that look up reservation or lease+-- records.+--+-- > typedef struct _DHCP_CLIENT_SEARCH_INFO {+-- > DHCP_SEARCH_INFO_TYPE SearchType;+-- > union {+-- > DHCP_IP_ADDRESS ClientIpAddress;+-- > DHCP_CLIENT_UID ClientHardwareAddress;+-- > LPWSTR ClientName;+-- > } SearchInfo;+-- > } DHCP_SEARCH_INFO, *LPDHCP_SEARCH_INFO;+data SEARCH_INFO+ -- | Search based on an IP address. All scopes are searched. It should+ -- not be possible for multiple records to exist.+ = ClientIpAddress !Ip+ -- | Search based on a subnet and MAC address. This method of searching+ -- has not been tested.+ | ClientHardwareAddress !Mac+ -- | Search based on a client's name. Multiple records may exist, and+ -- what happens in that case will depend on the function being called.+ -- This method of searching has not been tested.+ | ClientName !String++instance Show SEARCH_INFO where+ show (ClientIpAddress ip) = T.unpack $ "ClientIpAddress " <> showIp ip+ show (ClientHardwareAddress mac) = T.unpack $ "ClientHardwareAddress " <> showMac ":" mac+ show (ClientName name) = "ClientName " ++ name++siTypeOf :: SEARCH_INFO -> SEARCH_INFO_TYPE+siTypeOf (ClientIpAddress _) = 0+siTypeOf (ClientHardwareAddress _) = 1+siTypeOf (ClientName _) = 2++-- Allocate 12 because a SEARCH_INFO.SearchInfo member's in-structure alignment is 4 with a size of 8.+withSearchInfo :: SEARCH_INFO -> (Ptr SEARCH_INFO -> IO r) -> IO r+withSearchInfo si f = allocaBytes 12 $ \ptr -> do+ let pX = ptr `plusPtr` 4+ poke (castPtr ptr) $ siTypeOf si+ case si of+ ClientIpAddress x -> poke (castPtr pX) x >> f ptr+ ClientHardwareAddress m -> withMac m $ \pm -> copyBytes (castPtr pX) pm 8 >> f ptr+ -- We're preserving API compatibility here. A future version of+ -- Win32-dhcp-server will used Text values.+ ClientName str -> withTString (T.pack str)+ $ \pstr -> copyBytes (castPtr pX) pstr 4 >> f ptr
+ src/System/Win32/DHCP/SUBNET_CLIENT_INFO_ARRAY_V4.hs view
@@ -0,0 +1,22 @@+module System.Win32.DHCP.SUBNET_CLIENT_INFO_ARRAY_V4+ ( SUBNET_CLIENT_INFO_ARRAY_V4 (..)+ , clientInfoArray+ ) where++import System.Win32.DHCP.Client+import System.Win32.DHCP.DhcpStructure+import System.Win32.DHCP.LengthBuffer++-- typedef struct _DHCP_CLIENT_INFO_ARRAY_V4 {+-- DWORD NumElements;+-- LPDHCP_CLIENT_INFO_V4 *Clients;+-- } DHCP_CLIENT_INFO_ARRAY_V4, *LPDHCP_CLIENT_INFO_ARRAY_V4;+newtype SUBNET_CLIENT_INFO_ARRAY_V4+ = SUBNET_CLIENT_INFO_ARRAY_V4 (LengthBuffer Client)++unwrap :: SUBNET_CLIENT_INFO_ARRAY_V4 -> LengthBuffer Client+unwrap (SUBNET_CLIENT_INFO_ARRAY_V4 ia) = ia++clientInfoArray :: DhcpStructure SUBNET_CLIENT_INFO_ARRAY_V4+clientInfoArray = newtypeDhcpStructure SUBNET_CLIENT_INFO_ARRAY_V4 unwrap+ $ lengthBuffer (ptrDhcpArray clientInfo)
+ src/System/Win32/DHCP/SUBNET_ELEMENT_DATA_V4.hs view
@@ -0,0 +1,98 @@+{-# LANGUAGE RankNTypes #-}++module System.Win32.DHCP.SUBNET_ELEMENT_DATA_V4+ ( SUBNET_ELEMENT_DATA_V4 (..)+ , SUBNET_ELEMENT_TYPE+ , elementTypeOf+ , subnetElementData+ ) where++import Import+import System.Win32.DHCP.DhcpStructure+import System.Win32.DHCP.HOST_INFO+import System.Win32.DHCP.IP_CLUSTER+import System.Win32.DHCP.IP_RANGE+import System.Win32.DHCP.Reservation++-- typedef struct _DHCP_SUBNET_ELEMENT_DATA_V4 {+-- DHCP_SUBNET_ELEMENT_TYPE ElementType;+-- union {+-- DHCP_IP_RANGE *IpRange;+-- DHCP_HOST_INFO *SecondaryHost;+-- DHCP_IP_RESERVATION_V4 *ReservedIp;+-- DHCP_IP_RANGE *ExcludeIpRange;+-- DHCP_IP_CLUSTER *IpUsedCluster;+-- } Element;+-- } DHCP_SUBNET_ELEMENT_DATA_V4, *LPDHCP_SUBNET_ELEMENT_DATA_V4;+data SUBNET_ELEMENT_DATA_V4+ = IpRanges !IP_RANGE+ | SecondaryHosts !HOST_INFO+ | ReservedIps !Reservation+ | ExcludedIpRanges !IP_RANGE+ | IpUsedCluster !IP_CLUSTER++-- typedef enum _DHCP_SUBNET_ELEMENT_TYPE_V5 {+-- DhcpIpRanges,+-- DhcpSecondaryHosts,+-- DhcpReservedIps,+-- DhcpExcludedIpRanges,+-- DhcpIpRangesDhcpOnly,+-- DhcpIpRangesDhcpBootp,+-- DhcpIpRangesBootpOnly+-- } DHCP_SUBNET_ELEMENT_TYPE, *LPDHCP_SUBNET_ELEMENT_TYPE;+type SUBNET_ELEMENT_TYPE = CInt++subnetElementData :: DhcpStructure SUBNET_ELEMENT_DATA_V4+subnetElementData = DhcpStructure+ { peekDhcp = peekSubnetElementData+ , freeDhcpChildren = freeSubnetElementData+ , withDhcp' = withSubnetElementData'+ , sizeDhcp = 8+ }++peekSubnetElementData :: Ptr SUBNET_ELEMENT_DATA_V4 -> IO SUBNET_ELEMENT_DATA_V4+peekSubnetElementData ptr = do+ elementType <- (peek . castPtr) ptr :: IO SUBNET_ELEMENT_TYPE+ pElement <- peekByteOff ptr 4+ case elementType of+ 0 -> IpRanges <$> peek (castPtr pElement)+ 1 -> SecondaryHosts <$> peekDhcp hostInfo (castPtr pElement)+ 2 -> ReservedIps <$> peekDhcp reservation (castPtr pElement)+ 3 -> ExcludedIpRanges <$> peek (castPtr pElement)+ 4 -> IpUsedCluster <$> peek (castPtr pElement)+ _ -> error "Invalid element type found in SUBNET_ELEMENT_DATA_V4."++freeSubnetElementData :: (forall x. Ptr x -> IO ())+ -> Ptr SUBNET_ELEMENT_DATA_V4 -> IO ()+freeSubnetElementData freefunc ptr = do+ elementType <- (peek . castPtr) ptr :: IO SUBNET_ELEMENT_TYPE+ scrubWith_ (ppElement ptr) $ \pElement -> do+ case elementType of+ 0 -> return ()+ 1 -> freeDhcp hostInfo freefunc $ castPtr pElement+ 2 -> freeDhcp reservation freefunc $ castPtr pElement+ 3 -> return ()+ 4 -> return ()+ _ -> error "Invalid element type found in SUBNET_ELEMENT_DATA_V4."++-- Also used by withSubnetElementDataArray.+withSubnetElementData' :: SUBNET_ELEMENT_DATA_V4 -> Ptr SUBNET_ELEMENT_DATA_V4+ -> IO r -> IO r+withSubnetElementData' elementData ptr f = do+ castPtr ptr `poke` elementTypeOf elementData+ case elementData of+ IpRanges x -> with x $ \pX -> poke (ppElement ptr) pX >> f+ SecondaryHosts x -> withDhcp hostInfo x $ \pX -> poke (ppElement ptr) pX >> f+ ReservedIps x -> withDhcp reservation x $ \pX -> poke (ppElement ptr) pX >> f+ ExcludedIpRanges x -> with x $ \pX -> poke (ppElement ptr) pX >> f+ IpUsedCluster x -> with x $ \pX -> poke (ppElement ptr) pX >> f++ppElement :: Ptr SUBNET_ELEMENT_DATA_V4 -> Ptr a+ppElement ptr = castPtr $ ptr `plusPtr` 4++elementTypeOf :: SUBNET_ELEMENT_DATA_V4 -> SUBNET_ELEMENT_TYPE+elementTypeOf (IpRanges _) = 0+elementTypeOf (SecondaryHosts _) = 1+elementTypeOf (ReservedIps _) = 2+elementTypeOf (ExcludedIpRanges _) = 3+elementTypeOf (IpUsedCluster _) = 4
+ src/System/Win32/DHCP/SUBNET_ELEMENT_INFO_ARRAY_V4.hs view
@@ -0,0 +1,22 @@+module System.Win32.DHCP.SUBNET_ELEMENT_INFO_ARRAY_V4+ ( SUBNET_ELEMENT_INFO_ARRAY_V4 (..)+ , infoArray+ ) where++import System.Win32.DHCP.DhcpStructure+import System.Win32.DHCP.LengthBuffer+import System.Win32.DHCP.SUBNET_ELEMENT_DATA_V4++-- typedef struct _DHCP_SUBNET_ELEMENT_INFO_ARRAY_V4 {+-- DWORD NumElements;+-- LPDHCP_SUBNET_ELEMENT_DATA_V4 Elements;+-- } DHCP_SUBNET_ELEMENT_INFO_ARRAY_V4, *LPDHCP_SUBNET_ELEMENT_INFO_ARRAY_V4;+newtype SUBNET_ELEMENT_INFO_ARRAY_V4+ = SUBNET_ELEMENT_INFO_ARRAY_V4 (LengthBuffer SUBNET_ELEMENT_DATA_V4)++unwrap :: SUBNET_ELEMENT_INFO_ARRAY_V4 -> LengthBuffer SUBNET_ELEMENT_DATA_V4+unwrap (SUBNET_ELEMENT_INFO_ARRAY_V4 ia) = ia++infoArray :: DhcpStructure SUBNET_ELEMENT_INFO_ARRAY_V4+infoArray = newtypeDhcpStructure SUBNET_ELEMENT_INFO_ARRAY_V4 unwrap+ $ lengthBuffer (baseDhcpArray subnetElementData)
+ src/System/Win32/DHCP/Types.hs view
@@ -0,0 +1,73 @@+module System.Win32.DHCP.Types+ ( ClientType (..)+ , DATE_TIME (..)+ , FORCE_FLAG (..)+ , RESUME_HANDLE+ ) where++import Import++-- | Microsoft's DHCP server supports DHCP and BOOTP. Both protocols server+-- similar purposes, but DHCP is more widely used. Lease and reservation+-- records contain a flag field indicating which protocol the record is valid+-- for. In most cases this flag will be `Both`, because that is the default+-- behavior.+data ClientType = Unspecified | Dhcp | Bootp | Both | ReservationFlag | None+ deriving (Eq)++instance Enum ClientType where+ toEnum 0x00 = Unspecified+ toEnum 0x01 = Dhcp+ toEnum 0x02 = Bootp+ toEnum 0x03 = Both+ toEnum 0x04 = ReservationFlag+ toEnum 0x64 = None+ toEnum x = error $ "invalid ClientType: " ++ show x+ fromEnum Unspecified = 0x00+ fromEnum Dhcp = 0x01+ fromEnum Bootp = 0x02+ fromEnum Both = 0x03+ fromEnum ReservationFlag = 0x04+ fromEnum None = 0x64++instance Storable ClientType where+ sizeOf _ = sizeOf (undefined :: BYTE)+ alignment _ = alignment (undefined :: BYTE)+ peek ptr = toEnum . fromIntegral <$> peek (pbyte ptr)+ poke ptr ct = poke (pbyte ptr) . fromIntegral . fromEnum $ ct++pbyte :: Ptr ClientType -> Ptr BYTE+pbyte = castPtr++-- | The number of ticks (100-nanosecond increments) since 12:00 midnight,+-- January 1, 1 C.E. in the Gregorian calendar.+--+-- Microsoft does not provide any functions I know of for converting this+-- value into something more convenient to work with.+--+-- > typedef struct _DATE_TIME {+-- > DWORD dwLowDateTime;+-- > DWORD dwHighDateTime;+-- > } DATE_TIME,*PDATE_TIME, *LPDATE_TIME;+data DATE_TIME = DATE_TIME !DWORD !DWORD++instance Storable DATE_TIME where+ sizeOf _ = 8+ alignment _ = 4+ peek ptr = DATE_TIME <$> peekElemOff (pdword ptr) 0+ <*> peekElemOff (pdword ptr) 1+ poke ptr (DATE_TIME l h) = do+ pokeElemOff (pdword ptr) 0 l+ pokeElemOff (pdword ptr) 1 h++pdword :: Ptr DATE_TIME -> Ptr DWORD+pdword ptr = castPtr ptr++-- typedef enum _DHCP_FORCE_FLAG {+-- DhcpFullForce,+-- DhcpNoForce+-- } DHCP_FORCE_FLAG, *LPDHCP_FORCE_FLAG;+data FORCE_FLAG = FullForce | NoForce+ deriving (Enum)++type RESUME_HANDLE = DWORD