Win32-dhcp-server 0.2 → 0.2.1

raw patch · 18 files changed

+1678/−1628 lines, 18 filesdep ~Win32

Dependency ranges changed: Win32

Files

ChangeLog +11/−6
Data/Ip.hs +81/−81
Data/Mac.hs +121/−121
System/Win32/DHCP.hs +358/−357
System/Win32/DHCP/Client.hs +122/−117
System/Win32/DHCP/DhcpStructure.hs +187/−177
System/Win32/DHCP/HOST_INFO.hs +58/−56
System/Win32/DHCP/IP_CLUSTER.hs +25/−25
System/Win32/DHCP/IP_RANGE.hs +22/−22
System/Win32/DHCP/Internal.hs +151/−151
System/Win32/DHCP/LengthBuffer.hs +63/−51
System/Win32/DHCP/Reservation.hs +81/−81
System/Win32/DHCP/SEARCH_INFO.hs +68/−68
System/Win32/DHCP/SUBNET_ELEMENT_DATA_V4.hs +102/−100
System/Win32/DHCP/Types.hs +76/−76
Utils.hs +51/−38
Win32-dhcp-server.cabal +79/−79
examples/cabal.hs +22/−22

ChangeLog view

@@ -1,6 +1,11 @@-0.2
-===
-
-* All functions throw Win32Exception exceptions.
-* strict Text values are favored over String
-* drop dependency on safe
+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

Data/Ip.hs view

@@ -1,81 +1,81 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE OverloadedStrings #-}
-
--- | This module was taken, with modifications, from the
--- <http://hackage.haskell.org/package/maccatcher maccatcher> package.
-module Data.Ip
-    ( Ip ()
-    -- * String conversions
-    , readIp
-    , showIp
-    -- * Octet conversions
-    , fromOctets
-    , toOctets
-    -- * Other conversions
-    , toWord32
-    ) where
-
-import Control.Applicative
-import Control.Monad (unless)
-import Data.Bits
-import Data.Text (Text)
-import qualified Data.Text as T
-import Data.Text.Read
-import Data.Word
-import Foreign
-
-import Utils (fmapL, note)
-
--- |An Ip can be used as an IP address or subnet address.
---
--- A `Show` instance is omitted to avoid confusion. Use `showIp` and `readIp`
--- to convert between `String`s.
-newtype Ip = Ip {unIp :: Word32}
-   deriving (Eq, Ord, Bounded, Storable)
-
--- |Represent an `Ip` as a `String`.
---
--- >>> showIp $ fromOctets 192 168 1 100
--- "192.168.1.100"
-showIp :: Ip -> Text
-showIp ip = T.intercalate "." . map (T.pack . show) $ [a, b, c, d]
-  where (a, b, c, d) = toOctets ip
-
--- |Parse a `Text` value as an `Ip`. The string should be of the form
--- "X.X.X.X" where each 'X' is a decimal value between 0 and 255 inclusive.
---
--- >>> let Right ip = readIp "192.168.1.100"
--- >>> toOctets ip
--- (192, 168, 1, 100)
-readIp :: Text -> Either String Ip
-readIp s = fmapL (\e -> "Error parsing IP address: " ++ e) $ do
-   (a, s2) <- decimal s
-   (b, s3) <- dot s2 >>= decimal
-   (c, s4) <- dot s3 >>= decimal
-   (d, s5) <- dot s4 >>= decimal
-   unless (s5 == "") $ Left "exactly 4 octets were expected."
-   -- Confirm that all digits are in range
-   fromOctets <$> digit a <*> digit b <*> digit c <*> digit d
-  where
-    dot = note "Expected '.' character." . T.stripPrefix "."
-    digit :: Int -> Either String Word8
-    digit x | x < 0 || x > 255 = Left "digit out of range."
-            | otherwise = Right $ fromIntegral x
-
--- |An IP address is 32-bits wide. This function will construct an `Ip` from
--- 4 octets.
-fromOctets :: Word8 -> Word8 -> Word8 -> Word8 -> Ip
-fromOctets a b c d = Ip
-      $ (fromIntegral a `shiftL` 24)
-    .|. (fromIntegral b `shiftL` 16)
-    .|. (fromIntegral c `shiftL` 8)
-    .|. (fromIntegral d)
-
--- |Extract each of the 4 octets from an `Ip`.
-toOctets :: Ip -> (Word8, Word8, Word8, Word8)
-toOctets (Ip word) = (byte 3 word, byte 2 word, byte 1 word, byte 0 word)
-  where
-    byte i w = fromIntegral (w `shiftR` (i * 8))
-
-toWord32 :: Ip -> Word32
-toWord32 = unIp
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverloadedStrings #-}++-- | This module was taken, with modifications, from the+-- <http://hackage.haskell.org/package/maccatcher maccatcher> package.+module Data.Ip+    ( Ip ()+    -- * String conversions+    , readIp+    , showIp+    -- * Octet conversions+    , fromOctets+    , toOctets+    -- * Other conversions+    , toWord32+    ) where++import Control.Applicative+import Control.Monad (unless)+import Data.Bits+import Data.Text (Text)+import qualified Data.Text as T+import Data.Text.Read+import Data.Word+import Foreign++import Utils (fmapL, note)++-- |An Ip can be used as an IP address or subnet address.+--+-- A `Show` instance is omitted to avoid confusion. Use `showIp` and `readIp`+-- to convert between `String`s.+newtype Ip = Ip {unIp :: Word32}+   deriving (Eq, Ord, Bounded, Storable)++-- |Represent an `Ip` as a `String`.+--+-- >>> showIp $ fromOctets 192 168 1 100+-- "192.168.1.100"+showIp :: Ip -> Text+showIp ip = T.intercalate "." . map (T.pack . show) $ [a, b, c, d]+  where (a, b, c, d) = toOctets ip++-- |Parse a `Text` value as an `Ip`. The string should be of the form+-- "X.X.X.X" where each 'X' is a decimal value between 0 and 255 inclusive.+--+-- >>> let Right ip = readIp "192.168.1.100"+-- >>> toOctets ip+-- (192, 168, 1, 100)+readIp :: Text -> Either String Ip+readIp s = fmapL (\e -> "Error parsing IP address: " ++ e) $ do+   (a, s2) <- decimal s+   (b, s3) <- dot s2 >>= decimal+   (c, s4) <- dot s3 >>= decimal+   (d, s5) <- dot s4 >>= decimal+   unless (s5 == "") $ Left "exactly 4 octets were expected."+   -- Confirm that all digits are in range+   fromOctets <$> digit a <*> digit b <*> digit c <*> digit d+  where+    dot = note "Expected '.' character." . T.stripPrefix "."+    digit :: Int -> Either String Word8+    digit x | x < 0 || x > 255 = Left "digit out of range."+            | otherwise = Right $ fromIntegral x++-- |An IP address is 32-bits wide. This function will construct an `Ip` from+-- 4 octets.+fromOctets :: Word8 -> Word8 -> Word8 -> Word8 -> Ip+fromOctets a b c d = Ip+      $ (fromIntegral a `shiftL` 24)+    .|. (fromIntegral b `shiftL` 16)+    .|. (fromIntegral c `shiftL` 8)+    .|. (fromIntegral d)++-- |Extract each of the 4 octets from an `Ip`.+toOctets :: Ip -> (Word8, Word8, Word8, Word8)+toOctets (Ip word) = (byte 3 word, byte 2 word, byte 1 word, byte 0 word)+  where+    byte i w = fromIntegral (w `shiftR` (i * 8))++toWord32 :: Ip -> Word32+toWord32 = unIp

Data/Mac.hs view

