module Network.Socket.NetPacket
where
import Network.Socket
import Foreign.C.Types
import Foreign.C.Error
import Foreign.C.String
import Foreign.Storable
import Foreign.Ptr
import Control.Monad
import qualified Data.ByteString as BS
import qualified Data.ByteString.Unsafe as BS
import Data.Word
import Control.Applicative
import Network.Socket.InterfaceRequest
import Foreign.Storable.Asymmetric
import Network.Socket.IOCtl
import GHC.Conc (threadWaitWrite, threadWaitRead)
import Data.Maybe
import Foreign.Marshal
foreign import ccall "sendto" c_sendto_ll :: CInt -> CString -> CSize -> CInt -> Ptr SockAddrLL -> CSize -> IO CSize
foreign import ccall "recvfrom" c_recvfrom_ll :: CInt -> CString -> CSize -> CInt -> Ptr SockAddrLL -> Ptr CSize -> IO CSize
foreign import ccall "setsockopt" c_setsockopt_ll :: CInt -> CInt -> CInt -> Ptr () -> CSize -> IO CInt
foreign import ccall "bind" c_bind_ll :: CInt -> Ptr SockAddrLL -> CSize -> IO CInt
ethProtocolIPv4 :: ProtocolNumber
ethProtocolIPv4 = 8
ethProtocolIPv6 :: ProtocolNumber
ethProtocolIPv6 = 56710
ethProtocolAll :: ProtocolNumber
ethProtocolAll = 768
data PktType = PktType { unPktType :: Word8 } deriving (Eq, Ord, Show)
packetHost :: PktType
packetHost = PktType 0
packetBroadcast :: PktType
packetBroadcast = PktType 1
packetMulticast :: PktType
packetMulticast = PktType 2
packetOtherhost :: PktType
packetOtherhost = PktType 3
packetOutgoing :: PktType
packetOutgoing = PktType 4
packetLoopback :: PktType
packetLoopback = PktType 5
packetFastroute :: PktType
packetFastroute = PktType 6
afPacket :: CInt
afPacket = 17
newtype LLProtocol = LLProtocol Word16 deriving (Eq, Ord, Show)
lLProtocolIPv4 :: LLProtocol
lLProtocolIPv4 = LLProtocol 8
lLProtocolIPv6 :: LLProtocol
lLProtocolIPv6 = LLProtocol 56710
lLProtocolAll :: LLProtocol
lLProtocolAll = LLProtocol 768
newtype HardwareType = HardwareType Word16 deriving (Eq, Ord, Show)
hwTypeEther = HardwareType 0x1
data HWAddr = HWAddr BS.ByteString deriving (Eq, Ord, Show)
noHWAddr = HWAddr BS.empty
newtype IFIndex = IFIndex Int deriving (Eq, Ord, Show)
data SockAddrLL = SockAddrLL LLProtocol IFIndex HardwareType PktType HWAddr deriving (Eq, Ord, Show)
defaultSockAddrLL = SockAddrLL lLProtocolIPv4 (IFIndex 0) hwTypeEther packetHost (HWAddr $ BS.pack [])
solPacket :: CInt
solPacket = 263
newtype PacketSocketOption = PacketSocketOption Int deriving (Eq, Ord, Show)
packetAddMembership :: PacketSocketOption
packetAddMembership = PacketSocketOption 1
packetDropMembership :: PacketSocketOption
packetDropMembership = PacketSocketOption 2
packetRecvOutput :: PacketSocketOption
packetRecvOutput = PacketSocketOption 3
packetRXRing :: PacketSocketOption
packetRXRing = PacketSocketOption 5
packetStatistics :: PacketSocketOption
packetStatistics = PacketSocketOption 6
newtype PacketMReqType = PacketMReqType Word16 deriving (Eq, Ord, Show)
mrMulticast :: PacketMReqType
mrMulticast = PacketMReqType 0
mrPromisc :: PacketMReqType
mrPromisc = PacketMReqType 1
mrAllMulti :: PacketMReqType
mrAllMulti = PacketMReqType 2
data PacketMReq = PacketMReq IFIndex PacketMReqType HWAddr
instance Storable LLProtocol where
sizeOf _ = sizeOf (undefined :: Word16)
alignment _ = alignment (undefined :: Word16)
peek p = liftM LLProtocol $ peek (castPtr p)
poke p (LLProtocol v) = poke (castPtr p) v
instance Storable HardwareType where
sizeOf _ = sizeOf (undefined :: Word16)
alignment _ = alignment (undefined :: Word16)
peek p = liftM HardwareType $ peek (castPtr p)
poke p (HardwareType v) = poke (castPtr p) v
instance Storable PktType where
sizeOf _ = sizeOf (undefined :: Word8)
alignment _ = alignment (undefined :: Word8)
peek p = liftM PktType (peek (castPtr p))
poke p v = poke ((castPtr p) :: Ptr Word8) (unPktType v)
instance Storable IFIndex where
sizeOf _ = sizeOf (undefined :: Word32)
alignment _ = alignment (undefined :: Word32)
peek p = liftM (IFIndex . fromIntegral) $ peek ((castPtr p) :: Ptr CInt)
poke p (IFIndex v) = poke ((castPtr p) :: Ptr CInt) (fromIntegral v)
instance Storable SockAddrLL where
sizeOf _ = (20)
alignment _ = alignment (undefined :: CInt)
peek p = SockAddrLL <$>
(peek $ ((\hsc_ptr -> hsc_ptr `plusPtr` 2)) p) <*>
(peek $ ((\hsc_ptr -> hsc_ptr `plusPtr` 4)) p) <*>
(peek $ ((\hsc_ptr -> hsc_ptr `plusPtr` 8)) p) <*>
(peek $ ((\hsc_ptr -> hsc_ptr `plusPtr` 10)) p) <*>
(HWAddr <$> ((((,) (((\hsc_ptr -> hsc_ptr `plusPtr` 12)) p)) <$>
liftM fromIntegral ((((\hsc_ptr -> peekByteOff hsc_ptr 11)) p) :: IO Word8)) >>= BS.packCStringLen))
poke p (SockAddrLL proto ifi hatype pkttype (HWAddr hwaddr)) = do
((\hsc_ptr -> pokeByteOff hsc_ptr 0)) p afPacket
poke (((\hsc_ptr -> hsc_ptr `plusPtr` 2)) p) proto
poke (((\hsc_ptr -> hsc_ptr `plusPtr` 4)) p) ifi
poke (((\hsc_ptr -> hsc_ptr `plusPtr` 8)) p) hatype
poke (((\hsc_ptr -> hsc_ptr `plusPtr` 10)) p) pkttype
BS.unsafeUseAsCStringLen hwaddr $ \(chwaddr, l) -> do
poke (((\hsc_ptr -> hsc_ptr `plusPtr` 11)) p) ((fromIntegral l) :: Word8)
let aptr = ((\hsc_ptr -> hsc_ptr `plusPtr` 12)) p
forM_ [0..7] $ \idx -> do
v <- if idx < l then peekByteOff chwaddr idx
else return 0
pokeByteOff aptr idx (v :: Word8)
instance Storable PacketSocketOption where
sizeOf _ = sizeOf (undefined :: CInt)
alignment _ = alignment (undefined :: CInt)
peek p = liftM (PacketSocketOption . fromIntegral) $ (peek (castPtr p) :: IO CInt)
poke p (PacketSocketOption v) = poke (castPtr p :: Ptr CInt) (fromIntegral v)
instance Storable PacketMReqType where
sizeOf _ = sizeOf (undefined :: Word16)
alignment _ = alignment (undefined :: Word16)
peek p = liftM (PacketMReqType . fromIntegral) $ (peek (castPtr p) :: IO Word16)
poke p (PacketMReqType v) = poke (castPtr p :: Ptr Word16) (fromIntegral v)
instance Storable PacketMReq where
sizeOf _ = (16)
alignment _ = alignment (undefined :: CInt)
peek p = PacketMReq <$> (peek $ ((\hsc_ptr -> hsc_ptr `plusPtr` 0)) p) <*>
(peek $ ((\hsc_ptr -> hsc_ptr `plusPtr` 4)) p) <*>
(HWAddr <$> ((((,) (((\hsc_ptr -> hsc_ptr `plusPtr` 8)) p)) <$>
liftM fromIntegral ((((\hsc_ptr -> peekByteOff hsc_ptr 8)) p) :: IO Word16)) >>= BS.packCStringLen))
poke p (PacketMReq ii mt (HWAddr a)) = do
poke (((\hsc_ptr -> hsc_ptr `plusPtr` 0)) p) ii
poke (((\hsc_ptr -> hsc_ptr `plusPtr` 4)) p) mt
BS.unsafeUseAsCStringLen a $ \(chwaddr, l) -> do
poke (((\hsc_ptr -> hsc_ptr `plusPtr` 6)) p) ((fromIntegral l) :: Word16)
let aptr = ((\hsc_ptr -> hsc_ptr `plusPtr` 8)) p
forM_ [0..7] $ \idx -> do
v <- if idx < l then peekByteOff chwaddr idx
else return 0
pokeByteOff aptr idx (v :: Word8)
data GetIndexForName = GetIndexForName
instance IOControl GetIndexForName (DifferentPeekPoke (InterfaceRequest NoData) (InterfaceRequest CInt)) where
ioctlReq _ = 0x8933
getInterfaceIndex :: Socket -> String -> IO IFIndex
getInterfaceIndex s n = do
liftA (IFIndex . fromIntegral . irValue . getPeek) $ ioctlsocket s GetIndexForName (PokeIn (InterfaceRequest n NoData))
sendToLL :: Socket -> BS.ByteString -> SockAddrLL -> IO Int
sendToLL (MkSocket fd _ _ _ _) bs addr = liftM fromIntegral $
flip (throwErrnoIfMinus1RetryMayBlock
"sendToLL")
(threadWaitWrite (fromIntegral fd)) $
BS.unsafeUseAsCStringLen bs $ \(cs, l) ->
with addr $ \paddr ->
c_sendto_ll fd cs (fromIntegral l) 0 paddr (fromIntegral $ sizeOf addr)
recvFromLL :: Socket -> Int -> IO (SockAddrLL, BS.ByteString)
recvFromLL (MkSocket fd _ _ _ _) bufl = liftM fromJust $
flip (throwErrnoIfRetryMayBlock
(==Nothing)
"recvFromLL")
(threadWaitRead (fromIntegral fd)) $ do
v <- mallocBytes bufl
with defaultSockAddrLL $ \paddr ->
with ((fromIntegral $ sizeOf defaultSockAddrLL) :: CSize) $ \psize -> do
ret <- c_recvfrom_ll fd v (fromIntegral bufl) 0 paddr psize
if ret == 1
then free v >> return Nothing
else do
liftM Just $ (,) <$> peek paddr <*> BS.unsafePackCStringFinalizer (castPtr v) (fromIntegral ret) (free v)
setPacketOption :: Socket -> PacketSocketOption -> PacketMReq -> IO ()
setPacketOption (MkSocket fd _ _ _ _) (PacketSocketOption pso) req = do
throwErrnoIfMinus1 "setPacketOption" $
with req $ \preq ->
c_setsockopt_ll fd solPacket (fromIntegral pso) (castPtr preq) (fromIntegral $ sizeOf req)
return ()
bindLL :: Socket -> SockAddrLL -> IO ()
bindLL (MkSocket fd _ _ _ _) addr = do
throwErrnoIfMinus1 "bindLL" $ with addr $ \paddr ->
c_bind_ll fd paddr (fromIntegral $ sizeOf addr)
return ()