module Network.TUNTAP (
start,
finish,
openTAP,
closeTAP,
bringUp,
setMTU,
setIP,
setMask,
getMAC,
TAP,
Packet,
DevMAC,
readTAP,
writeTAP,
withTAP,
) where
import Foreign.C.Types
import Foreign.C.String
import Foreign.Ptr
import Foreign.ForeignPtr
import Foreign.Marshal.Array
import Data.Word
import qualified Data.ByteString.Internal as BI
import qualified Data.ByteString as BS
import Control.Monad
import Control.Exception
data TAPDesc
data EthernetFrame
type DevMAC = [Word8]
mkDevMAC :: [Word8] -> [Word8]
mkDevMAC m = case length m of
6 -> m
_ -> error "A DevMAC is 6 bytes! No more! No less!"
newtype TAP = TAP (Ptr TAPDesc)
deriving (Show)
maxPktSize :: Int
maxPktSize = 1560
type Packet = BS.ByteString
start :: IO TAP
start = init_tap_ffi >>= (return . TAP)
finish :: TAP -> IO CInt
finish (TAP p) = finish_tap_ffi p
openTAP :: TAP -> String -> IO CInt
openTAP (TAP p) n = withCString n (\s -> open_tap_ffi p s)
closeTAP :: TAP -> IO CInt
closeTAP (TAP p) = close_tap_ffi p
bringUp :: TAP -> IO CInt
bringUp (TAP p) = bring_up_tap_ffi p
setMTU :: TAP -> Int -> IO CInt
setMTU (TAP p) m = set_mtu_ffi p (fromIntegral m)
setIP :: TAP -> Word32 -> IO CInt
setIP (TAP p) a = set_ip_ffi p (fromIntegral a)
setMask :: TAP -> Word32 -> IO CInt
setMask (TAP p) m = set_mask_ffi p (fromIntegral m)
getMAC :: TAP -> IO DevMAC
getMAC (TAP p) = allocaArray 6 g
where g m = do get_mac_ffi p m
peekArray 6 m >>= (return . mkDevMAC . (map fromIntegral))
readTAP :: TAP -> IO Packet
readTAP (TAP t) = do
pkt <- mallocForeignPtrBytes maxPktSize
len <- go pkt
return $ mk pkt len
where
go pkt = do
len <- block $ withForeignPtr pkt $ \pkt' -> read_tap_ffi t pkt' mps
case len of
0 -> go pkt
_ -> return len
mk p l = let p' = castForeignPtr p
l' = fromIntegral l
in BI.fromForeignPtr p' 0 l'
mps = fromIntegral maxPktSize
writeTAP :: TAP -> Packet -> IO CInt
writeTAP (TAP t) p = withForeignPtr pkt $ \pkt' -> do
wlen <- write_tap_ffi t pkt' (fromIntegral len)
return wlen
where (pkt,len) = let (p',o,l) = BI.toForeignPtr p
in case o of
0 -> error $ "Got an offset of " ++ show o
_ -> (castForeignPtr p',l)
withTAP :: Int -> (TAP -> IO a) -> IO ()
withTAP m a = do
tap <- start
openTAP tap "scurry0"
setMTU tap m
bringUp tap
a tap
closeTAP tap
finish tap
return ()
foreign import CALLCONV safe "help.h init_tap" init_tap_ffi :: IO (Ptr TAPDesc)
foreign import CALLCONV safe "help.h finish_tap" finish_tap_ffi :: (Ptr TAPDesc) -> IO CInt
foreign import CALLCONV safe "help.h open_tap" open_tap_ffi :: (Ptr TAPDesc) -> CString -> IO CInt
foreign import CALLCONV safe "help.h close_tap" close_tap_ffi :: (Ptr TAPDesc) -> IO CInt
foreign import CALLCONV safe "help.h bring_up_tap" bring_up_tap_ffi :: (Ptr TAPDesc) -> IO CInt
foreign import CALLCONV safe "help.h set_mtu" set_mtu_ffi :: (Ptr TAPDesc) -> CUInt -> IO CInt
foreign import CALLCONV safe "help.h set_ip" set_ip_ffi :: (Ptr TAPDesc) -> CUInt -> IO CInt
foreign import CALLCONV safe "help.h set_mask" set_mask_ffi :: (Ptr TAPDesc) -> CUInt -> IO CInt
foreign import CALLCONV safe "help.h get_mac" get_mac_ffi :: (Ptr TAPDesc) -> (Ptr CUChar) -> IO CInt
foreign import CALLCONV safe "help.h read_tap" read_tap_ffi :: (Ptr TAPDesc) -> (Ptr EthernetFrame) -> CInt -> IO CInt
foreign import CALLCONV safe "help.h write_tap" write_tap_ffi :: (Ptr TAPDesc) -> (Ptr EthernetFrame) -> CInt -> IO CInt