-- GENERATED by C->Haskell Compiler, version 0.16.3 Crystal Seed, 24 Jan 2009 (Haskell)
-- Edit the ORIGNAL .chs file instead!


{-# LINE 1 "./System/Linux/Netlink/C.chs" #-}{-# LANGUAGE ForeignFunctionInterface #-}
{-# OPTIONS_GHC -fno-warn-overlapping-patterns #-}

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
{-# LINE 52 "./System/Linux/Netlink/C.chs" #-}
           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
{-# LINE 61 "./System/Linux/Netlink/C.chs" #-}
    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)

{-# LINE 83 "./System/Linux/Netlink/C.chs" #-}
data ST = Raw
        
instance Enum ST where
  fromEnum Raw = 3

  toEnum 3 = Raw
  toEnum unmatched = error ("ST.toEnum: Cannot match " ++ show unmatched)

{-# LINE 84 "./System/Linux/Netlink/C.chs" #-}

data IoVec = IoVec (Ptr (), Int)

instance Storable IoVec where
    sizeOf    _ = 8
{-# LINE 89 "./System/Linux/Netlink/C.chs" #-}
    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
{-# LINE 103 "./System/Linux/Netlink/C.chs" #-}
    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
{-# LINE 117 "./System/Linux/Netlink/C.chs" #-}
    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 ())))))