Win32-dhcp-server 0.3.1 → 0.3.2
raw patch · 20 files changed
+1681/−1669 lines, 20 files
Files
- ChangeLog +29/−23
- Win32-dhcp-server.cabal +82/−82
- src/Data/Ip.hs +79/−79
- src/Data/Mac.hs +118/−118
- src/Import.hs +3/−4
- src/System/Win32/DHCP.hs +342/−342
- src/System/Win32/DHCP/CLIENT_UID.hs +57/−56
- src/System/Win32/DHCP/Client.hs +118/−117
- src/System/Win32/DHCP/DhcpStructure.hs +185/−185
- src/System/Win32/DHCP/HOST_INFO.hs +53/−53
- src/System/Win32/DHCP/IP_CLUSTER.hs +21/−21
- src/System/Win32/DHCP/IP_RANGE.hs +20/−20
- src/System/Win32/DHCP/Internal.hs +151/−151
- src/System/Win32/DHCP/LengthBuffer.hs +58/−58
- src/System/Win32/DHCP/Reservation.hs +83/−78
- src/System/Win32/DHCP/SEARCH_INFO.hs +67/−67
- src/System/Win32/DHCP/SUBNET_CLIENT_INFO_ARRAY_V4.hs +22/−22
- src/System/Win32/DHCP/SUBNET_ELEMENT_DATA_V4.hs +98/−98
- src/System/Win32/DHCP/SUBNET_ELEMENT_INFO_ARRAY_V4.hs +22/−22
- src/System/Win32/DHCP/Types.hs +73/−73
ChangeLog view
@@ -1,23 +1,29 @@-0.3.1-=====--* updated documentation-* internal refactoring--0.3-===--* Update to support GHC 7.6 - 7.10-* Expose freeDHCP function--0.2.1-=====--* bug fix: Internal memory structures were not being freed properly.--0.2-===--* All functions throw Win32Exception exceptions.-* strict Text values are favored over String-* drop dependency on safe+0.3.2 +===== + +* internal code documentation +* small internal code refactorings + +0.3.1 +===== + +* updated documentation +* internal refactoring + +0.3 +=== + +* Update to support GHC 7.6 - 7.10 +* Expose freeDHCP function + +0.2.1 +===== + +* bug fix: Internal memory structures were not being freed properly. + +0.2 +=== + +* All functions throw Win32Exception exceptions. +* strict Text values are favored over String +* drop dependency on safe
Win32-dhcp-server.cabal view
@@ -1,82 +1,82 @@-Name: Win32-dhcp-server-Synopsis: Win32 DHCP Server Management API-Version: 0.3.1-License: BSD3-License-file: LICENSE-Author: Michael Steele-Maintainer: mikesteele81@gmail.com-Copyright: Copyright 2013-2015 Michael Steele-Homepage: http://github.com/mikesteele81/win32-dhcp-server-Bug-Reports: http://github.com/mikesteele81/win32-dhcp-server/issues-Category: System-Build-type: Simple-Cabal-version: >=1.16-Tested-With: GHC == 7.6.3, GHC == 7.8.3, GHC == 7.10.1-Stability: provisional-Description:- 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._Only 32-bit versions of GHC are- supported at this time._- .- Here are a few notes on the required environment:- .- * Only 32-bit executables are supported. This is mainly because pointers- are assumed to be 4 bytes wide in a few places. Support for 64-bit- executables may be added in the future.- .- * All library calls should be supported on Windows 7 or above.- .- /Simple Example and Usage/- .- @- \-\- Print all MAC addresses with an active client lease- module Main where- .- import Data.Ip- import Data.Mac- import qualified Data.Text.IO as T- import System.Win32.DHCP- .- main :: IO ()- main = do-   api <- loadDHCP-   clients <- enumClients api context-   let macs = map (showMac \":\" . clientHardwareAddress) clients-   mapM_ T.putStrLn macs-   where-   Right subnet = readIp \"192.168.1.0\"-   context = Context \"192.168.1.5\" subnet- @-extra-source-files:- ChangeLog- examples/*.hs--Library- Build-depends: base >= 4.6 && < 4.9- , text >= 0.11 && < 1.3- , 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:- 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+Name: Win32-dhcp-server +Synopsis: Win32 DHCP Server Management API +Version: 0.3.2 +License: BSD3 +License-file: LICENSE +Author: Michael Steele +Maintainer: mikesteele81@gmail.com +Copyright: Copyright 2013-2015 Michael Steele +Homepage: http://github.com/mikesteele81/win32-dhcp-server +Bug-Reports: http://github.com/mikesteele81/win32-dhcp-server/issues +Category: System +Build-type: Simple +Cabal-version: >=1.16 +Tested-With: GHC == 7.10.2 +Stability: provisional +Description: + 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._Only 32-bit versions of GHC are + supported at this time._ + . + Here are a few notes on the required environment: + . + * Only 32-bit executables are supported. This is mainly because pointers + are assumed to be 4 bytes wide in a few places. Support for 64-bit + executables may be added in the future. + . + * All library calls should be supported on Windows 7 or above. + . + /Simple Example and Usage/ + . + @ + \-\- Print all MAC addresses with an active client lease + module Main where + . + import Data.Ip + import Data.Mac + import qualified Data.Text.IO as T + import System.Win32.DHCP + . + main :: IO () + main = do +   api <- loadDHCP +   clients <- enumClients api context +   let macs = map (showMac \":\" . clientHardwareAddress) clients +   mapM_ T.putStrLn macs +   where +   Right subnet = readIp \"192.168.1.0\" +   context = Context \"192.168.1.5\" subnet + @ +extra-source-files: + ChangeLog + examples/*.hs + +Library + Build-depends: base >= 4.6 && < 4.9 + , text >= 0.11 && < 1.3 + , 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: + 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
@@ -1,79 +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+{-# 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
@@ -1,118 +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))+{-# 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
@@ -37,7 +37,6 @@ , 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 @@ -56,17 +55,17 @@ withTString :: Text -> (LPTSTR -> IO a) -> IO a withTString text act = withTStringLen text $ \ptr _ -> act ptr --- | Suppress the 'Left' value of an 'Either' +-- |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 +-- |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 +-- |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)
src/System/Win32/DHCP.hs view
@@ -1,342 +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)+{-# 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
@@ -1,56 +1,57 @@-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+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. Microsoft does not document this, +-- but it can be determined through experimentation. +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
@@ -1,117 +1,118 @@-{-# 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+{-# 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. The CLIENT_UID + -- structure is inlined into ClientInfo. + 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
@@ -1,185 +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+{-# 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
@@ -1,53 +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+{-# 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
@@ -1,21 +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+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
@@ -1,20 +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+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
@@ -1,151 +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+{-# 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
@@ -1,58 +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+{-# 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
@@ -1,78 +1,83 @@-{-# 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+{-# 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' + -- I arrived at this size through experimentation. It seems like the + -- size should be 12, but that is not the case. + , 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 p = plusPtr p 4 + +pClientType :: Ptr Reservation -> Ptr ClientType +pClientType p = plusPtr p 8 + +withReservation' :: Reservation -> Ptr Reservation + -> IO r -> IO r +withReservation' (Reservation (Mapping mac address) clientType) ptr f = + withMac mac $ \pCuid -> do + poke (castPtr ptr) address + ppCuid ptr `poke` pCuid + pClientType ptr `poke` clientType + f
src/System/Win32/DHCP/SEARCH_INFO.hs view
@@ -1,67 +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+{-# 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
@@ -1,22 +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)+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
@@ -1,98 +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+{-# 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
@@ -1,22 +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)+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
@@ -1,73 +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+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