module Network.Multicast (
multicastSender, multicastReceiver
, addMembership, dropMembership, setLoopbackMode
, LoopbackMode, enableLoopback, noLoopback
) where
import Network.BSD
import Network.Socket
import Foreign.C.Types
import Foreign.C.Error
import Foreign.Storable
import Foreign.Marshal
import Foreign.Ptr
type LoopbackMode = Bool
enableLoopback, noLoopback :: LoopbackMode
enableLoopback = True
noLoopback = False
multicastSender :: HostName -> PortNumber -> LoopbackMode -> IO (Socket, SockAddr)
multicastSender host port loop = do
proto <- getProtocolNumber "udp"
sock <- socket AF_INET Datagram proto
if loop then return () else setLoopbackMode sock loop
host <- inet_addr host
let addr = SockAddrInet port host
return (sock, addr)
multicastReceiver :: HostName -> PortNumber -> IO Socket
multicastReceiver host port = do
proto <- getProtocolNumber "udp"
sock <- socket AF_INET Datagram proto
addMembership sock host
host <- inet_addr host
let addr = SockAddrInet port host
bindSocket sock addr
return sock
setLoopbackMode :: Socket -> LoopbackMode -> IO ()
setLoopbackMode (MkSocket s _ _ _ _) mode = maybeIOError "setLoopbackMode" $
alloca $ \loopPtr -> do
let loop = if mode then 1 else 0 :: CUChar
poke loopPtr loop
c_setsockopt s _IPPROTO_IP _IP_MULTICAST_LOOP (castPtr loopPtr) (toEnum $ sizeOf loop)
addMembership :: Socket -> HostName -> IO ()
addMembership s = maybeIOError "addMembership" . doMulticastGroup _IP_ADD_MEMBERSHIP s
dropMembership :: Socket -> HostName -> IO ()
dropMembership s = maybeIOError "dropMembership" . doMulticastGroup _IP_DROP_MEMBERSHIP s
maybeIOError :: String -> IO CInt -> IO ()
maybeIOError name f = f >>= \err -> case err of
0 -> return ()
_ -> ioError (errnoToIOError name (Errno (fromIntegral err)) Nothing Nothing)
doMulticastGroup :: CInt -> Socket -> HostName -> IO CInt
doMulticastGroup flag (MkSocket s _ _ _ _) host = allocaBytes (8) $ \mReqPtr -> do
addr <- inet_addr host
(\hsc_ptr -> pokeByteOff hsc_ptr 0) mReqPtr addr
(\hsc_ptr -> pokeByteOff hsc_ptr 4) mReqPtr (0 `asTypeOf` addr)
c_setsockopt s _IPPROTO_IP flag (castPtr mReqPtr) ((8))
foreign import ccall unsafe "setsockopt"
c_setsockopt :: CInt -> CInt -> CInt -> Ptr CInt -> CInt -> IO CInt
_IPPROTO_IP :: CInt
_IPPROTO_IP = 0
_IP_ADD_MEMBERSHIP, _IP_DROP_MEMBERSHIP, _IP_MULTICAST_LOOP :: CInt
_IP_ADD_MEMBERSHIP = 35
_IP_DROP_MEMBERSHIP = 36
_IP_MULTICAST_LOOP = 34