module System.Linux.Netlink.C
(
NetlinkSocket
, makeSocket
, closeSocket
, sendmsg
, recvmsg
, cFromEnum
, cToEnum
) where
import Control.Applicative ((<$>), (<*))
import Control.Monad (when)
import Data.Bits (Bits, (.|.), shiftL)
import Data.ByteString (ByteString)
import Data.ByteString.Internal (createAndTrim, toForeignPtr)
import Data.Unique (hashUnique, newUnique)
import Data.Word (Word32)
import Foreign.C.Error (throwErrnoIf, throwErrnoIfMinus1, throwErrnoIfMinus1_)
import Foreign.C.Types
import Foreign.ForeignPtr (touchForeignPtr)
import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr)
import Foreign.Marshal.Array (withArrayLen)
import Foreign.Marshal.Utils (with)
import Foreign.Ptr (Ptr, castPtr, plusPtr)
import Foreign.Storable (Storable(..))
import System.Posix.Process (getProcessID)
import System.Linux.Netlink.Constants (eAF_NETLINK)
newtype NetlinkSocket = NS CInt
makeSocket :: IO NetlinkSocket
makeSocket = do
fd <- throwErrnoIfMinus1 "makeSocket.socket" $
(socket
eAF_NETLINK
(cFromEnum Raw)
(cFromEnum Route))
unique <- fromIntegral . hashUnique <$> newUnique
pid <- fromIntegral <$> getProcessID
let sockId = (unique `shiftL` 16) .|. pid
with (SockAddrNetlink sockId) $ \addr ->
throwErrnoIfMinus1_ "makeSocket.bind" $ do
bind fd (castPtr addr) 12
return $ NS fd
closeSocket :: NetlinkSocket -> IO ()
closeSocket (NS fd) = throwErrnoIfMinus1_ "closeSocket" $ close fd
sendmsg :: NetlinkSocket -> [ByteString] -> IO ()
sendmsg (NS fd) bs =
useManyAsPtrLen bs $ \ptrs ->
withArrayLen (map IoVec ptrs) $ \iovlen iov ->
with (MsgHdr (castPtr iov, iovlen)) $ \msg ->
throwErrnoIfMinus1_ "sendmsg" $ do
_sendmsg fd (castPtr msg) (0 :: CInt)
recvmsg :: NetlinkSocket -> Int -> IO ByteString
recvmsg (NS fd) len =
createAndTrim len $ \ptr ->
with (IoVec (castPtr ptr, len)) $ \vec ->
with (MsgHdr (castPtr vec, 1)) $ \msg ->
fmap fromIntegral . throwErrnoIf (<= 0) "recvmsg" $ do
_recvmsg fd (castPtr msg) (0 :: CInt)
data PF = Route
instance Enum PF where
fromEnum Route = 0
toEnum 0 = Route
toEnum unmatched = error ("PF.toEnum: Cannot match " ++ show unmatched)
data ST = Raw
instance Enum ST where
fromEnum Raw = 3
toEnum 3 = Raw
toEnum unmatched = error ("ST.toEnum: Cannot match " ++ show unmatched)
data IoVec = IoVec (Ptr (), Int)
instance Storable IoVec where
sizeOf _ = 8
alignment _ = 4
peek p = do
addr <- (\ptr -> do {peekByteOff ptr 0 ::IO (Ptr ())}) p
len <- (\ptr -> do {peekByteOff ptr 4 ::IO CUInt}) p
return $ IoVec (addr, (fromIntegral len))
poke p (IoVec (addr, len)) = do
zero p
(\ptr val -> do {pokeByteOff ptr 0 (val::(Ptr ()))}) p addr
(\ptr val -> do {pokeByteOff ptr 4 (val::CUInt)}) p (fromIntegral len)
data MsgHdr = MsgHdr (Ptr (), Int)
instance Storable MsgHdr where
sizeOf _ = 8
alignment _ = 4
peek p = do
iov <- (\ptr -> do {peekByteOff ptr 8 ::IO (Ptr ())}) p
iovlen <- (\ptr -> do {peekByteOff ptr 12 ::IO CUInt}) p
return $ MsgHdr (iov, fromIntegral iovlen)
poke p (MsgHdr (iov, iovlen)) = do
zero p
(\ptr val -> do {pokeByteOff ptr 8 (val::(Ptr ()))}) p iov
(\ptr val -> do {pokeByteOff ptr 12 (val::CUInt)}) p (fromIntegral iovlen)
data SockAddrNetlink = SockAddrNetlink Word32
instance Storable SockAddrNetlink where
sizeOf _ = 12
alignment _ = 4
peek p = do
family <- (\ptr -> do {peekByteOff ptr 0 ::IO CUShort}) p
when (family /= eAF_NETLINK) $ fail "Bad address family"
SockAddrNetlink . fromIntegral <$> (\ptr -> do {peekByteOff ptr 4 ::IO CUInt}) p
poke p (SockAddrNetlink pid) = do
zero p
(\ptr val -> do {pokeByteOff ptr 0 (val::CUShort)}) p eAF_NETLINK
(\ptr val -> do {pokeByteOff ptr 4 (val::CUInt)}) p (fromIntegral pid)
useManyAsPtrLen :: [ByteString] -> ([(Ptr (), Int)] -> IO a) -> IO a
useManyAsPtrLen bs act =
let makePtrLen (fptr, off, len) =
let ptr = plusPtr (unsafeForeignPtrToPtr fptr) off
in (ptr, len)
touchByteStringPtr (fptr, _, _) = touchForeignPtr fptr
foreigns = map toForeignPtr bs
in act (map makePtrLen foreigns) <* mapM_ touchByteStringPtr foreigns
sizeOfPtr :: (Storable a, Integral b) => Ptr a -> b
sizeOfPtr = fromIntegral . sizeOf . (undefined :: Ptr a -> a)
zero :: Storable a => Ptr a -> IO ()
zero p = void $ memset (castPtr p) 0 (sizeOfPtr p)
void :: Monad m => m a -> m ()
void act = act >> return ()
cFromEnum :: (Enum e, Integral i) => e -> i
cFromEnum = fromIntegral . fromEnum
cToEnum :: (Integral i, Enum e) => i -> e
cToEnum = toEnum . fromIntegral
foreign import ccall safe "System/Linux/Netlink/C.chs.h socket"
socket :: (CInt -> (CInt -> (CInt -> (IO CInt))))
foreign import ccall safe "System/Linux/Netlink/C.chs.h bind"
bind :: (CInt -> ((Ptr ()) -> (CUInt -> (IO CInt))))
foreign import ccall safe "System/Linux/Netlink/C.chs.h close"
close :: (CInt -> (IO CInt))
foreign import ccall safe "System/Linux/Netlink/C.chs.h sendmsg"
_sendmsg :: (CInt -> ((Ptr ()) -> (CInt -> (IO CInt))))
foreign import ccall safe "System/Linux/Netlink/C.chs.h recvmsg"
_recvmsg :: (CInt -> ((Ptr ()) -> (CInt -> (IO CInt))))
foreign import ccall safe "System/Linux/Netlink/C.chs.h memset"
memset :: ((Ptr ()) -> (CInt -> (CUInt -> (IO (Ptr ())))))