Low-level Networking in Haskell (largely C so far)

Networking.hs

{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# OPTIONS_GHC -Wall #-}

module Main where

import Data.Bits.Extras (w16)
import qualified Data.ByteString as BS
import Data.Word (Word16)
import Foreign.C.Types
  ( CInt (..),
    CSize (..),
    CUInt
    )
import Foreign.Marshal.Alloc (allocaBytes)
import Foreign.Ptr (Ptr)
import Foreign.Storable
  ( peekByteOff,
    pokeByteOff,
    sizeOf
    )
import qualified Language.C.Inline as C
import Network.Socket
  ( Family (AF_PACKET),
    SocketType (Raw),
    packFamily,
    socket,
    unpackFamily
    )
import Network.Socket.Address
  ( SocketAddress (..),
    bind,
    getSocketName,
    recvFrom,
    sendAllTo
    )

C.context (C.baseCtx <> C.bsCtx)

C.include "<stddef.h>" -- size_t

C.include "<netpacket/packet.h>" -- struct sockaddr_ll

C.include "<net/if.h>" -- if_nametoindex

sockAddrLLSize :: CSize
sockAddrLLSize =
  [C.pure| size_t { sizeof(struct sockaddr_ll) } |]

devIndex :: BS.ByteString -> IO CUInt
devIndex name =
  [C.block| unsigned int {
    return if_nametoindex($bs-ptr:name);
  } |]

data SockAddrLinkLayer
  = SockAddrLinkLayer
      { sllFamily :: Family,
        sllProtocol :: Word16,
        sllIfindex :: Int
        }
  deriving (Show)

sockAddrLinkLayer :: Int -> SockAddrLinkLayer
sockAddrLinkLayer index = SockAddrLinkLayer
  { sllFamily = AF_PACKET,
    sllProtocol = 0x0300, -- ETH_P_ALL
    sllIfindex = index
    }

foreign import ccall unsafe "string.h"
  memset :: Ptr a -> CInt -> CSize -> IO ()

-- | Zero a structure.
zeroMemory :: Ptr a -> CSize -> IO ()
zeroMemory dest nbytes = memset dest 0 (fromIntegral nbytes)

instance SocketAddress SockAddrLinkLayer where

  sizeOfSocketAddress :: SockAddrLinkLayer -> Int
  sizeOfSocketAddress = const (fromIntegral sockAddrLLSize)

  peekSocketAddress :: Ptr SockAddrLinkLayer -> IO SockAddrLinkLayer
  peekSocketAddress ptr = do
    familyVal <- peekByteOff @Word16 ptr 0
    let familySize = sizeOf familyVal
    protocol <- peekByteOff @Word16 ptr familySize
    indexVal <- peekByteOff @CInt ptr (familySize + sizeOf protocol)
    let family = unpackFamily (fromIntegral familyVal)
        index = fromIntegral indexVal
    pure (SockAddrLinkLayer family protocol index)

  pokeSocketAddress :: Ptr a -> SockAddrLinkLayer -> IO ()
  pokeSocketAddress p SockAddrLinkLayer {sllFamily, sllProtocol, sllIfindex} = do
    zeroMemory p sockAddrLLSize
    let familyVal = w16 (packFamily sllFamily)
        familySize = sizeOf familyVal
    pokeByteOff p 0 familyVal
    pokeByteOff p familySize sllProtocol
    pokeByteOff @CInt p (familySize + sizeOf sllProtocol) (fromIntegral sllIfindex)

main :: IO ()
main = do
  index <- devIndex "lo"
  let address = sockAddrLinkLayer (fromIntegral index)
  putStrLn "Test Storable round-trip"
  address' <-
    allocaBytes (sizeOfSocketAddress address) $ \p -> do
      pokeSocketAddress @SockAddrLinkLayer p address
      peekSocketAddress @SockAddrLinkLayer p
  print address'
  putStrLn "Test address binding"
  rawSocket <- socket AF_PACKET Raw 0
  bind rawSocket address
  print =<< getSocketName @SockAddrLinkLayer rawSocket
  putStrLn "Test that socket comms actually work"
  -- You can test this way but it's cooler to run this program and try curl-ing at localhost
  -- let payload = "\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\255\255Hello, World!"
  -- sendAllTo rawSocket payload address
  print =<< recvFrom @SockAddrLinkLayer rawSocket 65535