{-# LINE 1 "hssrc/Network/Socket/NetPacket.hsc" #-}
{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, ForeignFunctionInterface #-}
{-# LINE 2 "hssrc/Network/Socket/NetPacket.hsc" #-}
-- | A module for working with the NetPacket interface, giving the ability to send and
-- | receive raw low-level network packets such as Ethernet frames.
-- | Example:
-- |   import Network.Socket
-- |   import Network.Socket.NetPacket
-- |   main = do
-- |     s <- socket AF_PACKET Raw ethProtocolAll
-- |     p@(addr, dg) <- recvFromLL s 4096
-- |     print ("Received packet: " ++ show p)
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

-- | Low-level sendto call. Normally, this would not be used, as sendToLL provides a
-- | more convenient interface.
foreign import ccall "sendto" c_sendto_ll :: CInt -> CString -> CSize -> CInt -> Ptr SockAddrLL -> CSize -> IO CSize

-- | Low-level recvfrom call. Normally, this would not be used, as recvFromLL provides
-- | a more convenient interface.
foreign import ccall "recvfrom" c_recvfrom_ll :: CInt -> CString -> CSize -> CInt -> Ptr SockAddrLL -> Ptr CSize -> IO CSize

-- | Low-level setsockopt operation. Normally, it will be more convenient to use
-- | setPacketOption instead.
foreign import ccall "setsockopt" c_setsockopt_ll :: CInt -> CInt -> CInt -> Ptr () -> CSize -> IO CInt

-- | Low-level bind operation. Normally, this would not be used, as bindLL provides a
-- | more convenient interface.
foreign import ccall "bind" c_bind_ll :: CInt -> Ptr SockAddrLL -> CSize -> IO CInt


{-# LINE 49 "hssrc/Network/Socket/NetPacket.hsc" #-}

{-# LINE 50 "hssrc/Network/Socket/NetPacket.hsc" #-}

{-# LINE 51 "hssrc/Network/Socket/NetPacket.hsc" #-}

-- | Ethernet protocol numbers, for use with socket
ethProtocolIPv4  :: ProtocolNumber
ethProtocolIPv4  =  8
ethProtocolIPv6  :: ProtocolNumber
ethProtocolIPv6  =  56710
ethProtocolAll  :: ProtocolNumber
ethProtocolAll  =  768

{-# LINE 54 "hssrc/Network/Socket/NetPacket.hsc" #-}

-- | Represents a type of packet
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

{-# LINE 58 "hssrc/Network/Socket/NetPacket.hsc" #-}

-- | The address family of a packet socket.
afPacket  :: CInt
afPacket  =  17

{-# LINE 61 "hssrc/Network/Socket/NetPacket.hsc" #-}

-- | Represents a low-level protocol appearing in an address.
newtype LLProtocol = LLProtocol Word16 deriving (Eq, Ord, Show)
lLProtocolIPv4  :: LLProtocol
lLProtocolIPv4  = LLProtocol 8
lLProtocolIPv6  :: LLProtocol
lLProtocolIPv6  = LLProtocol 56710
lLProtocolAll  :: LLProtocol
lLProtocolAll  = LLProtocol 768

{-# LINE 65 "hssrc/Network/Socket/NetPacket.hsc" #-}

-- | Represents a hardware type appearing in an address.
newtype HardwareType = HardwareType Word16 deriving (Eq, Ord, Show)
-- | Represents the Ethernet hardware type
hwTypeEther = HardwareType 0x1

-- | Hardware address
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

{-# LINE 82 "hssrc/Network/Socket/NetPacket.hsc" #-}
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

{-# LINE 84 "hssrc/Network/Socket/NetPacket.hsc" #-}

newtype PacketMReqType = PacketMReqType Word16 deriving (Eq, Ord, Show)
mrMulticast  :: PacketMReqType
mrMulticast  = PacketMReqType 0
mrPromisc  :: PacketMReqType
mrPromisc  = PacketMReqType 1
mrAllMulti  :: PacketMReqType
mrAllMulti  = PacketMReqType 2

{-# LINE 87 "hssrc/Network/Socket/NetPacket.hsc" #-}

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)
{-# LINE 116 "hssrc/Network/Socket/NetPacket.hsc" #-}
  alignment _ = alignment (undefined :: CInt)
  peek p = SockAddrLL <$>
             (peek $ ((\hsc_ptr -> hsc_ptr `plusPtr` 2)) p) <*>
{-# LINE 119 "hssrc/Network/Socket/NetPacket.hsc" #-}
             (peek $ ((\hsc_ptr -> hsc_ptr `plusPtr` 4)) p) <*>
{-# LINE 120 "hssrc/Network/Socket/NetPacket.hsc" #-}
             (peek $ ((\hsc_ptr -> hsc_ptr `plusPtr` 8)) p) <*>
{-# LINE 121 "hssrc/Network/Socket/NetPacket.hsc" #-}
             (peek $ ((\hsc_ptr -> hsc_ptr `plusPtr` 10)) p) <*>
{-# LINE 122 "hssrc/Network/Socket/NetPacket.hsc" #-}
             (HWAddr <$> ((((,) (((\hsc_ptr -> hsc_ptr `plusPtr` 12)) p)) <$>
{-# LINE 123 "hssrc/Network/Socket/NetPacket.hsc" #-}
                           liftM fromIntegral ((((\hsc_ptr -> peekByteOff hsc_ptr 11)) p) :: IO Word8)) >>= BS.packCStringLen))
{-# LINE 124 "hssrc/Network/Socket/NetPacket.hsc" #-}
  poke p (SockAddrLL proto ifi hatype pkttype (HWAddr hwaddr)) = do
    ((\hsc_ptr -> pokeByteOff hsc_ptr 0)) p afPacket
{-# LINE 126 "hssrc/Network/Socket/NetPacket.hsc" #-}
    poke (((\hsc_ptr -> hsc_ptr `plusPtr` 2)) p) proto
{-# LINE 127 "hssrc/Network/Socket/NetPacket.hsc" #-}
    poke (((\hsc_ptr -> hsc_ptr `plusPtr` 4)) p) ifi
{-# LINE 128 "hssrc/Network/Socket/NetPacket.hsc" #-}
    poke (((\hsc_ptr -> hsc_ptr `plusPtr` 8)) p) hatype
{-# LINE 129 "hssrc/Network/Socket/NetPacket.hsc" #-}
    poke (((\hsc_ptr -> hsc_ptr `plusPtr` 10)) p) pkttype
{-# LINE 130 "hssrc/Network/Socket/NetPacket.hsc" #-}
    BS.unsafeUseAsCStringLen hwaddr $ \(chwaddr, l) -> do
      poke (((\hsc_ptr -> hsc_ptr `plusPtr` 11)) p) ((fromIntegral l) :: Word8)
{-# LINE 132 "hssrc/Network/Socket/NetPacket.hsc" #-}
      let aptr = ((\hsc_ptr -> hsc_ptr `plusPtr` 12)) p
{-# LINE 133 "hssrc/Network/Socket/NetPacket.hsc" #-}
      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)
{-# LINE 152 "hssrc/Network/Socket/NetPacket.hsc" #-}
  alignment _ = alignment (undefined :: CInt)
  peek p = PacketMReq <$> (peek $ ((\hsc_ptr -> hsc_ptr `plusPtr` 0)) p) <*>
{-# LINE 154 "hssrc/Network/Socket/NetPacket.hsc" #-}
                          (peek $ ((\hsc_ptr -> hsc_ptr `plusPtr` 4)) p) <*>
{-# LINE 155 "hssrc/Network/Socket/NetPacket.hsc" #-}
                          (HWAddr <$> ((((,) (((\hsc_ptr -> hsc_ptr `plusPtr` 8)) p)) <$>
{-# LINE 156 "hssrc/Network/Socket/NetPacket.hsc" #-}
                           liftM fromIntegral ((((\hsc_ptr -> peekByteOff hsc_ptr 8)) p) :: IO Word16)) >>= BS.packCStringLen))
{-# LINE 157 "hssrc/Network/Socket/NetPacket.hsc" #-}
  poke p (PacketMReq ii mt (HWAddr a)) = do
    poke (((\hsc_ptr -> hsc_ptr `plusPtr` 0)) p) ii
{-# LINE 159 "hssrc/Network/Socket/NetPacket.hsc" #-}
    poke (((\hsc_ptr -> hsc_ptr `plusPtr` 4)) p) mt
{-# LINE 160 "hssrc/Network/Socket/NetPacket.hsc" #-}
    BS.unsafeUseAsCStringLen a $ \(chwaddr, l) -> do
      poke (((\hsc_ptr -> hsc_ptr `plusPtr` 6)) p) ((fromIntegral l) :: Word16)
{-# LINE 162 "hssrc/Network/Socket/NetPacket.hsc" #-}
      let aptr = ((\hsc_ptr -> hsc_ptr `plusPtr` 8)) p
{-# LINE 163 "hssrc/Network/Socket/NetPacket.hsc" #-}
      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

-- | Gets the index for a named interface, for use with SockAddrLL
getInterfaceIndex :: Socket -> String -> IO IFIndex
getInterfaceIndex s n = do
  liftA (IFIndex . fromIntegral . irValue . getPeek) $ ioctlsocket s GetIndexForName (PokeIn (InterfaceRequest n NoData))

-- | Sends a packet to a particular low-level socket address.
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)

-- | Receives a packet from a socket, returning the address of the packet.
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)

-- | Sets an option on a packet socket. This can be used to control the receipt of multicast packets
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 ()

-- | Binds a packet socket to an address. This is not essential, but acts as a filter on received packets.
bindLL :: Socket -> SockAddrLL -> IO ()
bindLL (MkSocket fd _ _ _ _) addr = do
  throwErrnoIfMinus1 "bindLL" $ with addr $ \paddr ->
    c_bind_ll fd paddr (fromIntegral $ sizeOf addr)
  return ()