@@ -1,121 +1,121 @@-{-# LANGUAGE OverloadedStrings #-}
-
--- | This module was taken, with modifications, from the
--- <http://hackage.haskell.org/package/maccatcher maccatcher> package.
-module Data.Mac
-    ( Mac ()
-    -- ** String conversions
-    , readMac
-    , showMac
-    -- ** Octet conversions
-    , fromOctets
-    , toOctets
-    -- ** Other conversions
-    , toWord64
-    ) where
-
-import Control.Applicative
-import Control.Monad (unless)
-import Data.Bits
-import Data.Monoid
-import Data.Text (Text)
-import qualified Data.Text as T
-import qualified Data.Text.Lazy as L
-import qualified Data.Text.Lazy.Builder as L
-import qualified Data.Text.Lazy.Builder.Int as L
-import Data.Text.Read
-import Data.Word
-import Foreign
-
-import Utils
-
--- |A Mac is a 6-byte unique identifier used in layer-two network addressing.
--- Its `Storable` instance occupies 6 bytes of memory when `poke`d with the
--- first byte occupying the lowest address, and the last byte occupying the
--- highest address.
---
--- A `Show` instance is omitted to avoid confusion. Use `showMac` and
--- `readMac` to convert between `String`s.
-newtype Mac =  Mac { unMac :: Word64 }
-   deriving (Bounded, Eq, Ord)
-
-instance Storable Mac where
-  sizeOf _ =  6
-  alignment _ =  1
-  peek p =  fromOctets <$> (peek $ castPtr p) <*> peekByteOff p 1
-      <*> peekByteOff p 2 <*> peekByteOff p 3 <*> peekByteOff p 4
-      <*> peekByteOff p 5
-  poke p mac   =  do
-    poke (castPtr p) a
-    pokeByteOff p 1 b
-    pokeByteOff p 2 c
-    pokeByteOff p 3 d
-    pokeByteOff p 4 e
-    pokeByteOff p 5 f
-    where
-      (a, b, c, d, e, f) = toOctets mac
-
-toWord64 :: Mac -> Word64
-toWord64 = unMac
-
--- |Represent a `Mac` as a `String`. The supplied separator will be placed
--- between each octet in the final output.
---
--- >>> showMac "" $ fromOctets 0xa 0xb 0xc 0xd 0xe 0xf
--- "0a0b0c0d0e0f"
---
--- >>> showMac ":" $ fromOctets 0x11 0x22 0x33 0x44 0x55 0x66
--- "11:22:33:44:55:66"
-showMac :: Text -> Mac -> Text
-showMac sep mac = T.intercalate sep . map octet $ [a, b, c, d, e, f]
-  where
-    octet x = pad (2 :: Int) . L.toStrict . L.toLazyText . L.hexadecimal $ x
-    (a, b, c, d, e, f) = toOctets mac
-    pad n str = T.replicate (max 0 (n - T.length str)) "0" <> str
-
--- |Parse a `Text` value as a `Mac`. The string should not use any
--- separators between octets.
---
--- >>> let Right mac = readMac "000102030405"
--- >>> toOctets mac
--- (0, 1, 2, 3, 4, 5)
-readMac :: Text -> Either String Mac
-readMac s = fmapL (\e -> "Error parsing MAC address: " ++ e) $ do
-    (a, s2) <- octet s
-    (b, s3) <- octet s2
-    (c, s4) <- octet s3
-    (d, s5) <- octet s4
-    (e, s6) <- octet s5
-    (f, s7) <- octet s6
-    unless (s7 == "") $ Left "exactly 6 octets were expected."
-    fromOctets <$> digit a <*> digit b <*> digit c
-               <*> digit d <*> digit e <*> digit f
-  where
-    octet :: Text -> Either String (Int, Text)
-    octet s0 = do
-        (a, s2) <- hexadecimal a0
-        unless (s2 == "") $ Left "invalid characters"
-        return (a, rest)
-      where
-        (a0, rest) = T.splitAt 2 s0
-    digit :: Int -> Either String Word8
-    digit x | x < 0 || x > 255 = Left "digit out of range."
-            | otherwise = Right $ fromIntegral x
-
--- |A Mac address is 48-bits wide. This function will construct a `Mac` from
--- 6 octets.
-fromOctets :: Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Mac
-fromOctets a b c d e f = Mac
-      $ (fromIntegral a `shiftL` 40)
-    .|. (fromIntegral b `shiftL` 32)
-    .|. (fromIntegral c `shiftL` 24)
-    .|. (fromIntegral d `shiftL` 16)
-    .|. (fromIntegral e `shiftL` 8)
-    .|. (fromIntegral f)
-
--- |Extract each of the 6 octets from a `Mac`.
-toOctets :: Mac -> (Word8, Word8, Word8, Word8, Word8, Word8)
-toOctets (Mac word) = ( byte 5 word, byte 4 word, byte 3 word
-                      , byte 2 word, byte 1 word, byte 0 word)
-  where
-    byte i w = fromIntegral (w `shiftR` (i * 8))
+{-# LANGUAGE OverloadedStrings #-}++-- | This module was taken, with modifications, from the+-- <http://hackage.haskell.org/package/maccatcher maccatcher> package.+module Data.Mac+    ( Mac ()+    -- ** String conversions+    , readMac+    , showMac+    -- ** Octet conversions+    , fromOctets+    , toOctets+    -- ** Other conversions+    , toWord64+    ) where++import Control.Applicative+import Control.Monad (unless)+import Data.Bits+import Data.Monoid+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.Lazy as L+import qualified Data.Text.Lazy.Builder as L+import qualified Data.Text.Lazy.Builder.Int as L+import Data.Text.Read+import Data.Word+import Foreign++import Utils++-- |A Mac is a 6-byte unique identifier used in layer-two network addressing.+-- Its `Storable` instance occupies 6 bytes of memory when `poke`d with the+-- first byte occupying the lowest address, and the last byte occupying the+-- highest address.+--+-- A `Show` instance is omitted to avoid confusion. Use `showMac` and+-- `readMac` to convert between `String`s.+newtype Mac =  Mac { unMac :: Word64 }+   deriving (Bounded, Eq, Ord)++instance Storable Mac where+  sizeOf _ =  6+  alignment _ =  1+  peek p =  fromOctets <$> (peek $ castPtr p) <*> peekByteOff p 1+      <*> peekByteOff p 2 <*> peekByteOff p 3 <*> peekByteOff p 4+      <*> peekByteOff p 5+  poke p mac   =  do+    poke (castPtr p) a+    pokeByteOff p 1 b+    pokeByteOff p 2 c+    pokeByteOff p 3 d+    pokeByteOff p 4 e+    pokeByteOff p 5 f+    where+      (a, b, c, d, e, f) = toOctets mac++toWord64 :: Mac -> Word64+toWord64 = unMac++-- |Represent a `Mac` as a `String`. The supplied separator will be placed+-- between each octet in the final output.+--+-- >>> showMac "" $ fromOctets 0xa 0xb 0xc 0xd 0xe 0xf+-- "0a0b0c0d0e0f"+--+-- >>> showMac ":" $ fromOctets 0x11 0x22 0x33 0x44 0x55 0x66+-- "11:22:33:44:55:66"+showMac :: Text -> Mac -> Text+showMac sep mac = T.intercalate sep . map octet $ [a, b, c, d, e, f]+  where+    octet x = pad (2 :: Int) . L.toStrict . L.toLazyText . L.hexadecimal $ x+    (a, b, c, d, e, f) = toOctets mac+    pad n str = T.replicate (max 0 (n - T.length str)) "0" <> str++-- |Parse a `Text` value as a `Mac`. The string should not use any+-- separators between octets.+--+-- >>> let Right mac = readMac "000102030405"+-- >>> toOctets mac+-- (0, 1, 2, 3, 4, 5)+readMac :: Text -> Either String Mac+readMac s = fmapL (\e -> "Error parsing MAC address: " ++ e) $ do+    (a, s2) <- octet s+    (b, s3) <- octet s2+    (c, s4) <- octet s3+    (d, s5) <- octet s4+    (e, s6) <- octet s5+    (f, s7) <- octet s6+    unless (s7 == "") $ Left "exactly 6 octets were expected."+    fromOctets <$> digit a <*> digit b <*> digit c+               <*> digit d <*> digit e <*> digit f+  where+    octet :: Text -> Either String (Int, Text)+    octet s0 = do+        (a, s2) <- hexadecimal a0+        unless (s2 == "") $ Left "invalid characters"+        return (a, rest)+      where+        (a0, rest) = T.splitAt 2 s0+    digit :: Int -> Either String Word8+    digit x | x < 0 || x > 255 = Left "digit out of range."+            | otherwise = Right $ fromIntegral x++-- |A Mac address is 48-bits wide. This function will construct a `Mac` from+-- 6 octets.+fromOctets :: Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Mac+fromOctets a b c d e f = Mac+      $ (fromIntegral a `shiftL` 40)+    .|. (fromIntegral b `shiftL` 32)+    .|. (fromIntegral c `shiftL` 24)+    .|. (fromIntegral d `shiftL` 16)+    .|. (fromIntegral e `shiftL` 8)+    .|. (fromIntegral f)++-- |Extract each of the 6 octets from a `Mac`.+toOctets :: Mac -> (Word8, Word8, Word8, Word8, Word8, Word8)+toOctets (Mac word) = ( byte 5 word, byte 4 word, byte 3 word+                      , byte 2 word, byte 1 word, byte 0 word)+  where+    byte i w = fromIntegral (w `shiftR` (i * 8))

System/Win32/DHCP.hs view

@@ -1,357 +1,358 @@-{-# LANGUAGE OverloadedStrings #-}
-
--- |
--- module: System.Win32.DHCP
--- copyright: (c) Michael Steele, 2014
--- license: BSD3
--- maintainer: mikesteele81@gmail.com
--- stability: experimental
--- portability: Windows
-module System.Win32.DHCP
-    ( DhcpApi ()
-    , loadDHCP
-    -- * General Types
-    , Context (..)
-    , ClientType (..)
-    , DATE_TIME (..)
-    , HOST_INFO (..)
-    , SEARCH_INFO (..)
-    -- * Leases
-    , Client (..)
-    , enumClients
-    , lookupClient
-    , deleteClient
-    -- * Reservations
-    , Mapping (..)
-    , Reservation(..)
-    , addReservation
-    , enumReservations
-    , removeReservation
-    ) where
-
-import Control.Applicative
-import Control.Monad (unless)
-import Data.Char (chr)
-import Data.Text (Text)
-import qualified Data.Text as T
-import qualified Data.Text.Foreign as T
-import Foreign
-import Foreign.C.Types
-
-import System.Win32.Types hiding (withTString, withTStringLen)
-import qualified System.Win32.Error as E
-import qualified System.Win32.Error.Foreign as E
-
-import Data.Ip
-import System.Win32.DHCP.DhcpStructure
-import System.Win32.DHCP.HOST_INFO
-import System.Win32.DHCP.Internal
-import System.Win32.DHCP.Client
-import System.Win32.DHCP.LengthBuffer
-import System.Win32.DHCP.Reservation
-import System.Win32.DHCP.SEARCH_INFO
-import System.Win32.DHCP.SUBNET_CLIENT_INFO_ARRAY_V4
-import System.Win32.DHCP.SUBNET_ELEMENT_DATA_V4
-import System.Win32.DHCP.SUBNET_ELEMENT_INFO_ARRAY_V4
-import System.Win32.DHCP.Types
-
--- | A Context defines which server and scope within that server a command
--- refers to.  Microsoft's DHCP server supports multiple scopes. This allows
--- different configurations to be sent to devices based on their hardware
--- (MAC) address.  Scopes are identified by their network address.
-data Context = Context
-    { -- | The DHCP server management API uses an RPC mechanism to control the
-      -- server.
-      contextServer :: !Text
-    , -- | Scopes are identified by a subnet identifier. This is useful in
-      -- cases where multiple scopes are defined, but still required in the
-      -- common case of a single scope.
-      contextSubnet :: !Ip
-    } deriving (Eq, Ord)
-
--- | Delete an active DHCP lease from the server.
--- The `SEARCH_INFO` argument determines which search criteria
--- to use. Searching by name will delete all active leases
--- with that name. This action corresponds to MSDN's DhcpDeleteClientInfoV4
--- function.
-deleteClient :: DhcpApi
-    -> Text
-    -- ^ String which specifies the IP address or hostname of the DHCP
-    -- server.
-    -> SEARCH_INFO
-    -- ^ Define how to lookup a client to delete. Only deleting based on
-    -- IP addresses have been tested.
-    -> IO ()
-    -- ^ This function will throw an 'E.Win32Exception' when the internal Win32
-    -- call returnes an error condition. MSDN lists the following exceptions,
-    -- but others might be thrown as well:
-    --
-    --   ['E.DhcpReservedClient'] The specified DHCP client is a reserved DHCP
-    --   client.
-    --
-    --   ['E.DhcpJetError'] An error occurred while accessing the DHCP server
-    --   database, or the client entry is not present in the database.
-deleteClient api server si =
-    withTString server $ \pserver ->
-    withSearchInfo si $ \psi ->
-    E.failUnlessSuccess "DeleteClientInfo"
-    $ c_DeleteClientInfo api pserver psi
-
--- | Perform a lookup operation for all client lease records within a
--- scope. This action corresponds to MSDN's DhcpEnumSubnetClientsV4 function.
-enumClients :: DhcpApi
-    -> Context
-    -- ^ Specify which server and scope to search for client leases.
-    -> IO [Client]
-    -- ^ The empty list means that no client records exist for the provided
-    -- subnet. This function will throw an 'E.Win32Exception' when the
-    -- internal Win32 call returnes an error condition. MSDN lists the
-    -- following exceptions, but others might be thrown as well:
-    --
-    --   ['E.DhcpJetError'] An error occurred while accessing the DHCP server
-    --   database.
-enumClients dhcp (Context server subnet) =
-    enumSubnetClientsV4 dhcp server subnet
-
--- | Search the DHCP server for a lease matching the given search criteria.
--- `Nothing` is returned when no lease was found. This corresponds to MSDN's
--- DhcpGetClientInfoV4 function.
-lookupClient :: DhcpApi
-    -> Text
-    -- ^ According to MSDN this must specify the IP address of the server.
-    -- Other functions (including this one) may or may not also accept
-    -- a Unicode host name.
-    -> SEARCH_INFO
-    -- ^ Define how to lookup a client. Only searching based on an
-    -- IP addresses has been tested.
-    -> IO (Maybe Client)
-    -- ^ A `Nothing` indicates that no client was found. This function will throw an 'E.Win32Exception' when the
-    -- internal Win32 call returnes an error condition. MSDN lists the
-    -- following exceptions, but others might be thrown as well:
-    --
-    --   ['E.DhcpJetError'] An error occurred while accessing the DHCP server
-    --   database.
-lookupClient api serverip si =
-    withTString serverip $ \pserverip ->
-    withSearchInfo si $ \psi ->
-    with nullPtr $ \ppclientinfo -> do
-    -- DhcpGetClientInfo takes a structure on the stack.
-    siType <- peek (castPtr psi :: Ptr CInt)
-    siPayload <- peekElemOff (castPtr psi :: Ptr (Ptr ())) 4
-    E.failUnlessSuccess "GetClientInfoV4"
-        $ c_GetClientInfoV4  api pserverip siType siPayload ppclientinfo
-    pclientinfo <- peek ppclientinfo
-    if pclientinfo == nullPtr
-      then return Nothing
-      else do
-        clientinfo <- peekDhcp clientInfo pclientinfo
-        freeDhcp clientInfo (rpcFreeMemory api) pclientinfo
-        poke (castPtr pclientinfo) nullPtr
-        return $ Just clientinfo
-
-addReservation :: DhcpApi -> Context -> Mapping
-    -> IO ()
-    -- ^ This function will throw an 'E.Win32Exception' when the internal Win32
-    -- call returnes an error condition. MSDN lists the following exceptions,
-    -- but others might be thrown as well:
-    --
-    --   ['E.DhcpSubnetNotPresent'] The specified IPv4 subnet does not exist
-    --   on the DHCP server.
-    --
-    --   ['E.DhcpJetError'] An error occurred while accessing the DHCP server
-    --   database.
-    --
-    --   ['E.DhcpNotReservedClient'] The specified DHCP client is not a
-    --   reserved client.
-    --
-    --   ['E.DhcpInvalidRange'] The specified IPv4 range does not match an
-    --   existing IPv4 range.
-    --
-    --   ['E.ScopeRangePolicyChangeConflict'] An IP address range is
-    --   configured for a policy in this scope. This operation cannot be
-    --   performed on the scope IP address range until the policy IP address
-    --   range is suitably modified.
-addReservation dhcp (Context server subnet) mapping =
-    addSubnetElementV4 dhcp server subnet
-    $ ReservedIps (Reservation mapping Both)
-
-enumReservations :: DhcpApi -> Context -> IO [Reservation]
-enumReservations dhcp (Context server subnet) = do
-    ex <- enumSubnetElementsV4 dhcp server subnet 2
-    res <- flip mapM ex $ \element -> do
-        case element of
-          ReservedIps res -> return res
-          _ -> error "bug in Win32 API."
-    return res
-
--- | Remove a reservation from the server
-removeReservation :: DhcpApi -> Context -> Mapping
-    -> ClientType
-    -- ^ Specify a DHCP reservation, BOOTP reservation, or both. This is untested.
-    -> Bool
-    -- ^ Specify whether any active leases for the reservation should be
-    -- removed as well.
-    -> IO ()
-    -- ^ This function will throw an 'E.Win32Exception' when the internal Win32
-    -- call returnes an error condition. MSDN lists the following exceptions,
-    -- but others might be thrown as well:
-    --
-    --   ['E.DhcpSubnetNotPresent'] The specified IPv4 subnet does not exist
-    --   on the DHCP server.
-    --
-    --   ['E.DhcpElementCantRemove'] Failure can occur for any number of
-    --   reasons.
-    --
-    --   ['E.DhcpJetError'] An error occurred while accessing the DHCP server
-    --   database.
-    --
-    --   ['E.DhcpInvalidRange'] The specified IPv4 range does not match an
-    --   existing IPv4 range.
-    --
-    --   ['E.ScopeRangePolicyChangeConflict'] An IP address range is
-    --   configured for a policy in this scope. This operation cannot be
-    --   performed on the scope IP address range until the policy IP address
-    --   range is suitably modified.
-removeReservation dhcp (Context server subnet) mapping ct force =
-    removeSubnetElementV4 dhcp server subnet
-    (ReservedIps $ Reservation mapping ct) fForce
- where
-   fForce = if force then FullForce else NoForce
-
-enumSubnetClientsV4 :: DhcpApi -> Text -> Ip -> IO [Client]
-enumSubnetClientsV4 dhcp server subnet =
-    withTString server $ \pServer ->
-    -- inout parameter. Supply on successive calls to retreive more elements
-    with 0 $ \pResumeHandle ->
-    alloca $ \pElementsRead ->
-    alloca $ \pElementsTotal ->
-    with nullPtr $ \ppInfoArray -> do
-    -- We have to call enumSubnetElementsV4 at least twice for a sucessfull run.
-    -- Failure to use the returned resumeHandle may result in an internal access
-    -- violation within RPCRT4.dll.
-    let loop acc = do
-            ret <- E.fromDWORD <$> c_EnumSubnetClientsV4 dhcp pServer (toWord32 subnet)
-                                   pResumeHandle 0xFFFFFFFF ppInfoArray
-                                   pElementsRead pElementsTotal
-            unless (elem ret [E.Success, E.MoreData, E.NoMoreItems])
-                $ E.failWith "EnumSubnetClientsV4" ret
-            pInfoArray <- peek ppInfoArray
-            elems <- if pInfoArray == nullPtr
-                     then return []
-                     else do
-                       SUBNET_CLIENT_INFO_ARRAY_V4 (LengthBuffer _ elems) <- peekDhcp clientInfoArray pInfoArray
-                       freeDhcp clientInfoArray (rpcFreeMemory dhcp) pInfoArray
-                       poke ppInfoArray nullPtr
-                       return elems
-            elementsTotal <- peek pElementsTotal
-            elementsRead <- peek pElementsRead
-            if (ret == E.NoMoreItems || (ret == E.Success && elementsTotal == elementsRead))
-              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 $ \ppEnumElementInfoArray -> do
-    -- We have to call enumSubnetElementsV4 at least twice for a sucessfull run.
-    -- Failure to use the returned resumeHandle may result in an internal access
-    -- violation within RPCRT4.dll.
-    let loop acc = do
-            ret <- E.fromDWORD <$> c_EnumSubnetElementsV4 dhcp pServer (toWord32 subnet) elementType
-                                   pResumeHandle 0xFFFFFFFF ppEnumElementInfoArray
-                                   pElementsRead pElementsTotal
-            unless (elem ret [E.Success, E.MoreData, E.NoMoreItems])
-                $ E.failWith "EnumSubnetElementsV4" ret
-            pEnumElementInfoArray <- peek ppEnumElementInfoArray
-            elems <- if pEnumElementInfoArray == nullPtr
-                     then return []
-                     else do
-                       SUBNET_ELEMENT_INFO_ARRAY_V4 (LengthBuffer _ elems) <- peekDhcp infoArray pEnumElementInfoArray
-                       freeDhcp infoArray (rpcFreeMemory dhcp) pEnumElementInfoArray
-                       poke ppEnumElementInfoArray nullPtr
-                       return elems
-            elementsTotal <- peek pElementsTotal
-            if (ret == E.NoMoreItems || (ret == E.Success && elementsTotal == 0))
-              then return (elems:acc)
-              else loop (elems:acc)
-
-    revelemss <- loop []
-    return $ concat $ reverse revelemss
-
-addSubnetElementV4 :: DhcpApi -> Text -> Ip -> SUBNET_ELEMENT_DATA_V4 -> IO ()
-addSubnetElementV4 dhcp server subnet elementData =
-    withTString server $ \pServer ->
-    withDhcp subnetElementData elementData $ \pElementData ->
-    E.failUnlessSuccess "AddSubnetElementsV4"
-    $ c_AddSubnetElementV4 dhcp pServer (toWord32 subnet) pElementData
-
--- | Remove an IPv4 subnet element from an IPv4 subnet defined on the DHCPv4
---   server.
-removeSubnetElementV4
-    :: DhcpApi
-    -> Text   -- ^ Unicode string that specifies the IP address, such as
-              --   \"123.456.789.012\", or hostname, such as \"server\",
-              --   of the DHCP server.
-    -> Ip -- ^ 'DWORD' value that specifies the IP address of the
-                  --   subnet gateway and uniquely identifies it. As an
-                  --   example, with the above IP address and a subnet mask
-                  --   of 255.255.255.0, the subnet would be 123.456.789.0.
-                  --   This must then be converted to a 'DWORD' value of
-                  --   2,093,683,968.
-    -> SUBNET_ELEMENT_DATA_V4 -- ^ 'DHCP_SUBNET_ELEMENT_DATA_V4' structure
-                              --   that contains information used to find the
-                              --   element that will be removed from subnet
-                              --   specified in SubnetAddress.
-    -> FORCE_FLAG -- ^ DHCP_FORCE_FLAG enumeration value that indicates
-                  --   whether or not the clients affected by the removal of
-                  --   the subnet element should also be deleted.
-                  --
-                  --   Note If the flag is set to DhcpNoForce and this subnet
-                  --   has served an IPv4 address to DHCPv4/BOOTP clients, the
-                  --   IPv4 range is not deleted; conversely, if the flag is
-                  --   set to DhcpFullForce, the IPv4 range is deleted along
-                  --   with the DHCPv4 client lease record on the DHCPv4
-                  --   server.
-    -> IO ()
-    -- ^ This function will throw an 'E.Win32Exception' when the internal Win32
-    -- call returnes an error condition. MSDN lists the following exceptions,
-    -- but others might be thrown as well:
-    --
-    --   ['E.DhcpSubnetNotPresent'] The specified IPv4 subnet does not exist
-    --   on the DHCP server.
-    --
-    --   ['E.DhcpElementCantRemove'] Failure can occur for any number of
-    --   reasons.
-    --
-    --   ['E.DhcpJetError'] An error occurred while accessing the DHCP server
-    --   database.
-    --
-    --   ['E.DhcpInvalidRange'] The specified IPv4 range does not match an
-    --   existing IPv4 range.
-    --
-    --   ['E.ScopeRangePolicyChangeConflict'] An IP address range is
-    --   configured for a policy in this scope. This operation cannot be
-    --   performed on the scope IP address range until the policy IP address
-    --   range is suitably modified.
-removeSubnetElementV4 dhcp server subnet elementData forceFlag =
-    withTString server $ \pServer ->
-    withDhcp subnetElementData elementData $ \pElementData ->
-    E.failUnlessSuccess "RemoveSubnetElementV4"
-    $ c_RemoveSubnetElementV4 dhcp pServer (toWord32 subnet) pElementData
-          (fromIntegral . fromEnum $ forceFlag)
-
-withTStringLen :: Text -> (LPTSTR -> T.I16 -> IO a) -> IO a
-withTStringLen text act = T.useAsPtr (T.snoc text (chr 0x0)) $ \ptr len ->
-    act (castPtr ptr) len
-
-withTString :: Text -> (LPTSTR -> IO a) -> IO a
-withTString text act = withTStringLen text $ \ptr _ -> do
-    act ptr
+{-# LANGUAGE OverloadedStrings #-}++-- |+-- module: System.Win32.DHCP+-- copyright: (c) Michael Steele, 2014+-- license: BSD3+-- maintainer: mikesteele81@gmail.com+-- stability: experimental+-- portability: Windows+module System.Win32.DHCP+    ( DhcpApi ()+    , loadDHCP+    -- * General Types+    , Context (..)+    , ClientType (..)+    , DATE_TIME (..)+    , HOST_INFO (..)+    , SEARCH_INFO (..)+    -- * Leases+    , Client (..)+    , enumClients+    , lookupClient+    , deleteClient+    -- * Reservations+    , Mapping (..)+    , Reservation(..)+    , addReservation+    , enumReservations+    , removeReservation+    ) where++import Control.Applicative+import Control.Monad (unless)+import Data.Char (chr)+import Data.Maybe (fromMaybe)+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.Foreign as T+import Foreign+import Foreign.C.Types++import System.Win32.Types hiding (withTString, withTStringLen)+import qualified System.Win32.Error as E+import qualified System.Win32.Error.Foreign as E++import Data.Ip+import System.Win32.DHCP.DhcpStructure+import System.Win32.DHCP.HOST_INFO+import System.Win32.DHCP.Internal+import System.Win32.DHCP.Client+import System.Win32.DHCP.LengthBuffer+import System.Win32.DHCP.Reservation+import System.Win32.DHCP.SEARCH_INFO+import System.Win32.DHCP.SUBNET_CLIENT_INFO_ARRAY_V4+import System.Win32.DHCP.SUBNET_ELEMENT_DATA_V4+import System.Win32.DHCP.SUBNET_ELEMENT_INFO_ARRAY_V4+import System.Win32.DHCP.Types+import Utils++-- | A Context defines which server and scope within that server a command+-- refers to.  Microsoft's DHCP server supports multiple scopes. This allows+-- different configurations to be sent to devices based on their hardware+-- (MAC) address.  Scopes are identified by their network address.+data Context = Context+    { -- | The DHCP server management API uses an RPC mechanism to control the+      -- server.+      contextServer :: !Text+    , -- | Scopes are identified by a subnet identifier. This is useful in+      -- cases where multiple scopes are defined, but still required in the+      -- common case of a single scope.+      contextSubnet :: !Ip+    } deriving (Eq, Ord)++-- | Delete an active DHCP lease from the server.+-- The `SEARCH_INFO` argument determines which search criteria+-- to use. Searching by name will delete all active leases+-- with that name. This action corresponds to MSDN's DhcpDeleteClientInfoV4+-- function.+deleteClient :: DhcpApi+    -> Text+    -- ^ String which specifies the IP address or hostname of the DHCP+    -- server.+    -> SEARCH_INFO+    -- ^ Define how to lookup a client to delete. Only deleting based on+    -- IP addresses have been tested.+    -> IO ()+    -- ^ This function will throw an 'E.Win32Exception' when the internal Win32+    -- call returnes an error condition. MSDN lists the following exceptions,+    -- but others might be thrown as well:+    --+    --   ['E.DhcpReservedClient'] The specified DHCP client is a reserved DHCP+    --   client.+    --+    --   ['E.DhcpJetError'] An error occurred while accessing the DHCP server+    --   database, or the client entry is not present in the database.+deleteClient api server si =+    withTString server $ \pserver ->+    withSearchInfo si $ \psi ->+    E.failUnlessSuccess "DeleteClientInfo"+    $ c_DeleteClientInfo api pserver psi++-- | Perform a lookup operation for all client lease records within a+-- scope. This action corresponds to MSDN's DhcpEnumSubnetClientsV4 function.+enumClients :: DhcpApi+    -> Context+    -- ^ Specify which server and scope to search for client leases.+    -> IO [Client]+    -- ^ The empty list means that no client records exist for the provided+    -- subnet. This function will throw an 'E.Win32Exception' when the+    -- internal Win32 call returnes an error condition. MSDN lists the+    -- following exceptions, but others might be thrown as well:+    --+    --   ['E.DhcpJetError'] An error occurred while accessing the DHCP server+    --   database.+enumClients dhcp (Context server subnet) =+    enumSubnetClientsV4 dhcp server subnet++-- | Search the DHCP server for a lease matching the given search criteria.+-- `Nothing` is returned when no lease was found. This corresponds to MSDN's+-- DhcpGetClientInfoV4 function.+lookupClient :: DhcpApi+    -> Text+    -- ^ According to MSDN this must specify the IP address of the server.+    -- Other functions (including this one) may or may not also accept+    -- a Unicode host name.+    -> SEARCH_INFO+    -- ^ Define how to lookup a client. Only searching based on an+    -- IP addresses has been tested.+    -> IO (Maybe Client)+    -- ^ A `Nothing` indicates that no client was found. This function will throw an 'E.Win32Exception' when the+    -- internal Win32 call returnes an error condition. MSDN lists the+    -- following exceptions, but others might be thrown as well:+    --+    --   ['E.DhcpJetError'] An error occurred while accessing the DHCP server+    --   database.+lookupClient api serverip si =+    withTString serverip $ \pserverip ->+    withSearchInfo si $ \psi ->+    with nullPtr $ \ppclientinfo -> do+    -- DhcpGetClientInfo takes a structure on the stack.+    siType <- peek (castPtr psi :: Ptr CInt)+    siPayload <- peekElemOff (castPtr psi :: Ptr (Ptr ())) 4+    E.failUnlessSuccess "GetClientInfoV4"+        $ c_GetClientInfoV4  api pserverip siType siPayload ppclientinfo++    -- Extract client information from out parameter and free the memory+    -- 'Nothing' will be returned the case where GetClientInfoV4 returns a+    -- null pointer.+    scrubWith ppclientinfo $ \pclientinfo -> do+        clientinfo <- peekDhcp clientInfo pclientinfo+        freeDhcp clientInfo (rpcFreeMemory api) pclientinfo+        return clientinfo++addReservation :: DhcpApi -> Context -> Mapping+    -> IO ()+    -- ^ This function will throw an 'E.Win32Exception' when the internal Win32+    -- call returnes an error condition. MSDN lists the following exceptions,+    -- but others might be thrown as well:+    --+    --   ['E.DhcpSubnetNotPresent'] The specified IPv4 subnet does not exist+    --   on the DHCP server.+    --+    --   ['E.DhcpJetError'] An error occurred while accessing the DHCP server+    --   database.+    --+    --   ['E.DhcpNotReservedClient'] The specified DHCP client is not a+    --   reserved client.+    --+    --   ['E.DhcpInvalidRange'] The specified IPv4 range does not match an+    --   existing IPv4 range.+    --+    --   ['E.ScopeRangePolicyChangeConflict'] An IP address range is+    --   configured for a policy in this scope. This operation cannot be+    --   performed on the scope IP address range until the policy IP address+    --   range is suitably modified.+addReservation dhcp (Context server subnet) mapping =+    addSubnetElementV4 dhcp server subnet+    $ ReservedIps (Reservation mapping Both)++enumReservations :: DhcpApi -> Context -> IO [Reservation]+enumReservations dhcp (Context server subnet) = do+    ex <- enumSubnetElementsV4 dhcp server subnet 2+    res <- flip mapM ex $ \element -> do+        case element of+          ReservedIps res -> return res+          _ -> error "bug in Win32 API."+    return res++-- | Remove a reservation from the server+removeReservation :: DhcpApi -> Context -> Mapping+    -> ClientType+    -- ^ Specify a DHCP reservation, BOOTP reservation, or both. This is untested.+    -> Bool+    -- ^ Specify whether any active leases for the reservation should be+    -- removed as well.+    -> IO ()+    -- ^ This function will throw an 'E.Win32Exception' when the internal Win32+    -- call returnes an error condition. MSDN lists the following exceptions,+    -- but others might be thrown as well:+    --+    --   ['E.DhcpSubnetNotPresent'] The specified IPv4 subnet does not exist+    --   on the DHCP server.+    --+    --   ['E.DhcpElementCantRemove'] Failure can occur for any number of+    --   reasons.+    --+    --   ['E.DhcpJetError'] An error occurred while accessing the DHCP server+    --   database.+    --+    --   ['E.DhcpInvalidRange'] The specified IPv4 range does not match an+    --   existing IPv4 range.+    --+    --   ['E.ScopeRangePolicyChangeConflict'] An IP address range is+    --   configured for a policy in this scope. This operation cannot be+    --   performed on the scope IP address range until the policy IP address+    --   range is suitably modified.+removeReservation dhcp (Context server subnet) mapping ct force =+    removeSubnetElementV4 dhcp server subnet+    (ReservedIps $ Reservation mapping ct) fForce+ where+   fForce = if force then FullForce else NoForce++enumSubnetClientsV4 :: DhcpApi -> Text -> Ip -> IO [Client]+enumSubnetClientsV4 dhcp server subnet =+    withTString server $ \pServer ->+    -- inout parameter. Supply on successive calls to retreive more elements+    with 0 $ \pResumeHandle ->+    alloca $ \pElementsRead ->+    alloca $ \pElementsTotal ->+    with nullPtr $ \ppInfoArray -> do+    -- We have to call enumSubnetElementsV4 at least twice for a sucessfull run.+    -- Failure to use the returned resumeHandle may result in an internal access+    -- violation within RPCRT4.dll.+    let loop acc = do+            ret <- E.fromDWORD <$> c_EnumSubnetClientsV4 dhcp pServer (toWord32 subnet)+                                   pResumeHandle 0xFFFFFFFF ppInfoArray+                                   pElementsRead pElementsTotal+            unless (elem ret [E.Success, E.MoreData, E.NoMoreItems])+                $ E.failWith "EnumSubnetClientsV4" ret++            melems <- scrubWith ppInfoArray $ \pInfoArray -> do+                SUBNET_CLIENT_INFO_ARRAY_V4 (LengthBuffer _ elems) <- peekDhcp clientInfoArray pInfoArray+                freeDhcp clientInfoArray (rpcFreeMemory dhcp) pInfoArray+                return elems+            let elems = fromMaybe [] melems++            if (ret == E.NoMoreItems || ret == E.Success)+              then return (elems:acc)+              else loop (elems:acc)++    revelemss <- loop []+    return $ concat $ reverse revelemss++enumSubnetElementsV4 :: DhcpApi -> Text -> Ip -> CInt+    -> IO [SUBNET_ELEMENT_DATA_V4]+enumSubnetElementsV4 dhcp server subnet elementType =+    withTString server $ \pServer ->+    -- inout parameter. Supply on successive calls to retreive more elements+    with 0 $ \pResumeHandle ->+    alloca $ \pElementsRead ->+    alloca $ \pElementsTotal ->+    with nullPtr $ \ppInfoArray -> do+    -- We have to call enumSubnetElementsV4 at least twice for a sucessfull run.+    -- Failure to use the returned resumeHandle may result in an internal access+    -- violation within RPCRT4.dll.+    let loop acc = do+            ret <- E.fromDWORD <$> c_EnumSubnetElementsV4 dhcp pServer (toWord32 subnet) elementType+                                   pResumeHandle 0xFFFFFFFF ppInfoArray+                                   pElementsRead pElementsTotal+            unless (elem ret [E.Success, E.MoreData, E.NoMoreItems])+                $ E.failWith "EnumSubnetElementsV4" ret++            melems <- scrubWith ppInfoArray $ \pInfoArray -> do+                SUBNET_ELEMENT_INFO_ARRAY_V4 (LengthBuffer _ elems) <- peekDhcp infoArray pInfoArray+                freeDhcp infoArray (rpcFreeMemory dhcp) pInfoArray+                return elems+            let elems = fromMaybe [] melems++            -- Intentionally ignore elementsTotal. Microsoft's documentation+            -- on how this should work doesn't seem right. In my testing+            -- elementsTotal always returns 0x7fffffff until the last loop, at+            -- which time it always matches elementsRead.+            if (ret == E.NoMoreItems || ret == E.Success)+              then return (elems:acc)+              else loop (elems:acc)++    revelemss <- loop []+    return $ concat $ reverse revelemss++addSubnetElementV4 :: DhcpApi -> Text -> Ip -> SUBNET_ELEMENT_DATA_V4 -> IO ()+addSubnetElementV4 dhcp server subnet elementData =+    withTString server $ \pServer ->+    withDhcp subnetElementData elementData $ \pElementData ->+    E.failUnlessSuccess "AddSubnetElementsV4"+    $ c_AddSubnetElementV4 dhcp pServer (toWord32 subnet) pElementData++-- | Remove an IPv4 subnet element from an IPv4 subnet defined on the DHCPv4+--   server.+removeSubnetElementV4+    :: DhcpApi+    -> Text   -- ^ Unicode string that specifies the IP address, such as+              --   \"123.456.789.012\", or hostname, such as \"server\",+              --   of the DHCP server.+    -> Ip -- ^ 'DWORD' value that specifies the IP address of the+                  --   subnet gateway and uniquely identifies it. As an+                  --   example, with the above IP address and a subnet mask+                  --   of 255.255.255.0, the subnet would be 123.456.789.0.+                  --   This must then be converted to a 'DWORD' value of+                  --   2,093,683,968.+    -> SUBNET_ELEMENT_DATA_V4 -- ^ 'DHCP_SUBNET_ELEMENT_DATA_V4' structure+                              --   that contains information used to find the+                              --   element that will be removed from subnet+                              --   specified in SubnetAddress.+    -> FORCE_FLAG -- ^ DHCP_FORCE_FLAG enumeration value that indicates+                  --   whether or not the clients affected by the removal of+                  --   the subnet element should also be deleted.+                  --+                  --   Note If the flag is set to DhcpNoForce and this subnet+                  --   has served an IPv4 address to DHCPv4/BOOTP clients, the+                  --   IPv4 range is not deleted; conversely, if the flag is+                  --   set to DhcpFullForce, the IPv4 range is deleted along+                  --   with the DHCPv4 client lease record on the DHCPv4+                  --   server.+    -> IO ()+    -- ^ This function will throw an 'E.Win32Exception' when the internal Win32+    -- call returnes an error condition. MSDN lists the following exceptions,+    -- but others might be thrown as well:+    --+    --   ['E.DhcpSubnetNotPresent'] The specified IPv4 subnet does not exist+    --   on the DHCP server.+    --+    --   ['E.DhcpElementCantRemove'] Failure can occur for any number of+    --   reasons.+    --+    --   ['E.DhcpJetError'] An error occurred while accessing the DHCP server+    --   database.+    --+    --   ['E.DhcpInvalidRange'] The specified IPv4 range does not match an+    --   existing IPv4 range.+    --+    --   ['E.ScopeRangePolicyChangeConflict'] An IP address range is+    --   configured for a policy in this scope. This operation cannot be+    --   performed on the scope IP address range until the policy IP address+    --   range is suitably modified.+removeSubnetElementV4 dhcp server subnet elementData forceFlag =+    withTString server $ \pServer ->+    withDhcp subnetElementData elementData $ \pElementData ->+    E.failUnlessSuccess "RemoveSubnetElementV4"+    $ c_RemoveSubnetElementV4 dhcp pServer (toWord32 subnet) pElementData+          (fromIntegral . fromEnum $ forceFlag)++withTStringLen :: Text -> (LPTSTR -> T.I16 -> IO a) -> IO a+withTStringLen text act = T.useAsPtr (T.snoc text (chr 0x0)) $ \ptr len ->+    act (castPtr ptr) len++withTString :: Text -> (LPTSTR -> IO a) -> IO a+withTString text act = withTStringLen text $ \ptr _ -> do+    act ptr

System/Win32/DHCP/Client.hs view

@@ -1,117 +1,122 @@-module System.Win32.DHCP.Client
-  ( Client (..)
-  , clientInfo
-  ) where
-
-import Control.Applicative
-import Foreign
-
-import System.Win32.Types
-
-import Data.Ip
-import Data.Mac
-import System.Win32.DHCP.CLIENT_UID
-import System.Win32.DHCP.DhcpStructure
-import System.Win32.DHCP.HOST_INFO
-import System.Win32.DHCP.Types
-import Utils
-
--- | Information about an active lease. This type corresponds to
--- MSDN's DHCP_CLIENT_INFO_V4 structure.
---
--- > typedef struct _DHCP_CLIENT_INFO_V4 {
--- >   DHCP_IP_ADDRESS ClientIpAddress;
--- >   DHCP_IP_MASK    SubnetMask;
--- >   DHCP_CLIENT_UID ClientHardwareAddress;
--- >   LPWSTR          ClientName;
--- >   LPWSTR          ClientComment;
--- >   DATE_TIME       ClientLeaseExpires;
--- >   DHCP_HOST_INFO  OwnerHost;
--- >   BYTE            bClientType;
--- > } DHCP_CLIENT_INFO_V4, *LPDHCP_CLIENT_INFO_V4;
-data Client = Client
-    { clientIp              :: !Ip
-    , clientSubnetMask      :: !Ip
-    , clientHardwareAddress :: !Mac
-    , clientName            :: Maybe String
-    , clientComment         :: Maybe String
-    , clientLeaseExpires    :: !DATE_TIME
-    -- ^ MSDN: The date and time the DHCP client lease will expire, in UTC time.
-    --
-    -- I don't know of any available functions to work with a `DATE_TIME`.
-    , clientOwnerHost       :: !HOST_INFO
-    -- ^ Information on the DHCP server that assigned the lease to the client.
-    , clientType            :: !ClientType
-    }
- 
-clientInfo :: DhcpStructure Client
-clientInfo = DhcpStructure
-    { peekDhcp = peekClientInfoV4
-    , freeDhcp = 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 :: (Ptr a -> IO ()) -> Ptr Client -> IO ()
-freeClientInfoV4 freefunc ptr = do
-    freeDhcp clientUid freefunc $ pmac ptr
-    freeptr freefunc $ ppclientName ptr
-    freeptr freefunc $ ppclientComment ptr
-    freeDhcp hostInfo freefunc $ pownerHost ptr
-    freefunc $ castPtr 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 Control.Applicative+import Foreign++import System.Win32.Types++import Data.Ip+import Data.Mac+import System.Win32.DHCP.CLIENT_UID+import System.Win32.DHCP.DhcpStructure+import System.Win32.DHCP.HOST_INFO+import System.Win32.DHCP.Types+import Utils++-- | Information about an active lease. This type corresponds to+-- MSDN's DHCP_CLIENT_INFO_V4 structure.+--+-- > typedef struct _DHCP_CLIENT_INFO_V4 {+-- >   DHCP_IP_ADDRESS ClientIpAddress;+-- >   DHCP_IP_MASK    SubnetMask;+-- >   DHCP_CLIENT_UID ClientHardwareAddress;+-- >   LPWSTR          ClientName;+-- >   LPWSTR          ClientComment;+-- >   DATE_TIME       ClientLeaseExpires;+-- >   DHCP_HOST_INFO  OwnerHost;+-- >   BYTE            bClientType;+-- > } DHCP_CLIENT_INFO_V4, *LPDHCP_CLIENT_INFO_V4;+data Client = Client+    { clientIp              :: !Ip+    , clientSubnetMask      :: !Ip+    , clientHardwareAddress :: !Mac+    , clientName            :: Maybe String+    , clientComment         :: Maybe String+    , clientLeaseExpires    :: !DATE_TIME+    -- ^ MSDN: The date and time the DHCP client lease will expire, in UTC+    -- time.+    --+    -- I don't know of any available functions to work with a `DATE_TIME`.+    , clientOwnerHost       :: !HOST_INFO+    -- ^ Information on the DHCP server that assigned the lease to the client.+    , clientType            :: !ClientType+    }+ +clientInfo :: DhcpStructure Client+clientInfo = DhcpStructure+    { peekDhcp = peekClientInfoV4+    , freeDhcpChildren = freeClientInfoV4+    , withDhcp' = withClientInfo'+    -- 12-byte alignment because of the inlined HOST_INFO struct+    , sizeDhcp = 48+    }++withClientInfo' :: Client -> Ptr Client -> IO r -> IO r+withClientInfo' c ptr f = +    -- The Mac is inlined, so we'll need to copy pmacsrc into pmac+    withMac     (clientHardwareAddress c) $ \pcuidsrc ->+    withMaybeTString (clientName c)       $ \pclientName ->+    withMaybeTString (clientComment c)    $ \pclientComment ->+    withDhcp' hostInfo   (clientOwnerHost c) (pownerHost ptr) $ do+    poke (pclientIP ptr)     $ clientIp c+    poke (psubnetMask ptr)   $ clientSubnetMask c+    -- we can't use the Storable instance for Mac here.+    copyBytes (pmac ptr) pcuidsrc $ sizeDhcp clientUid+    poke (ppclientName ptr)    pclientName+    poke (ppclientComment ptr) pclientComment+    poke (pleaseExpires ptr) $ clientLeaseExpires c+     -- Owner host has already been poked+    poke (pclientType ptr)   $ clientType c+    f++peekClientInfoV4 :: Ptr Client -> IO Client+peekClientInfoV4 ptr = Client+    <$> (peek $ pclientIP ptr)+    <*> (peek $ psubnetMask ptr)+    <*> (macCuid <$> peekDhcp clientUid (pmac ptr))+    <*> (peek (ppclientName ptr) >>= peekMaybeTString)+    <*> (peek (ppclientComment ptr) >>= peekMaybeTString)+    <*> (peek $ pleaseExpires ptr)+    <*> (peekDhcp hostInfo $ pownerHost ptr)+    <*> (peek $ pclientType ptr)++freeClientInfoV4 :: (forall a. Ptr a -> IO ()) -> Ptr Client -> IO ()+freeClientInfoV4 freefunc ptr = do+    -- The client_uid is inlined into the client_info structure.+    freeDhcpChildren clientUid freefunc $ pmac ptr+    freefunc `scrubbing_` ppclientName ptr+    freefunc `scrubbing_` ppclientComment ptr+    -- The HOST_INFO structure is inlined within the ClientInfoV4, so we don't+    -- have to free its main pointer.+    freeDhcpChildren hostInfo freefunc $ pownerHost ptr++pclientIP :: Ptr Client -> Ptr Ip+pclientIP = castPtr++psubnetMask :: Ptr Client -> Ptr Ip+psubnetMask ptr = castPtr ptr `plusPtr` 4++-- The client_uid is inlined into the client_info structure.+pmac :: Ptr Client -> Ptr CLIENT_UID+pmac ptr = castPtr ptr `plusPtr` 8++ppclientName :: Ptr Client -> Ptr LPWSTR+ppclientName ptr = castPtr ptr `plusPtr` 16++ppclientComment :: Ptr Client -> Ptr LPWSTR+ppclientComment ptr = castPtr ptr `plusPtr` 20++pleaseExpires :: Ptr Client -> Ptr DATE_TIME+pleaseExpires ptr = castPtr ptr `plusPtr` 24++-- the HOST_INFO is inlined into the CLIENT_INFO structure+pownerHost :: Ptr Client -> Ptr HOST_INFO+pownerHost ptr = castPtr ptr `plusPtr` 32++pclientType :: Ptr Client -> Ptr ClientType+pclientType ptr = castPtr ptr `plusPtr` 44

System/Win32/DHCP/DhcpStructure.hs view

@@ -1,177 +1,187 @@-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE RankNTypes #-}
-
-module System.Win32.DHCP.DhcpStructure where
-
-import Control.Applicative
-import Foreign.Marshal.Alloc (allocaBytes)
-import Foreign.Ptr
-import Foreign.Storable
-
-import Utils (freeptr)
-
--- |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
-    , freeDhcp  :: 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
-    }
-
--- |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 f = freeDhcp dict f . castPtr
-    withNt' a ptr f = withDhcp' dict (unwrap a) (castPtr ptr) f
-
-storableDhcpStructure :: forall a. (Storable a) => DhcpStructure a
-storableDhcpStructure = DhcpStructure
-    { peekDhcp  = peek
-    , freeDhcp  = free
-    , withDhcp' = withStorable'
-    , sizeDhcp  = sizeOf (undefined :: a)
-    }
-  where
-    free freefunc ptr = freeptr freefunc $ castPtr ptr
-    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 numElements ptr
-  | numElements <= 0 = return []
-  | otherwise = f (numElements - 1) []
-  where
-    f 0 acc = do
-        e <- peekDhcp dict ptr
-        return (e:acc)
-    f n acc = do
-        e <- peekDhcp dict (ptr `plusPtr` (sizeDhcp dict * n))
-        f (n - 1) (e:acc)
-
-baseFreeArray :: DhcpStructure a -> (Ptr x -> IO ()) -> Int -> Ptr a -> IO ()
-baseFreeArray dict freefunc len ptr = f (len - 1)
-  where
-    f 0 = freeDhcp dict freefunc ptr
-    f n = do
-        freeDhcp 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 -> (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 numElements ptr
-  | numElements <= 0 = return []
-  | otherwise = f (numElements - 1) []
-  where
-    --Each element is a pointer to the real data
-    pptr = castPtr ptr
-    f 0 acc = do
-        e <- peek pptr >>= peekDhcp dict
-        return (e:acc)
-    f n acc = do
-        pe <- peek $ pptr `plusPtr` (sizeOf nullPtr * n)
-        e <- peekDhcp dict pe
-        f (n - 1) (e:acc)
-
-ptrFreeArray :: DhcpStructure a -> (Ptr x -> IO ()) -> Int -> Ptr a -> IO ()
-ptrFreeArray dict freefunc len ptr = f (len - 1)
-  where
-    --Each element is a pointer to the real data
-    pptr = castPtr ptr
-    f 0 = peek pptr >>= freeDhcp dict freefunc
-    f n = do
-        pElem <- peek $ pptr `plusPtr` (sizeOf nullPtr * n)
-        freeDhcp dict freefunc pElem
-        f (n - 1)
-
-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.Applicative+import Control.Monad (when)+import Foreign.Marshal.Alloc (allocaBytes)+import Foreign.Ptr+import Foreign.Storable++import Utils++-- |Function dictionary for objects used with the DHCP api.+--  * Ability to peek from a pointer to that object.+--  * Ability to properly free an object using Win32's rpcFreeMemory+--    created by the DHCP api.+--  * Ability to use the with* metaphor to temporarily poke an+--    object into C memory, call a continuation on it, and then+--    free the memory from Haskell's heap.+--+-- Extra features made possible by the typeclass+--  * Ability to turn any Storable instance into a DhpcStructure instance+--    by wrapping it into a StorableDhcpStructure.+--  * Ability to peek an array of DHCP structures into a list.+--  * Ability to poke a list of objects into contiguous memory, then+--    call a continuation on that block of memory.+data DhcpStructure a = DhcpStructure+    { peekDhcp  :: Ptr a -> IO a+    -- |Cleaning up memory is the responsibility of the client of this+    -- library. Most out parameters return compound structures which need to+    -- be recursively navigated, freeing all children, before freeing the main+    -- pointer.+    --+    -- This function only frees child objects without freeing the pointer+    -- itself. It's necessary because some structures contained inline+    -- structures instead of the usual pointer. A separate 'freeDhcp' function+    -- will call this one before freeing its supplied pointer.+    , freeDhcpChildren  :: (forall x. Ptr x -> IO ()) -> Ptr a -> IO ()+    -- |Like `withDhcp`, but without any allocation or cleanup of memory.+    -- The continuation is not automatically given a pointer because+    -- the caller should already have it.+    , withDhcp' :: forall r. a -> Ptr a -> IO r -> IO r+    , sizeDhcp :: Int+    }++freeDhcp :: DhcpStructure a -> (forall x. Ptr x -> IO ()) -> Ptr a -> IO ()+freeDhcp dict free ptr = do+    freeDhcpChildren dict free ptr+    free ptr++-- |Allocate memory for a structure, poke it into memory, apply+-- a function, and then clean up the memory.+withDhcp :: DhcpStructure a -> a -> (Ptr a -> IO r) -> IO r+withDhcp dict a f = allocaBytes (sizeDhcp dict) $ \ptr ->+    withDhcp' dict a ptr $ f ptr++-- |Convert a DhcpStructure so that it can be used with a newtype+-- wrapper.+newtypeDhcpStructure :: (a -> nt) -> (nt -> a)+    -> DhcpStructure a -> DhcpStructure nt+newtypeDhcpStructure wrap unwrap dict =+    DhcpStructure peekNt freeNt withNt' (sizeDhcp dict)+  where+    peekNt ptr = wrap <$> peekDhcp dict (castPtr ptr)+    freeNt :: (forall x. Ptr x -> IO ()) -> Ptr a -> IO ()+    freeNt f ptr = freeDhcpChildren dict f (castPtr ptr)+    withNt' a ptr f = withDhcp' dict (unwrap a) (castPtr ptr) f++-- |This is used in cases like 'CLIENT_UID' where we want to treat it like+-- a 'LengthArray' but individual elements of the array are simple values.+-- We reuse the 'Storable' instances peek and poke functions.+storableDhcpStructure :: forall a. (Storable a) => DhcpStructure a+storableDhcpStructure = DhcpStructure+    { peekDhcp  = peek+    , freeDhcpChildren  = \freeFunc ptr -> freeFunc ptr+    , withDhcp' = withStorable'+    , sizeDhcp  = sizeOf (undefined :: a)+    }+  where+    withStorable' x ptr f = poke ptr x >> f++data DhcpArray a = DhcpArray+    { peekDhcpArray  :: Int -> Ptr a -> IO [a]+    , freeDhcpArray  :: (forall x. Ptr x -> IO ()) -> Int -> Ptr a -> IO ()+    , withDhcpArray' :: forall r. [a] -> Ptr a -> IO r -> IO r+    , dhcpStructure   :: DhcpStructure a+    }++-- |Allocate enough contiguous memory for each element. Recursively+-- free all memory once the supplied function returns.+-- The continuation receives a length argument. This is because+-- the length must be calculated in the course of execution, and will+-- likely be needed again by the caller.+withDhcpArray ::  DhcpArray a -> [a] -> (Int -> Ptr a -> IO r) -> IO r+withDhcpArray dict elems f =+    allocaBytes (stride * size) $ \ptr ->+    -- `f` is meant to be called on the array as a whole; not individual elements.+    -- It's supplied its pointer here because we want it called on position 0.+    withDhcpArray' dict elems ptr $ f size ptr+  where+    size = length elems+    stride = sizeDhcp . dhcpStructure $ dict++-- |This dictionary is a default set to "base" other versions on.+-- Scanning through the buffer happens dhcpSize bytes at a time. Memory+-- is freed by calling the freeing function on every element in the buffer.+baseDhcpArray :: DhcpStructure a -> DhcpArray a+baseDhcpArray s = DhcpArray+    { peekDhcpArray = basePeekArray s+    , freeDhcpArray = baseFreeArray s+    , withDhcpArray' = baseWithArray' s+    , dhcpStructure = s+    }++-- |This differs from `baseDhcpArray` in that the entire buffer+-- is freed with a single call to the freeing function.+basicDhcpArray :: DhcpStructure a -> DhcpArray a+basicDhcpArray dict = (baseDhcpArray dict)+    { freeDhcpArray = basicFreeArray dict+    }++ptrDhcpArray :: DhcpStructure a -> DhcpArray a+ptrDhcpArray dict = (baseDhcpArray dict)+    { peekDhcpArray = ptrPeekArray dict+    , freeDhcpArray = ptrFreeArray dict+    , withDhcpArray' = ptrWithArray' dict+    }++basePeekArray :: DhcpStructure a -> Int -> Ptr a -> IO [a]+basePeekArray dict len ptr0 = mapM (peekDhcp dict) ptrs+  where+    ptrs = take len . iterate (`plusPtr` sizeDhcp dict) $ ptr0++-- |Elements are arranged end to end in a buffer. The buffer is freed+-- at once after each element's children are freed.+baseFreeArray :: DhcpStructure a+    -> (forall x. Ptr x -> IO ()) -> Int -> Ptr a -> IO ()+baseFreeArray dict freefunc len ptr+  | len <= 0 = return ()+  | otherwise = do+    f (len - 1)+    freefunc ptr+  where+    f 0 = freeDhcpChildren dict freefunc ptr+    f n = do+        freeDhcpChildren dict freefunc $ ptr `plusPtr` (n * sizeDhcp dict)+        f (n - 1)++baseWithArray' :: DhcpStructure a -> [a] -> Ptr a -> IO r -> IO r+baseWithArray' _    []     _   f = f+baseWithArray' dict (e:es) ptr f =+    -- We're not concerned with the individual element.+    withDhcp' dict e ptr+    $ baseWithArray' dict es (ptr `plusPtr` sizeDhcp dict) f++basicFreeArray :: DhcpStructure a -> (forall x. Ptr x -> IO ())+    -> Int -> Ptr a -> IO ()+basicFreeArray dict freefunc _ ptr = freeDhcp dict freefunc ptr++ptrPeekArray :: DhcpStructure a -> Int -> Ptr a -> IO [a]+ptrPeekArray dict len ptr = mapM peekElement pptrs+  where+    --Each element is a pointer to the real data+    pptrs = take len . iterate (`plusPtr` sizeOf nullPtr) $ castPtr ptr+    peekElement pptr = peek pptr >>= peekDhcp dict++ptrFreeArray :: DhcpStructure a+    -> (forall x. Ptr x -> IO ()) -> Int -> Ptr a -> IO ()+ptrFreeArray dict freefunc len ptr = do+    mapM (freeDhcp dict freefunc `scrubbing_`) pptrs+    -- Len may very well be 0 in which case there's really nothing to free.+    when (len > 0) $ freefunc ptr+  where+    --Each element is a pointer to the real data+    pptrs = take len . iterate (`plusPtr` sizeOf nullPtr) $ castPtr ptr++ptrWithArray' :: DhcpStructure a -> [a] -> Ptr a -> IO r -> IO r+ptrWithArray' _    []     _   f = f+ptrWithArray' dict (e:es) ptr f =+    -- We're not concerned with the individual element.+    withDhcp dict e $ \pe -> do+    poke pptr pe+    ptrWithArray' dict es (ptr `plusPtr` sizeOf nullPtr) f+  where+    --Each element is a pointer to the real data+    pptr = castPtr ptr

System/Win32/DHCP/HOST_INFO.hs view

@@ -1,56 +1,58 @@-module System.Win32.DHCP.HOST_INFO
-    ( HOST_INFO (..)
-    , hostInfo
-    ) where
-
-import Control.Applicative
-import Foreign
-
-import System.Win32.Types
-
-import Data.Ip
-import System.Win32.DHCP.DhcpStructure
-import Utils
-
--- typedef struct _DHCP_HOST_INFO {
---   DHCP_IP_ADDRESS IpAddress;
---   LPWSTR          NetBiosName;
---   LPWSTR          HostName;
--- } DHCP_HOST_INFO, *LPDHCP_HOST_INFO;
-data HOST_INFO = HOST_INFO !Ip (Maybe String) (Maybe String)
-
-
-hostInfo :: DhcpStructure HOST_INFO
-hostInfo = DhcpStructure
-    { peekDhcp = peekHostInfo
-    , freeDhcp = 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 :: (Ptr a -> IO ()) -> Ptr HOST_INFO -> IO ()
-freeHostInfoChildren rpcfree phi = do
-    freeptr rpcfree $ ppnetBiosName phi
-    freeptr rpcfree $ 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 Control.Applicative+import Foreign++import System.Win32.Types++import Data.Ip+import System.Win32.DHCP.DhcpStructure+import Utils++-- typedef struct _DHCP_HOST_INFO {+--   DHCP_IP_ADDRESS IpAddress;+--   LPWSTR          NetBiosName;+--   LPWSTR          HostName;+-- } DHCP_HOST_INFO, *LPDHCP_HOST_INFO;+data HOST_INFO = HOST_INFO !Ip (Maybe String) (Maybe String)+++hostInfo :: DhcpStructure HOST_INFO+hostInfo = DhcpStructure+    { peekDhcp = peekHostInfo+    , freeDhcpChildren = freeHostInfoChildren+    , withDhcp' = withHostInfo'+    , sizeDhcp = 12+    }++peekHostInfo :: Ptr HOST_INFO -> IO HOST_INFO+peekHostInfo ptr = do+    pnetBiosName <- peek $ ppnetBiosName ptr+    phostName <- peek $ pphostName ptr+    HOST_INFO <$> peek (castPtr ptr) <*> peekMaybeTString pnetBiosName+              <*> peekMaybeTString phostName++withHostInfo' :: HOST_INFO -> Ptr HOST_INFO -> IO r -> IO r+withHostInfo' (HOST_INFO ip netbiosname hostname) ptr f =+    withMaybeTString netbiosname $ \pnetbiosname ->+    withMaybeTString hostname    $ \phostname -> do+    poke (castPtr ptr) ip+    pokeByteOff (castPtr ptr) 4 pnetbiosname+    pokeByteOff (castPtr ptr) 8 phostname+    f++freeHostInfoChildren :: (forall x. Ptr x -> IO ()) -> Ptr HOST_INFO -> IO ()+freeHostInfoChildren rpcfree phi = do+    rpcfree `scrubbing_` ppnetBiosName phi+    rpcfree `scrubbing_` pphostName phi++ppnetBiosName :: Ptr HOST_INFO -> Ptr LPWSTR+ppnetBiosName ptr = castPtr ptr `plusPtr` 4++pphostName :: Ptr HOST_INFO -> Ptr LPWSTR+pphostName ptr = castPtr ptr `plusPtr` 8

System/Win32/DHCP/IP_CLUSTER.hs view

@@ -1,25 +1,25 @@-module System.Win32.DHCP.IP_CLUSTER
-    ( IP_CLUSTER (..)
-    ) where
-
-import Control.Applicative
-import Foreign
-
-import System.Win32.Types
-
-import Data.Ip
-
--- typedef struct _DHCP_IP_CLUSTER {
---   DHCP_IP_ADDRESS ClusterAddress;
---   DWORD           ClusterMask;
--- } DHCP_IP_CLUSTER, *LPDHCP_IP_CLUSTER;
-data IP_CLUSTER = IP_CLUSTER !Ip !DWORD
-
-instance Storable IP_CLUSTER where
-  sizeOf _ = 8
-  alignment _ = 1
-  peek ptr = IP_CLUSTER <$> (peek . castPtr $ ptr)
-      <*> (castPtr ptr `peekByteOff` 4)
-  poke ptr (IP_CLUSTER ip cmask) = do
-      poke (castPtr ptr) ip
-      pokeByteOff (castPtr ptr) 4 cmask
+module System.Win32.DHCP.IP_CLUSTER+    ( IP_CLUSTER (..)+    ) where++import Control.Applicative+import Foreign++import System.Win32.Types++import Data.Ip++-- typedef struct _DHCP_IP_CLUSTER {+--   DHCP_IP_ADDRESS ClusterAddress;+--   DWORD           ClusterMask;+-- } DHCP_IP_CLUSTER, *LPDHCP_IP_CLUSTER;+data IP_CLUSTER = IP_CLUSTER !Ip !DWORD++instance Storable IP_CLUSTER where+  sizeOf _ = 8+  alignment _ = 1+  peek ptr = IP_CLUSTER <$> (peek . castPtr $ ptr)+      <*> (castPtr ptr `peekByteOff` 4)+  poke ptr (IP_CLUSTER ip cmask) = do+      poke (castPtr ptr) ip+      pokeByteOff (castPtr ptr) 4 cmask

System/Win32/DHCP/IP_RANGE.hs view

@@ -1,22 +1,22 @@-module System.Win32.DHCP.IP_RANGE
-    ( IP_RANGE (..)
-    ) where
-
-import Control.Applicative
-import Foreign
-
-import Data.Ip
-
-data IP_RANGE = IP_RANGE !Ip !Ip
-
-instance Storable IP_RANGE where
-  sizeOf _ = 8
-  alignment _ = 1
-  peek ptr = IP_RANGE
-      <$> (peek . castPtr) ptr
-      <*> castPtr ptr `peekByteOff` 4
-  poke ptr (IP_RANGE start end) = do
-      pokeElemOff addrPtr 0 start
-      pokeElemOff addrPtr 1 end
-    where
-      addrPtr = castPtr ptr :: Ptr Ip
+module System.Win32.DHCP.IP_RANGE+    ( IP_RANGE (..)+    ) where++import Control.Applicative+import Foreign++import Data.Ip++data IP_RANGE = IP_RANGE !Ip !Ip++instance Storable IP_RANGE where+  sizeOf _ = 8+  alignment _ = 1+  peek ptr = IP_RANGE+      <$> (peek . castPtr) ptr+      <*> castPtr ptr `peekByteOff` 4+  poke ptr (IP_RANGE start end) = do+      pokeElemOff addrPtr 0 start+      pokeElemOff addrPtr 1 end+    where+      addrPtr = castPtr ptr :: Ptr Ip

System/Win32/DHCP/Internal.hs 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

System/Win32/DHCP/LengthBuffer.hs view

@@ -1,51 +1,63 @@-module System.Win32.DHCP.LengthBuffer
-  ( LengthBuffer (..)
-  , lengthBuffer
-  ) where
-
-import Control.Applicative
-import Foreign.Ptr
-import Foreign.Storable
-import System.Win32.Types (DWORD)
-
-import System.Win32.DHCP.DhcpStructure
-
--- |A LengthBuffer is a list of items which can be marshalled in and out
--- of memory with a `DhcpArray` instance. 
-data LengthBuffer a = LengthBuffer
-    { lbLength :: Int
-    , buffer :: [a]
-    }
-
-lengthBuffer :: DhcpArray a -> DhcpStructure (LengthBuffer a)
-lengthBuffer dict = DhcpStructure
-    { peekDhcp = peekLb dict
-    , freeDhcp = 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 -> (Ptr x -> IO ()) -> Ptr (LengthBuffer a) -> IO ()
-freeLb dict freefunc ptr = do
-    len <- fromIntegral <$> peek (pNumElements ptr)
-    pElements <- peek $ ppElements ptr
-    freeDhcpArray dict freefunc len pElements
-
-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 Control.Applicative+import Foreign.Ptr+import Foreign.Storable+import System.Win32.Types (DWORD)++import System.Win32.DHCP.DhcpStructure++import Utils++-- |A LengthBuffer is a list of items which can be marshalled in and out+-- of memory with a `DhcpArray` instance. A C structure that can be used+-- with this looks something like the following:+-- +-- typedef struct Structure {+--   DWORD         NumElements;+--   LPElementData Elements;+-- } Structure, *LPStructure;+data LengthBuffer a = LengthBuffer+    { lbLength :: !Int+    , buffer :: [a]+    }++lengthBuffer :: DhcpArray a -> DhcpStructure (LengthBuffer a)+lengthBuffer dict = DhcpStructure+    { peekDhcp = peekLb dict+    , freeDhcpChildren = freeLb dict+    , withDhcp' = withLb' dict+    , sizeDhcp = 8+    }++peekLb :: DhcpArray a -> Ptr (LengthBuffer a) -> IO (LengthBuffer a)+peekLb dict ptr = do+    len <- fromIntegral <$> peek (pNumElements ptr)+    pElements <- peek $ ppElements ptr+    LengthBuffer len <$> peekDhcpArray dict len pElements++freeLb :: DhcpArray a -> (forall x. Ptr x -> IO ())+    -> Ptr (LengthBuffer a) -> IO ()+freeLb dict freefunc ptr = do+    len <- fromIntegral <$> peek (pNumElements ptr)+    -- A LengthBuffer contain a pointer to the buffer; not the start of the+    -- buffer itself.+    freeDhcpArray dict freefunc len `scrubbing_` ppElements ptr++withLb' :: DhcpArray a -> LengthBuffer a -> Ptr (LengthBuffer a) -> IO r -> IO r+withLb' dict (LengthBuffer _ elems) ptr f =+    withDhcpArray dict elems $ \size pelems -> do+    pokeByteOff ptr 0 (fromIntegral size :: DWORD)+    poke (ppElements ptr) (castPtr pelems)+    f++pNumElements :: Ptr (LengthBuffer a) -> Ptr DWORD+pNumElements ptr = castPtr ptr++ppElements :: Ptr (LengthBuffer a) -> Ptr (Ptr a)+ppElements ptr = castPtr ptr `plusPtr` 4

System/Win32/DHCP/Reservation.hs view

@@ -1,81 +1,81 @@-module System.Win32.DHCP.Reservation
-    ( Mapping (..)
-    , Reservation (..)
-    , reservation
-    ) where
-
-import Control.Applicative
-import Foreign
-
-import Data.Ip
-import Data.Mac
-import System.Win32.DHCP.CLIENT_UID
-import System.Win32.DHCP.DhcpStructure
-import System.Win32.DHCP.Types (ClientType)
-import Utils (freeptr)
-
--- | 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
-    , freeDhcp = 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 :: (Ptr a -> IO ()) -> Ptr Reservation -> IO ()
-freeReservation freefunc ptr = do
-    peek (ppCuid ptr) >>= freeDhcp clientUid freefunc
-    freeptr freefunc $ ppCuid ptr
-    freefunc $ castPtr 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 Control.Applicative+import Foreign++import Data.Ip+import Data.Mac+import System.Win32.DHCP.CLIENT_UID+import System.Win32.DHCP.DhcpStructure+import System.Win32.DHCP.Types (ClientType)+import Utils (scrubbing_)++-- | A Reservation guarantees that a device with a given Mac address will+-- always be assigned to a particular IP address. A reservation is not the+-- same thing as a lease, and there are separate calls to work with both+-- objects.+--+-- This type corresponds to MSDN's DHCP_IP_RESERVATION_V4 structure.+--+-- > typedef struct _DHCP_IP_RESERVATION_V4 {+-- >   DHCP_IP_ADDRESS ReservedIpAddress;+-- >   DHCP_CLIENT_UID *ReservedForClient;+-- >   BYTE            bAllowedClientTypes;+-- > } DHCP_IP_RESERVATION_V4, *LPDHCP_IP_RESERVATION_V4;+data Reservation = Reservation+    { reservationMapping :: !Mapping+    , reservationType    :: !ClientType+    } deriving (Eq)++-- | A mapping between an IP and a MAC address. Each IP number may map to+-- only one MAC address, and each MAC address may map to only one IP number.+--+-- This is a separate type from `Reservation` for practical reasons. When+-- writing software to work with a DHCP server, `Reservation`'s+-- `ClientType` field is often not important. Without the `Mapping` type+-- defined here it would often be necessary to define a custom type in+-- each project.+data Mapping = Mapping+    { mappingMac :: !Mac+    , mappingIp  :: !Ip+    } deriving (Eq, Ord)++reservation :: DhcpStructure Reservation+reservation = DhcpStructure+    { peekDhcp = peekReservation+    , freeDhcpChildren = freeReservation+    , withDhcp' = withReservation'+    , sizeDhcp = 10+    }++peekReservation :: Ptr Reservation -> IO Reservation+peekReservation ptr = do+    pCuid <- peek $ ppCuid ptr+    mac <- macCuidDrop5 <$> peekDhcp clientUid pCuid+    addr <- peek pAddress+    clientType <- peekByteOff (castPtr ptr) 8+    return $ Reservation (Mapping mac addr) clientType+  where+    pAddress = castPtr ptr :: Ptr Ip++freeReservation :: (forall x. Ptr x -> IO ()) -> Ptr Reservation -> IO ()+freeReservation freefunc ptr = do+    freeDhcp clientUid freefunc `scrubbing_` ppCuid ptr++ppCuid :: Ptr Reservation -> Ptr (Ptr CLIENT_UID)+ppCuid ptr = castPtr ptr `plusPtr` 4++withReservation' :: Reservation -> Ptr Reservation+    -> IO r -> IO r+withReservation' (Reservation (Mapping mac address) clientType) ptr f =+    withMac mac $ \pCuid -> do+    poke (castPtr ptr) address+    pokeByteOff (castPtr ptr) 4 pCuid+    pokeByteOff (castPtr ptr) 8 clientType+    f

System/Win32/DHCP/SEARCH_INFO.hs view

@@ -1,68 +1,68 @@-{-# LANGUAGE OverloadedStrings #-}
-
-module System.Win32.DHCP.SEARCH_INFO
-  ( SEARCH_INFO_TYPE
-  , SEARCH_INFO (..)
-  , withSearchInfo
-  ) where
-
-import Data.Monoid ((<>))
-import qualified Data.Text as T
-import Foreign
-import Foreign.C.Types
-
-import System.Win32.Types
-
-import Data.Ip
-import Data.Mac
-import System.Win32.DHCP.CLIENT_UID
-
--- typedef enum _DHCP_CLIENT_SEARCH_TYPE { 
---   DhcpClientIpAddress,
---   DhcpClientHardwareAddress,
---   DhcpClientName
--- } DHCP_SEARCH_INFO_TYPE, *LPDHCP_SEARCH_INFO_TYPE;
-type SEARCH_INFO_TYPE = CInt
-
--- | Filter criteria used in actions that look up reservation or lease
--- records.
---
--- > typedef struct _DHCP_CLIENT_SEARCH_INFO {
--- >   DHCP_SEARCH_INFO_TYPE SearchType;
--- >   union {
--- >     DHCP_IP_ADDRESS ClientIpAddress;
--- >     DHCP_CLIENT_UID ClientHardwareAddress;
--- >     LPWSTR          ClientName;
--- >   } SearchInfo;
--- > } DHCP_SEARCH_INFO, *LPDHCP_SEARCH_INFO;
-data SEARCH_INFO
-  -- | Search based on an IP address. All scopes are searched. It should
-  -- not be possible for multiple records to exist.
-  = ClientIpAddress       !Ip
-  -- | Search based on a subnet and MAC address. This method of searching
-  -- has not been tested.
-  | ClientHardwareAddress !Mac
-  -- | Search based on a client's name. Multiple records may exist, and
-  -- what happens in that case will depend on the function being called.
-  -- This method of searching has not been tested.
-  | ClientName            !String
-
-instance Show SEARCH_INFO where
-  show (ClientIpAddress ip) = T.unpack $ "ClientIpAddress " <> showIp ip
-  show (ClientHardwareAddress mac) = T.unpack $ "ClientHardwareAddress " <> showMac ":" mac
-  show (ClientName name) = "ClientName " ++ name
-
-siTypeOf :: SEARCH_INFO -> SEARCH_INFO_TYPE
-siTypeOf (ClientIpAddress _) = 0
-siTypeOf (ClientHardwareAddress _) = 1
-siTypeOf (ClientName _) = 2
-
--- Allocate 12 because a SEARCH_INFO.SearchInfo member's in-structure alignment is 4 with a size of 8.
-withSearchInfo :: SEARCH_INFO -> (Ptr SEARCH_INFO -> IO r) -> IO r
-withSearchInfo si f = allocaBytes 12 $ \ptr -> do
-    let pX = ptr `plusPtr` 4
-    poke (castPtr ptr) $ siTypeOf si
-    case si of
-      ClientIpAddress x -> poke (castPtr pX) x >> f ptr
-      ClientHardwareAddress m -> withMac m $ \pm -> copyBytes (castPtr pX) pm 8 >> f ptr
-      ClientName str -> withTString str $ \pstr -> copyBytes (castPtr pX) pstr 4 >> f ptr
+{-# LANGUAGE OverloadedStrings #-}++module System.Win32.DHCP.SEARCH_INFO+  ( SEARCH_INFO_TYPE+  , SEARCH_INFO (..)+  , withSearchInfo+  ) where++import Data.Monoid ((<>))+import qualified Data.Text as T+import Foreign+import Foreign.C.Types++import System.Win32.Types++import Data.Ip+import Data.Mac+import System.Win32.DHCP.CLIENT_UID++-- typedef enum _DHCP_CLIENT_SEARCH_TYPE { +--   DhcpClientIpAddress,+--   DhcpClientHardwareAddress,+--   DhcpClientName+-- } DHCP_SEARCH_INFO_TYPE, *LPDHCP_SEARCH_INFO_TYPE;+type SEARCH_INFO_TYPE = CInt++-- | Filter criteria used in actions that look up reservation or lease+-- records.+--+-- > typedef struct _DHCP_CLIENT_SEARCH_INFO {+-- >   DHCP_SEARCH_INFO_TYPE SearchType;+-- >   union {+-- >     DHCP_IP_ADDRESS ClientIpAddress;+-- >     DHCP_CLIENT_UID ClientHardwareAddress;+-- >     LPWSTR          ClientName;+-- >   } SearchInfo;+-- > } DHCP_SEARCH_INFO, *LPDHCP_SEARCH_INFO;+data SEARCH_INFO+  -- | Search based on an IP address. All scopes are searched. It should+  -- not be possible for multiple records to exist.+  = ClientIpAddress       !Ip+  -- | Search based on a subnet and MAC address. This method of searching+  -- has not been tested.+  | ClientHardwareAddress !Mac+  -- | Search based on a client's name. Multiple records may exist, and+  -- what happens in that case will depend on the function being called.+  -- This method of searching has not been tested.+  | ClientName            !String++instance Show SEARCH_INFO where+  show (ClientIpAddress ip) = T.unpack $ "ClientIpAddress " <> showIp ip+  show (ClientHardwareAddress mac) = T.unpack $ "ClientHardwareAddress " <> showMac ":" mac+  show (ClientName name) = "ClientName " ++ name++siTypeOf :: SEARCH_INFO -> SEARCH_INFO_TYPE+siTypeOf (ClientIpAddress _) = 0+siTypeOf (ClientHardwareAddress _) = 1+siTypeOf (ClientName _) = 2++-- Allocate 12 because a SEARCH_INFO.SearchInfo member's in-structure alignment is 4 with a size of 8.+withSearchInfo :: SEARCH_INFO -> (Ptr SEARCH_INFO -> IO r) -> IO r+withSearchInfo si f = allocaBytes 12 $ \ptr -> do+    let pX = ptr `plusPtr` 4+    poke (castPtr ptr) $ siTypeOf si+    case si of+      ClientIpAddress x -> poke (castPtr pX) x >> f ptr+      ClientHardwareAddress m -> withMac m $ \pm -> copyBytes (castPtr pX) pm 8 >> f ptr+      ClientName str -> withTString str $ \pstr -> copyBytes (castPtr pX) pstr 4 >> f ptr

System/Win32/DHCP/SUBNET_ELEMENT_DATA_V4.hs view

@@ -1,100 +1,102 @@-module System.Win32.DHCP.SUBNET_ELEMENT_DATA_V4
-    ( SUBNET_ELEMENT_DATA_V4 (..)
-    , SUBNET_ELEMENT_TYPE
-    , elementTypeOf
-    , subnetElementData
-    ) where
-
-import Control.Applicative
-import Foreign
-import Foreign.C.Types
-
-import System.Win32.DHCP.DhcpStructure
-import System.Win32.DHCP.HOST_INFO
-import System.Win32.DHCP.IP_CLUSTER
-import System.Win32.DHCP.IP_RANGE
-import System.Win32.DHCP.Reservation
-
--- 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
-    , freeDhcp = 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 :: (Ptr a -> IO ()) -> Ptr SUBNET_ELEMENT_DATA_V4 -> IO ()
-freeSubnetElementData freefunc ptr = do
-    elementType <- (peek . castPtr) ptr :: IO SUBNET_ELEMENT_TYPE
-    pElement <- peek $ ppElement ptr
-    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."
-    poke (ppElement ptr) nullPtr
-    freefunc $ castPtr ptr
-
--- 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 Control.Applicative+import Foreign+import Foreign.C.Types++import System.Win32.DHCP.DhcpStructure+import System.Win32.DHCP.HOST_INFO+import System.Win32.DHCP.IP_CLUSTER+import System.Win32.DHCP.IP_RANGE+import System.Win32.DHCP.Reservation+import Utils++-- typedef struct _DHCP_SUBNET_ELEMENT_DATA_V4 {+--   DHCP_SUBNET_ELEMENT_TYPE ElementType;+--   union {+--     DHCP_IP_RANGE          *IpRange;+--     DHCP_HOST_INFO         *SecondaryHost;+--     DHCP_IP_RESERVATION_V4 *ReservedIp;+--     DHCP_IP_RANGE          *ExcludeIpRange;+--     DHCP_IP_CLUSTER        *IpUsedCluster;+--   } Element;+-- } DHCP_SUBNET_ELEMENT_DATA_V4, *LPDHCP_SUBNET_ELEMENT_DATA_V4;+data SUBNET_ELEMENT_DATA_V4+    = IpRanges         !IP_RANGE+    | SecondaryHosts   !HOST_INFO+    | ReservedIps      !Reservation+    | ExcludedIpRanges !IP_RANGE+    | IpUsedCluster    !IP_CLUSTER++-- typedef enum _DHCP_SUBNET_ELEMENT_TYPE_V5 {+--   DhcpIpRanges,+--   DhcpSecondaryHosts,+--   DhcpReservedIps,+--   DhcpExcludedIpRanges,+--   DhcpIpRangesDhcpOnly,+--   DhcpIpRangesDhcpBootp,+--   DhcpIpRangesBootpOnly+-- } DHCP_SUBNET_ELEMENT_TYPE, *LPDHCP_SUBNET_ELEMENT_TYPE;+type SUBNET_ELEMENT_TYPE = CInt++subnetElementData :: DhcpStructure SUBNET_ELEMENT_DATA_V4+subnetElementData = DhcpStructure+    { peekDhcp = peekSubnetElementData+    , freeDhcpChildren = freeSubnetElementData+    , withDhcp' = withSubnetElementData'+    , sizeDhcp = 8+    }++peekSubnetElementData :: Ptr SUBNET_ELEMENT_DATA_V4 -> IO SUBNET_ELEMENT_DATA_V4+peekSubnetElementData ptr = do+    elementType <- (peek . castPtr) ptr :: IO SUBNET_ELEMENT_TYPE+    pElement <- peekByteOff ptr 4+    case elementType of+      0 -> IpRanges         <$> peek (castPtr pElement)+      1 -> SecondaryHosts   <$> peekDhcp hostInfo (castPtr pElement)+      2 -> ReservedIps      <$> peekDhcp reservation (castPtr pElement)+      3 -> ExcludedIpRanges <$> peek (castPtr pElement)+      4 -> IpUsedCluster    <$> peek (castPtr pElement)+      _ -> error "Invalid element type found in SUBNET_ELEMENT_DATA_V4."++freeSubnetElementData :: (forall x. Ptr x -> IO ())+    -> Ptr SUBNET_ELEMENT_DATA_V4 -> IO ()+freeSubnetElementData freefunc ptr = do+    elementType <- (peek . castPtr) ptr :: IO SUBNET_ELEMENT_TYPE+    scrubWith_ (ppElement ptr) $ \pElement -> do+        case elementType of+          0 -> return ()+          1 -> freeDhcp hostInfo freefunc $ castPtr pElement+          2 -> freeDhcp reservation freefunc $ castPtr pElement+          3 -> return ()+          4 -> return ()+          _ -> error "Invalid element type found in SUBNET_ELEMENT_DATA_V4."++-- Also used by withSubnetElementDataArray.+withSubnetElementData' :: SUBNET_ELEMENT_DATA_V4 -> Ptr SUBNET_ELEMENT_DATA_V4+    -> IO r -> IO r+withSubnetElementData' elementData ptr f = do+    castPtr ptr `poke` elementTypeOf elementData+    case elementData of+      IpRanges x -> with x $ \pX -> poke (ppElement ptr) pX >> f+      SecondaryHosts x -> withDhcp hostInfo x $ \pX -> poke (ppElement ptr) pX >> f+      ReservedIps x -> withDhcp reservation x $ \pX -> poke (ppElement ptr) pX >> f+      ExcludedIpRanges x -> with x $ \pX -> poke (ppElement ptr) pX >> f+      IpUsedCluster x -> with x $ \pX -> poke (ppElement ptr) pX >> f++ppElement :: Ptr SUBNET_ELEMENT_DATA_V4 -> Ptr a+ppElement ptr = castPtr $ ptr `plusPtr` 4++elementTypeOf :: SUBNET_ELEMENT_DATA_V4 -> SUBNET_ELEMENT_TYPE+elementTypeOf (IpRanges _)         = 0+elementTypeOf (SecondaryHosts _)   = 1+elementTypeOf (ReservedIps _)      = 2+elementTypeOf (ExcludedIpRanges _) = 3+elementTypeOf (IpUsedCluster _)    = 4

System/Win32/DHCP/Types.hs view

@@ -1,76 +1,76 @@-module System.Win32.DHCP.Types
-  ( ClientType (..)
-  , DATE_TIME (..)
-  , FORCE_FLAG (..)
-  , RESUME_HANDLE
-  ) where
-
-import Control.Applicative
-import Foreign
-
-import System.Win32.Types
-
--- | Microsoft's DHCP server supports DHCP and BOOTP. Both protocols server
--- similar purposes, but DHCP is more widely used. Lease and reservation
--- records contain a flag field indicating which protocol the record is valid
--- for. In most cases this flag will be `Both`, because that is the default
--- behavior.
-data ClientType = Unspecified | Dhcp | Bootp | Both | ReservationFlag | None
-    deriving (Eq)
-
-instance Enum ClientType where
-  toEnum 0x00 = Unspecified
-  toEnum 0x01 = Dhcp
-  toEnum 0x02 = Bootp
-  toEnum 0x03 = Both
-  toEnum 0x04 = ReservationFlag
-  toEnum 0x64 = None
-  toEnum x    = error $ "invalid ClientType: " ++ show x
-  fromEnum Unspecified     = 0x00
-  fromEnum Dhcp            = 0x01
-  fromEnum Bootp           = 0x02
-  fromEnum Both            = 0x03
-  fromEnum ReservationFlag = 0x04
-  fromEnum None            = 0x64
-
-instance Storable ClientType where
-  sizeOf _ = sizeOf (undefined :: BYTE)
-  alignment _ = alignment (undefined :: BYTE)
-  peek ptr = toEnum . fromIntegral <$> peek (pbyte ptr)
-  poke ptr ct = poke (pbyte ptr) . fromIntegral . fromEnum $ ct
-
-pbyte :: Ptr ClientType -> Ptr BYTE
-pbyte = castPtr
-
--- | The number of ticks (100-nanosecond increments) since 12:00 midnight,
--- January 1, 1 C.E. in the Gregorian calendar.
---
--- Microsoft does not provide any functions I know of for converting this
--- value into something more convenient to work with.
---
--- > typedef struct _DATE_TIME {
--- >     DWORD dwLowDateTime;
--- >     DWORD dwHighDateTime;
--- > } DATE_TIME,*PDATE_TIME, *LPDATE_TIME;
-data DATE_TIME = DATE_TIME !DWORD !DWORD
-
-instance Storable DATE_TIME where
-  sizeOf _ = 8
-  alignment _ = 4
-  peek ptr = DATE_TIME <$> peekElemOff (pdword ptr) 0
-                       <*> peekElemOff (pdword ptr) 1
-  poke ptr (DATE_TIME l h) = do
-    pokeElemOff (pdword ptr) 0 l
-    pokeElemOff (pdword ptr) 1 h
-
-pdword :: Ptr DATE_TIME -> Ptr DWORD
-pdword ptr = castPtr ptr
-
--- typedef enum _DHCP_FORCE_FLAG {
---   DhcpFullForce,
---   DhcpNoForce
--- } DHCP_FORCE_FLAG, *LPDHCP_FORCE_FLAG;
-data FORCE_FLAG = FullForce | NoForce
-    deriving (Enum)
-
-type RESUME_HANDLE = DWORD
+module System.Win32.DHCP.Types+  ( ClientType (..)+  , DATE_TIME (..)+  , FORCE_FLAG (..)+  , RESUME_HANDLE+  ) where++import Control.Applicative+import Foreign++import System.Win32.Types++-- | Microsoft's DHCP server supports DHCP and BOOTP. Both protocols server+-- similar purposes, but DHCP is more widely used. Lease and reservation+-- records contain a flag field indicating which protocol the record is valid+-- for. In most cases this flag will be `Both`, because that is the default+-- behavior.+data ClientType = Unspecified | Dhcp | Bootp | Both | ReservationFlag | None+    deriving (Eq)++instance Enum ClientType where+  toEnum 0x00 = Unspecified+  toEnum 0x01 = Dhcp+  toEnum 0x02 = Bootp+  toEnum 0x03 = Both+  toEnum 0x04 = ReservationFlag+  toEnum 0x64 = None+  toEnum x    = error $ "invalid ClientType: " ++ show x+  fromEnum Unspecified     = 0x00+  fromEnum Dhcp            = 0x01+  fromEnum Bootp           = 0x02+  fromEnum Both            = 0x03+  fromEnum ReservationFlag = 0x04+  fromEnum None            = 0x64++instance Storable ClientType where+  sizeOf _ = sizeOf (undefined :: BYTE)+  alignment _ = alignment (undefined :: BYTE)+  peek ptr = toEnum . fromIntegral <$> peek (pbyte ptr)+  poke ptr ct = poke (pbyte ptr) . fromIntegral . fromEnum $ ct++pbyte :: Ptr ClientType -> Ptr BYTE+pbyte = castPtr++-- | The number of ticks (100-nanosecond increments) since 12:00 midnight,+-- January 1, 1 C.E. in the Gregorian calendar.+--+-- Microsoft does not provide any functions I know of for converting this+-- value into something more convenient to work with.+--+-- > typedef struct _DATE_TIME {+-- >     DWORD dwLowDateTime;+-- >     DWORD dwHighDateTime;+-- > } DATE_TIME,*PDATE_TIME, *LPDATE_TIME;+data DATE_TIME = DATE_TIME !DWORD !DWORD++instance Storable DATE_TIME where+  sizeOf _ = 8+  alignment _ = 4+  peek ptr = DATE_TIME <$> peekElemOff (pdword ptr) 0+                       <*> peekElemOff (pdword ptr) 1+  poke ptr (DATE_TIME l h) = do+    pokeElemOff (pdword ptr) 0 l+    pokeElemOff (pdword ptr) 1 h++pdword :: Ptr DATE_TIME -> Ptr DWORD+pdword ptr = castPtr ptr++-- typedef enum _DHCP_FORCE_FLAG {+--   DhcpFullForce,+--   DhcpNoForce+-- } DHCP_FORCE_FLAG, *LPDHCP_FORCE_FLAG;+data FORCE_FLAG = FullForce | NoForce+    deriving (Enum)++type RESUME_HANDLE = DWORD

Utils.hs view

@@ -1,38 +1,51 @@-module Utils where
-
-import Control.Applicative
-import Control.Monad (unless)
-import Foreign
-
-import System.Win32.Types
-
--- |Many DHCP functions return a large object composed of pointers to other
---  objects. When it comes time to clean up memory we need to walk through
---  the structure. This helper function calls an action to get a pointer
---  to free (usually a variant of peek), and then calls the supplied free
---  action on it. Finally, the pointer is zeroed out.
-freeptr :: (Ptr b -> IO ()) -> Ptr (Ptr a) -> IO ()
-freeptr rpcfree pptr =
-    peek pptr >>= \ptr ->
-    unless (ptr == nullPtr) $ do
-    rpcfree $ castPtr ptr
-    poke pptr nullPtr
-
--- |Peek a string that might be null. Null pointers become Nothing
-peekMaybeTString :: LPTSTR -> IO (Maybe String)
-peekMaybeTString ptr
-  | ptr == nullPtr = return Nothing
-  | otherwise      = Just <$> peekTString ptr
-
--- |Temporarily marshal a Maybe String. A nothing becomes a null pointer.
-withMaybeTString :: Maybe String -> (LPTSTR -> IO a) -> IO a
-withMaybeTString Nothing    f = f nullPtr
-withMaybeTString (Just str) f = withTString str f
-
-note :: e -> Maybe a -> Either e a
-note e Nothing = Left e
-note _ (Just x) = Right x
-
-fmapL :: (a -> b) -> Either a r -> Either b r
-fmapL f (Left x) = Left (f x)
-fmapL _ (Right x) = (Right x)
+module Utils where++import Control.Applicative+import Foreign++import System.Win32.Types++-- | Perform an action over a double pointer, and then zero it out. If the+-- double pointer is already zeroed out, do nothing and return 'Nothing'.+scrubbing :: (Ptr a -> IO b) -> Ptr (Ptr a) -> IO (Maybe b)+scrubbing f pptr = do+    ptr <- peek pptr+    if ptr == nullPtr+      then return Nothing+      else do+        ret <- f ptr+        poke pptr nullPtr+        return $ Just ret++-- |Perform a cleanup operation on memory.+scrubbing_ :: (Ptr a -> IO ()) -> Ptr (Ptr a) -> IO ()+scrubbing_ f pptr = do+    _ <- scrubbing f pptr+    return ()++scrubWith :: Ptr (Ptr a) -> (Ptr a -> IO b) -> IO (Maybe b)+scrubWith = flip scrubbing++scrubWith_ :: Ptr (Ptr a) -> (Ptr a -> IO ()) -> IO ()+scrubWith_ pptr f = do+    _ <-scrubWith pptr f+    return ()++-- |Peek a string that might be null. Null pointers become Nothing+peekMaybeTString :: LPTSTR -> IO (Maybe String)+peekMaybeTString ptr+  | ptr == nullPtr = return Nothing+  | otherwise      = Just <$> peekTString ptr++-- |Temporarily marshal a Maybe String. A nothing becomes a null pointer.+withMaybeTString :: Maybe String -> (LPTSTR -> IO a) -> IO a+withMaybeTString Nothing    f = f nullPtr+withMaybeTString (Just str) f = withTString str f++note :: e -> Maybe a -> Either e a+note e Nothing = Left e+note _ (Just x) = Right x++fmapL :: (a -> b) -> Either a r -> Either b r+fmapL f (Left x) = Left (f x)+fmapL _ (Right x) = (Right x)

Win32-dhcp-server.cabal view

@@ -1,79 +1,79 @@-Name:                Win32-dhcp-server
-Synopsis:            Win32 DHCP Server Management API.
-Version:             0.2
-License:             BSD3
-License-file:        LICENSE
-Author:              Michael Steele
-Maintainer:          mikesteele81@gmail.com
-Copyright:           2013 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.14
-Tested-With:         GHC == 7.6.3
-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.
-  .
-  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
-  &#x20;   api <- loadDHCP
-  &#x20;   clients <- enumClients api context
-  &#x20;   let macs = map (showMac \":\" . clientHardwareAddress) clients
-  &#x20;   mapM_ T.putStrLn macs
-  &#x20; where
-  &#x20;   Right subnet = readIp \"192.168.1.0\"
-  &#x20;   context = Context \"192.168.1.5\" subnet
-  @
-extra-source-files:
-    ChangeLog
-    examples/*.hs
-
-Library
-  Build-depends: base         >= 4.6  && < 4.8
-               , text          > 0.11 && < 1.2
-               , Win32
-               , Win32-errors >= 0.2  && < 1.0
-  default-language: Haskell2010
-  Exposed-modules: Data.Ip
-                 , Data.Mac
-                 , System.Win32.DHCP
-  Ghc-Options: -funbox-strict-fields -Wall
-  other-modules: Utils
-               , System.Win32.DHCP.Internal
-               , System.Win32.DHCP.Client
-               , System.Win32.DHCP.CLIENT_UID
-               , System.Win32.DHCP.DhcpStructure
-               , System.Win32.DHCP.HOST_INFO
-               , System.Win32.DHCP.IP_CLUSTER
-               , System.Win32.DHCP.IP_RANGE
-               , System.Win32.DHCP.LengthBuffer
-               , System.Win32.DHCP.SEARCH_INFO
-               , System.Win32.DHCP.Reservation
-               , System.Win32.DHCP.SUBNET_CLIENT_INFO_ARRAY_V4
-               , System.Win32.DHCP.SUBNET_ELEMENT_DATA_V4
-               , System.Win32.DHCP.SUBNET_ELEMENT_INFO_ARRAY_V4
-               , System.Win32.DHCP.Types
+Name:                Win32-dhcp-server+Synopsis:            Win32 DHCP Server Management API+Version:             0.2.1+License:             BSD3+License-file:        LICENSE+Author:              Michael Steele+Maintainer:          mikesteele81@gmail.com+Copyright:           2013 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.14+Tested-With:         GHC == 7.8.3+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.+  .+  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+  &#x20;   api <- loadDHCP+  &#x20;   clients <- enumClients api context+  &#x20;   let macs = map (showMac \":\" . clientHardwareAddress) clients+  &#x20;   mapM_ T.putStrLn macs+  &#x20; where+  &#x20;   Right subnet = readIp \"192.168.1.0\"+  &#x20;   context = Context \"192.168.1.5\" subnet+  @+extra-source-files:+    ChangeLog+    examples/*.hs++Library+  Build-depends: base         >= 4.6  && < 4.8+               , text         >  0.11 && < 1.2+               , Win32        >= 2.2  && < 2.4+               , Win32-errors >= 0.2  && < 1.0+  default-language: Haskell2010+  Exposed-modules: Data.Ip+                 , Data.Mac+                 , System.Win32.DHCP+  Ghc-Options: -funbox-strict-fields -Wall+  other-modules: Utils+               , System.Win32.DHCP.Internal+               , System.Win32.DHCP.Client+               , System.Win32.DHCP.CLIENT_UID+               , System.Win32.DHCP.DhcpStructure+               , System.Win32.DHCP.HOST_INFO+               , System.Win32.DHCP.IP_CLUSTER+               , System.Win32.DHCP.IP_RANGE+               , System.Win32.DHCP.LengthBuffer+               , System.Win32.DHCP.SEARCH_INFO+               , System.Win32.DHCP.Reservation+               , System.Win32.DHCP.SUBNET_CLIENT_INFO_ARRAY_V4+               , System.Win32.DHCP.SUBNET_ELEMENT_DATA_V4+               , System.Win32.DHCP.SUBNET_ELEMENT_INFO_ARRAY_V4+               , System.Win32.DHCP.Types

examples/cabal.hs view

@@ -1,22 +1,22 @@--- This is the example used in the main .cabal file.
-
-{-# LANGUAGE OverloadedStrings #-}
-
--- 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
-
+-- This is the example used in the main .cabal file.++{-# LANGUAGE OverloadedStrings #-}++-- 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+