{-# LINE 1 "System/Linux/Netlink/C.hsc" #-}
{-# LANGUAGE ForeignFunctionInterface #-}
{-|
Module      : System.Linux.Netlink.C
Description : A module to bridge the haskell code to underlying C code
Maintainer  : ongy
Stability   : testing
Portability : Linux

I consider this module internal.
The documentation may be a bit sparse.
-}
module System.Linux.Netlink.C
    ( makeSocket
    , makeSocketGeneric
    , closeSocket
    , sendmsg
    , recvmsg
    , joinMulticastGroup
    , leaveMulticastGroup
    )
where



{-# LINE 25 "System/Linux/Netlink/C.hsc" #-}

{-# LINE 28 "System/Linux/Netlink/C.hsc" #-}

import Control.Monad (when)
import Data.ByteString (ByteString)
import Data.ByteString.Internal (createAndTrim, toForeignPtr)
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.Linux.Netlink.Constants (eAF_NETLINK, eNETLINK_ADD_MEMBERSHIP, eNETLINK_DROP_MEMBERSHIP)







-- FFI declarations for clib syscall wrappers
-- So if we are not blocking long or calling back into haskell it should be ok to do unsafe imports?
-- These should be done fast, and we know the will never call back into haskell
foreign import ccall unsafe "socket" c_socket :: CInt -> CInt -> CInt -> IO CInt
foreign import ccall unsafe "bind" c_bind :: CInt -> Ptr SockAddrNetlink -> Int -> IO CInt
foreign import ccall unsafe "close" c_close :: CInt -> IO CInt
foreign import ccall unsafe "setsockopt" c_setsockopt :: CInt -> CInt -> CInt -> Ptr a -> CInt -> IO CInt
foreign import ccall unsafe "memset" c_memset :: Ptr a -> CInt -> CInt -> IO ()

-- those two may block for a while, so we'll not do unsafe for them
foreign import ccall "sendmsg" c_sendmsg :: CInt -> Ptr MsgHdr -> CInt -> IO CInt
foreign import ccall "recvmsg" c_recvmsg :: CInt -> Ptr MsgHdr -> CInt -> IO CInt

data SockAddrNetlink = SockAddrNetlink Word32

instance Storable SockAddrNetlink where
    sizeOf :: SockAddrNetlink -> Int
sizeOf    SockAddrNetlink
_ = (Int
12)
{-# LINE 67 "System/Linux/Netlink/C.hsc" #-}
    alignment _ = 4
    peek :: Ptr SockAddrNetlink -> IO SockAddrNetlink
peek Ptr SockAddrNetlink
p = do
        family <- (\Ptr SockAddrNetlink
hsc_ptr -> Ptr SockAddrNetlink -> Int -> IO CShort
forall b. Ptr b -> Int -> IO CShort
forall a b. Storable a => Ptr b -> Int -> IO a
peekByteOff Ptr SockAddrNetlink
hsc_ptr Int
0) Ptr SockAddrNetlink
p
{-# LINE 70 "System/Linux/Netlink/C.hsc" #-}
        when ((family :: CShort) /= eAF_NETLINK) $ fail "Bad address family"
        SockAddrNetlink . fromIntegral <$> ((\Ptr SockAddrNetlink
hsc_ptr -> Ptr SockAddrNetlink -> Int -> IO CUInt
forall b. Ptr b -> Int -> IO CUInt
forall a b. Storable a => Ptr b -> Int -> IO a
peekByteOff Ptr SockAddrNetlink
hsc_ptr Int
4) p :: IO CUInt)
{-# LINE 72 "System/Linux/Netlink/C.hsc" #-}
    poke p (SockAddrNetlink pid) = do
        zero p
        (\hsc_ptr -> pokeByteOff hsc_ptr 0) p (eAF_NETLINK :: CShort)
{-# LINE 75 "System/Linux/Netlink/C.hsc" #-}
        (\hsc_ptr -> pokeByteOff hsc_ptr 4) p (fromIntegral pid :: CUInt)
{-# LINE 76 "System/Linux/Netlink/C.hsc" #-}

data IoVec = IoVec (Ptr (), Int)

instance Storable IoVec where
    sizeOf :: IoVec -> Int
sizeOf    IoVec
_ = (Int
16)
{-# LINE 81 "System/Linux/Netlink/C.hsc" #-}
    alignment _ = 4
    peek :: Ptr IoVec -> IO IoVec
peek Ptr IoVec
p = do
        addr <- (\Ptr IoVec
hsc_ptr -> Ptr IoVec -> Int -> IO (Ptr ())
forall b. Ptr b -> Int -> IO (Ptr ())
forall a b. Storable a => Ptr b -> Int -> IO a
peekByteOff Ptr IoVec
hsc_ptr Int
0) Ptr IoVec
p
{-# LINE 84 "System/Linux/Netlink/C.hsc" #-}
        len  <- (\Ptr IoVec
hsc_ptr -> Ptr IoVec -> Int -> IO CSize
forall b. Ptr b -> Int -> IO CSize
forall a b. Storable a => Ptr b -> Int -> IO a
peekByteOff Ptr IoVec
hsc_ptr Int
8)  p :: IO CSize
{-# LINE 85 "System/Linux/Netlink/C.hsc" #-}
        return $ IoVec (addr, fromIntegral len)
    poke :: Ptr IoVec -> IoVec -> IO ()
poke Ptr IoVec
p (IoVec (Ptr ()
addr, Int
len)) = do
        Ptr IoVec -> IO ()
forall a. Storable a => Ptr a -> IO ()
zero Ptr IoVec
p
        (\Ptr IoVec
hsc_ptr -> Ptr IoVec -> Int -> Ptr () -> IO ()
forall b. Ptr b -> Int -> Ptr () -> IO ()
forall a b. Storable a => Ptr b -> Int -> a -> IO ()
pokeByteOff Ptr IoVec
hsc_ptr Int
0) Ptr IoVec
p Ptr ()
addr
{-# LINE 89 "System/Linux/Netlink/C.hsc" #-}
        (\Ptr IoVec
hsc_ptr -> Ptr IoVec -> Int -> CSize -> IO ()
forall b. Ptr b -> Int -> CSize -> IO ()
forall a b. Storable a => Ptr b -> Int -> a -> IO ()
pokeByteOff Ptr IoVec
hsc_ptr Int
8) Ptr IoVec
p (Int -> CSize
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
len :: CSize)
{-# LINE 90 "System/Linux/Netlink/C.hsc" #-}

data MsgHdr = MsgHdr (Ptr (), Int)

instance Storable MsgHdr where
    sizeOf :: MsgHdr -> Int
sizeOf    MsgHdr
_ = (Int
56)
{-# LINE 95 "System/Linux/Netlink/C.hsc" #-}
    alignment _ = 4
    peek :: Ptr MsgHdr -> IO MsgHdr
peek Ptr MsgHdr
p = do
        iov     <- (\Ptr MsgHdr
hsc_ptr -> Ptr MsgHdr -> Int -> IO (Ptr ())
forall b. Ptr b -> Int -> IO (Ptr ())
forall a b. Storable a => Ptr b -> Int -> IO a
peekByteOff Ptr MsgHdr
hsc_ptr Int
16) Ptr MsgHdr
p
{-# LINE 98 "System/Linux/Netlink/C.hsc" #-}
        iovlen  <- (\Ptr MsgHdr
hsc_ptr -> Ptr MsgHdr -> Int -> IO CSize
forall b. Ptr b -> Int -> IO CSize
forall a b. Storable a => Ptr b -> Int -> IO a
peekByteOff Ptr MsgHdr
hsc_ptr Int
24) p :: IO CSize
{-# LINE 99 "System/Linux/Netlink/C.hsc" #-}
        return $ MsgHdr (iov, fromIntegral iovlen)
    poke :: Ptr MsgHdr -> MsgHdr -> IO ()
poke Ptr MsgHdr
p (MsgHdr (Ptr ()
iov, Int
iovlen)) = do
        Ptr MsgHdr -> IO ()
forall a. Storable a => Ptr a -> IO ()
zero Ptr MsgHdr
p
        (\Ptr MsgHdr
hsc_ptr -> Ptr MsgHdr -> Int -> Ptr () -> IO ()
forall b. Ptr b -> Int -> Ptr () -> IO ()
forall a b. Storable a => Ptr b -> Int -> a -> IO ()
pokeByteOff Ptr MsgHdr
hsc_ptr Int
16) Ptr MsgHdr
p Ptr ()
iov
{-# LINE 103 "System/Linux/Netlink/C.hsc" #-}
        (\Ptr MsgHdr
hsc_ptr -> Ptr MsgHdr -> Int -> CSize -> IO ()
forall b. Ptr b -> Int -> CSize -> IO ()
forall a b. Storable a => Ptr b -> Int -> a -> IO ()
pokeByteOff Ptr MsgHdr
hsc_ptr Int
24) Ptr MsgHdr
p (Int -> CSize
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
iovlen :: CSize)
{-# LINE 104 "System/Linux/Netlink/C.hsc" #-}


-- |Create a netlink socket, for legacy reasons this will be of the route family
makeSocket :: IO CInt
makeSocket :: IO CInt
makeSocket = Int -> IO CInt
makeSocketGeneric Int
0
{-# LINE 109 "System/Linux/Netlink/C.hsc" #-}

-- TODO maybe readd the unique thingy (look at git log)
-- |Create any netlink socket
makeSocketGeneric 
  :: Int -- ^The netlink family to use
  -> IO CInt
makeSocketGeneric :: Int -> IO CInt
makeSocketGeneric Int
prot = do
  fd <- String -> IO CInt -> IO CInt
forall a. (Eq a, Num a) => String -> IO a -> IO a
throwErrnoIfMinus1 String
"makeSocket.socket" (IO CInt -> IO CInt) -> IO CInt -> IO CInt
forall a b. (a -> b) -> a -> b
$
          CInt -> CInt -> CInt -> IO CInt
c_socket CInt
forall a. Num a => a
eAF_NETLINK CInt
3 (Int -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
prot)
{-# LINE 118 "System/Linux/Netlink/C.hsc" #-}
  -- we need to bind or joining multicast groups will be useless
  with (SockAddrNetlink 0) $ \Ptr SockAddrNetlink
addr ->
    String -> IO CInt -> IO ()
forall a. (Eq a, Num a) => String -> IO a -> IO ()
throwErrnoIfMinus1_ String
"makeSocket.bind" (IO CInt -> IO ()) -> IO CInt -> IO ()
forall a b. (a -> b) -> a -> b
$
      CInt -> Ptr SockAddrNetlink -> Int -> IO CInt
c_bind CInt
fd (Ptr SockAddrNetlink -> Ptr SockAddrNetlink
forall a b. Ptr a -> Ptr b
castPtr Ptr SockAddrNetlink
addr) (Int
12)
{-# LINE 122 "System/Linux/Netlink/C.hsc" #-}
  return fd


-- |Close a socket when it is not needed anymore
closeSocket :: CInt -> IO ()
closeSocket :: CInt -> IO ()
closeSocket CInt
fd = String -> IO CInt -> IO ()
forall a. (Eq a, Num a) => String -> IO a -> IO ()
throwErrnoIfMinus1_ String
"closeSocket" (IO CInt -> IO ()) -> IO CInt -> IO ()
forall a b. (a -> b) -> a -> b
$ CInt -> IO CInt
c_close CInt
fd

-- |Send a message over a socket.
sendmsg :: CInt -> [ByteString] -> IO ()
sendmsg :: CInt -> [ByteString] -> IO ()
sendmsg CInt
fd [ByteString]
bs =
    [ByteString] -> ([(Ptr (), Int)] -> IO ()) -> IO ()
forall a. [ByteString] -> ([(Ptr (), Int)] -> IO a) -> IO a
useManyAsPtrLen [ByteString]
bs (([(Ptr (), Int)] -> IO ()) -> IO ())
-> ([(Ptr (), Int)] -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \[(Ptr (), Int)]
ptrs ->
    [IoVec] -> (Int -> Ptr IoVec -> IO ()) -> IO ()
forall a b. Storable a => [a] -> (Int -> Ptr a -> IO b) -> IO b
withArrayLen (((Ptr (), Int) -> IoVec) -> [(Ptr (), Int)] -> [IoVec]
forall a b. (a -> b) -> [a] -> [b]
map (Ptr (), Int) -> IoVec
IoVec [(Ptr (), Int)]
ptrs) ((Int -> Ptr IoVec -> IO ()) -> IO ())
-> (Int -> Ptr IoVec -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Int
iovlen Ptr IoVec
iov ->
    MsgHdr -> (Ptr MsgHdr -> IO ()) -> IO ()
forall a b. Storable a => a -> (Ptr a -> IO b) -> IO b
with ((Ptr (), Int) -> MsgHdr
MsgHdr (Ptr IoVec -> Ptr ()
forall a b. Ptr a -> Ptr b
castPtr Ptr IoVec
iov, Int
iovlen)) ((Ptr MsgHdr -> IO ()) -> IO ()) -> (Ptr MsgHdr -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Ptr MsgHdr
msg ->
    String -> IO CInt -> IO ()
forall a. (Eq a, Num a) => String -> IO a -> IO ()
throwErrnoIfMinus1_ String
"sendmsg" (IO CInt -> IO ()) -> IO CInt -> IO ()
forall a b. (a -> b) -> a -> b
$CInt -> Ptr MsgHdr -> CInt -> IO CInt
c_sendmsg CInt
fd (Ptr MsgHdr -> Ptr MsgHdr
forall a b. Ptr a -> Ptr b
castPtr Ptr MsgHdr
msg) (CInt
0 :: CInt)

-- |Receive a message over a socket.
recvmsg :: CInt -> Int -> IO ByteString
recvmsg :: CInt -> Int -> IO ByteString
recvmsg CInt
fd Int
len =
    Int -> (Ptr Word8 -> IO Int) -> IO ByteString
createAndTrim Int
len ((Ptr Word8 -> IO Int) -> IO ByteString)
-> (Ptr Word8 -> IO Int) -> IO ByteString
forall a b. (a -> b) -> a -> b
$ \Ptr Word8
ptr ->
    IoVec -> (Ptr IoVec -> IO Int) -> IO Int
forall a b. Storable a => a -> (Ptr a -> IO b) -> IO b
with ((Ptr (), Int) -> IoVec
IoVec (Ptr Word8 -> Ptr ()
forall a b. Ptr a -> Ptr b
castPtr Ptr Word8
ptr, Int
len)) ((Ptr IoVec -> IO Int) -> IO Int)
-> (Ptr IoVec -> IO Int) -> IO Int
forall a b. (a -> b) -> a -> b
$ \Ptr IoVec
vec ->
    MsgHdr -> (Ptr MsgHdr -> IO Int) -> IO Int
forall a b. Storable a => a -> (Ptr a -> IO b) -> IO b
with ((Ptr (), Int) -> MsgHdr
MsgHdr (Ptr IoVec -> Ptr ()
forall a b. Ptr a -> Ptr b
castPtr Ptr IoVec
vec, Int
1)) ((Ptr MsgHdr -> IO Int) -> IO Int)
-> (Ptr MsgHdr -> IO Int) -> IO Int
forall a b. (a -> b) -> a -> b
$ \Ptr MsgHdr
msg ->
    (CInt -> Int) -> IO CInt -> IO Int
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap CInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (IO CInt -> IO Int) -> (IO CInt -> IO CInt) -> IO CInt -> IO Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CInt -> Bool) -> String -> IO CInt -> IO CInt
forall a. (a -> Bool) -> String -> IO a -> IO a
throwErrnoIf (CInt -> CInt -> Bool
forall a. Ord a => a -> a -> Bool
<= CInt
0) String
"recvmsg" (IO CInt -> IO Int) -> IO CInt -> IO Int
forall a b. (a -> b) -> a -> b
$
        CInt -> Ptr MsgHdr -> CInt -> IO CInt
c_recvmsg CInt
fd (Ptr MsgHdr -> Ptr MsgHdr
forall a b. Ptr a -> Ptr b
castPtr Ptr MsgHdr
msg) (CInt
0 :: CInt)

useManyAsPtrLen :: [ByteString] -> ([(Ptr (), Int)] -> IO a) -> IO a
useManyAsPtrLen :: forall a. [ByteString] -> ([(Ptr (), Int)] -> IO a) -> IO a
useManyAsPtrLen [ByteString]
bs [(Ptr (), Int)] -> IO a
act =
    let makePtrLen :: (ForeignPtr a, Int, b) -> (Ptr b, b)
makePtrLen (ForeignPtr a
fptr, Int
off, b
len) =
            let ptr :: Ptr b
ptr = Ptr a -> Int -> Ptr b
forall a b. Ptr a -> Int -> Ptr b
plusPtr (ForeignPtr a -> Ptr a
forall a. ForeignPtr a -> Ptr a
unsafeForeignPtrToPtr ForeignPtr a
fptr) Int
off
            in (Ptr b
forall {b}. Ptr b
ptr, b
len)
        touchByteStringPtr :: (ForeignPtr a, b, c) -> IO ()
touchByteStringPtr (ForeignPtr a
fptr, b
_, c
_) = ForeignPtr a -> IO ()
forall a. ForeignPtr a -> IO ()
touchForeignPtr ForeignPtr a
fptr
        foreigns :: [(ForeignPtr Word8, Int, Int)]
foreigns = (ByteString -> (ForeignPtr Word8, Int, Int))
-> [ByteString] -> [(ForeignPtr Word8, Int, Int)]
forall a b. (a -> b) -> [a] -> [b]
map ByteString -> (ForeignPtr Word8, Int, Int)
toForeignPtr [ByteString]
bs
    in [(Ptr (), Int)] -> IO a
act (((ForeignPtr Word8, Int, Int) -> (Ptr (), Int))
-> [(ForeignPtr Word8, Int, Int)] -> [(Ptr (), Int)]
forall a b. (a -> b) -> [a] -> [b]
map (ForeignPtr Word8, Int, Int) -> (Ptr (), Int)
forall {a} {b} {b}. (ForeignPtr a, Int, b) -> (Ptr b, b)
makePtrLen [(ForeignPtr Word8, Int, Int)]
foreigns) IO a -> IO () -> IO a
forall a b. IO a -> IO b -> IO a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ((ForeignPtr Word8, Int, Int) -> IO ())
-> [(ForeignPtr Word8, Int, Int)] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (ForeignPtr Word8, Int, Int) -> IO ()
forall {a} {b} {c}. (ForeignPtr a, b, c) -> IO ()
touchByteStringPtr [(ForeignPtr Word8, Int, Int)]
foreigns

sizeOfPtr :: (Storable a, Integral b) => Ptr a -> b
sizeOfPtr :: forall a b. (Storable a, Integral b) => Ptr a -> b
sizeOfPtr = Int -> b
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> b) -> (Ptr a -> Int) -> Ptr a -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Int
forall a. Storable a => a -> Int
sizeOf (a -> Int) -> (Ptr a -> a) -> Ptr a -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Ptr a -> a
forall {a}. Ptr a -> a
forall a. HasCallStack => a
undefined :: Ptr a -> a)

zero :: Storable a => Ptr a -> IO ()
zero :: forall a. Storable a => Ptr a -> IO ()
zero Ptr a
p = IO () -> IO ()
forall (m :: * -> *) a. Monad m => m a -> m ()
void (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Ptr Any -> CInt -> CInt -> IO ()
forall a. Ptr a -> CInt -> CInt -> IO ()
c_memset (Ptr a -> Ptr Any
forall a b. Ptr a -> Ptr b
castPtr Ptr a
p) CInt
0 (Ptr a -> CInt
forall a b. (Storable a, Integral b) => Ptr a -> b
sizeOfPtr Ptr a
p)

void :: Monad m => m a -> m ()
void :: forall (m :: * -> *) a. Monad m => m a -> m ()
void m a
act = m a
act m a -> m () -> m ()
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> () -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()


-- |Set membership to netlink multicast group
joinOrLeaveMulticastGroup :: Bool -> CInt -> Word32 -> IO ()
joinOrLeaveMulticastGroup :: Bool -> CInt -> Word32 -> IO ()
joinOrLeaveMulticastGroup Bool
beMember CInt
fd Word32
fid = do
  _ <- String -> IO CInt -> IO CInt
forall a. (Eq a, Num a) => String -> IO a -> IO a
throwErrnoIfMinus1 String
"joinMulticast" (IO CInt -> IO CInt) -> IO CInt -> IO CInt
forall a b. (a -> b) -> a -> b
$ Word32 -> (Ptr Word32 -> IO CInt) -> IO CInt
forall a b. Storable a => a -> (Ptr a -> IO b) -> IO b
with Word32
fid (\Ptr Word32
ptr ->
    CInt -> CInt -> CInt -> Ptr Any -> CInt -> IO CInt
forall a. CInt -> CInt -> CInt -> Ptr a -> CInt -> IO CInt
c_setsockopt CInt
fd CInt
sol_netlink CInt
value (Ptr Word32 -> Ptr Any
forall a b. Ptr a -> Ptr b
castPtr Ptr Word32
ptr) CInt
size)
  return ()
  where
    size :: CInt
size = Int -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> CInt) -> Int -> CInt
forall a b. (a -> b) -> a -> b
$CInt -> Int
forall a. Storable a => a -> Int
sizeOf (CInt
forall a. HasCallStack => a
undefined :: CInt)
    sol_netlink :: CInt
sol_netlink = CInt
270 :: CInt
    value :: CInt
value = if Bool
beMember
      then CInt
forall a. Num a => a
eNETLINK_ADD_MEMBERSHIP
      else CInt
forall a. Num a => a
eNETLINK_DROP_MEMBERSHIP

-- |Join a netlink multicast group
joinMulticastGroup :: CInt -> Word32 -> IO ()
joinMulticastGroup :: CInt -> Word32 -> IO ()
joinMulticastGroup = Bool -> CInt -> Word32 -> IO ()
joinOrLeaveMulticastGroup Bool
True

-- |Leave a netlink multicast group
leaveMulticastGroup :: CInt -> Word32 -> IO ()
leaveMulticastGroup :: CInt -> Word32 -> IO ()
leaveMulticastGroup = Bool -> CInt -> Word32 -> IO ()
joinOrLeaveMulticastGroup Bool
False