{-# LINE 1 "src/Network/Multicast.hsc" #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Network.Multicast
-- Copyright   :  (c) Audrey Tang 2008
-- License     :  MIT License
-- 
-- Maintainer  :  audreyt@audreyt.org
-- Stability   :  experimental
-- Portability :  portable
--
-- The "Network.Multicast" module is for sending UDP datagrams over multicast
-- (class D) addresses.
--
-----------------------------------------------------------------------------


module Network.Multicast (
    -- * Simple sending and receiving
      multicastSender, multicastReceiver
    -- * Additional Socket operations
    , addMembership, dropMembership
    , setLoopbackMode, setTimeToLive, setInterface
    -- * Socket options
    , TimeToLive, 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
import Control.Exception (bracketOnError)
import Data.Word (Word32)

type TimeToLive = Int
type LoopbackMode = Bool

enableLoopback, noLoopback :: LoopbackMode
enableLoopback :: LoopbackMode
enableLoopback = LoopbackMode
True
noLoopback :: LoopbackMode
noLoopback     = LoopbackMode
False

inet_addr :: HostName -> IO HostAddress
inet_addr :: HostName -> IO Word32
inet_addr = (HostEntry -> Word32) -> IO HostEntry -> IO Word32
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap HostEntry -> Word32
hostAddress (IO HostEntry -> IO Word32)
-> (HostName -> IO HostEntry) -> HostName -> IO Word32
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HostName -> IO HostEntry
getHostByName

-- | Calling 'multicastSender' creates a client side UDP socket for sending
-- multicast datagrams to the specified host and port.
--
-- Minimal example:
--
-- > import Network.Socket
-- > import Network.Multicast
-- > main = withSocketsDo $ do
-- >     (sock, addr) <- multicastSender "224.0.0.99" 9999
-- >     let loop = do
-- >         sendTo sock "Hello, world" addr
-- >         loop in loop
--
multicastSender :: HostName -> PortNumber -> IO (Socket, SockAddr)
multicastSender :: HostName -> PortNumber -> IO (Socket, SockAddr)
multicastSender HostName
host PortNumber
port = do
    SockAddr
addr  <- (Word32 -> SockAddr) -> IO Word32 -> IO SockAddr
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (PortNumber -> Word32 -> SockAddr
SockAddrInet PortNumber
port) (HostName -> IO Word32
Network.Multicast.inet_addr HostName
host)
    CInt
proto <- HostName -> IO CInt
getProtocolNumber HostName
"udp"
    Socket
sock  <- Family -> SocketType -> CInt -> IO Socket
socket Family
AF_INET SocketType
Datagram CInt
proto
    (Socket, SockAddr) -> IO (Socket, SockAddr)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Socket
sock, SockAddr
addr)

-- | Calling 'multicastReceiver' creates and binds a UDP socket for listening
-- multicast datagrams on the specified host and port.
--
-- Minimal example:
--
-- > import Network.Socket
-- > import Network.Multicast
-- > main = withSocketsDo $ do
-- >     sock <- multicastReceiver "224.0.0.99" 9999
-- >     let loop = do
-- >         (msg, _, addr) <- recvFrom sock 1024
-- >         print (msg, addr) in loop
--
multicastReceiver :: HostName -> PortNumber -> IO Socket
multicastReceiver :: HostName -> PortNumber -> IO Socket
multicastReceiver HostName
host PortNumber
port = IO Socket
-> (Socket -> IO ()) -> (Socket -> IO Socket) -> IO Socket
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracketOnError IO Socket
get Socket -> IO ()
close Socket -> IO Socket
setup
  where
    get :: IO Socket
    get :: IO Socket
get = do
      CInt
proto <- HostName -> IO CInt
getProtocolNumber HostName
"udp"
      Socket
sock  <- Family -> SocketType -> CInt -> IO Socket
socket Family
AF_INET SocketType
Datagram CInt
proto

{-# LINE 90 "src/Network/Multicast.hsc" #-}
      Socket -> SocketOption -> Int -> IO ()
setSocketOption Socket
sock SocketOption
ReuseAddr Int
1
      Socket -> IO Socket
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Socket
sock

{-# LINE 93 "src/Network/Multicast.hsc" #-}
    setup :: Socket -> IO Socket
    setup :: Socket -> IO Socket
setup Socket
sock = do
      Socket -> SockAddr -> IO ()
bind Socket
sock (SockAddr -> IO ()) -> SockAddr -> IO ()
forall a b. (a -> b) -> a -> b
$ PortNumber -> Word32 -> SockAddr
SockAddrInet PortNumber
port Word32
Network.Multicast.iNADDR_ANY
      Socket -> HostName -> Maybe HostName -> IO ()
addMembership Socket
sock HostName
host Maybe HostName
forall a. Maybe a
Nothing
      Socket -> IO Socket
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Socket
sock

iNADDR_ANY :: HostAddress
iNADDR_ANY :: Word32
iNADDR_ANY = Word32 -> Word32
Network.Multicast.htonl Word32
0

-- | Converts the from host byte order to network byte order.
foreign import ccall unsafe "htonl" htonl :: Word32 -> Word32

class IOCompat f where ioCompat :: f -> (Socket -> IO CInt)
instance IOCompat (Socket -> IO CInt) where ioCompat :: (Socket -> IO CInt) -> Socket -> IO CInt
ioCompat = (Socket -> IO CInt) -> Socket -> IO CInt
forall a. a -> a
id
instance IOCompat (Socket -> CInt) where ioCompat :: (Socket -> CInt) -> Socket -> IO CInt
ioCompat = (CInt -> IO CInt
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (CInt -> IO CInt) -> (Socket -> CInt) -> Socket -> IO CInt
forall b c a. (b -> c) -> (a -> b) -> a -> c
.)

doSetSocketOption :: Storable a => CInt -> Socket -> a -> IO CInt
doSetSocketOption :: forall a. Storable a => CInt -> Socket -> a -> IO CInt
doSetSocketOption CInt
ip_multicast_option Socket
sock a
x = (Ptr a -> IO CInt) -> IO CInt
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca ((Ptr a -> IO CInt) -> IO CInt) -> (Ptr a -> IO CInt) -> IO CInt
forall a b. (a -> b) -> a -> b
$ \Ptr a
ptr -> do
    Ptr a -> a -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke Ptr a
ptr a
x
    CInt
fd <- ((Socket -> IO CInt) -> Socket -> IO CInt
forall f. IOCompat f => f -> Socket -> IO CInt
ioCompat Socket -> IO CInt
fdSocket) Socket
sock
    CInt -> CInt -> CInt -> Ptr CInt -> CInt -> IO CInt
c_setsockopt CInt
fd CInt
_IPPROTO_IP CInt
ip_multicast_option (Ptr a -> Ptr CInt
forall a b. Ptr a -> Ptr b
castPtr Ptr a
ptr) (Int -> CInt
forall a. Enum a => Int -> a
toEnum (Int -> CInt) -> Int -> CInt
forall a b. (a -> b) -> a -> b
$ a -> Int
forall a. Storable a => a -> Int
sizeOf a
x)

-- | Enable or disable the loopback mode on a socket created by 'multicastSender'.
-- Loopback is enabled by default; disabling it may improve performance a little bit.
setLoopbackMode :: Socket -> LoopbackMode -> IO ()
setLoopbackMode :: Socket -> LoopbackMode -> IO ()
setLoopbackMode Socket
sock LoopbackMode
mode = HostName -> IO CInt -> IO ()
maybeIOError HostName
"setLoopbackMode" (IO CInt -> IO ()) -> IO CInt -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    let loop :: CUChar
loop = if LoopbackMode
mode then CUChar
1 else CUChar
0 :: CUChar
    CInt -> Socket -> CUChar -> IO CInt
forall a. Storable a => CInt -> Socket -> a -> IO CInt
doSetSocketOption CInt
_IP_MULTICAST_LOOP Socket
sock CUChar
loop

-- | Set the Time-to-Live of the multicast.
setTimeToLive :: Socket -> TimeToLive -> IO ()
setTimeToLive :: Socket -> Int -> IO ()
setTimeToLive Socket
sock Int
ttl = HostName -> IO CInt -> IO ()
maybeIOError HostName
"setTimeToLive" (IO CInt -> IO ()) -> IO CInt -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    let val :: CInt
val = Int -> CInt
forall a. Enum a => Int -> a
toEnum Int
ttl :: CInt
    CInt -> Socket -> CInt -> IO CInt
forall a. Storable a => CInt -> Socket -> a -> IO CInt
doSetSocketOption CInt
_IP_MULTICAST_TTL Socket
sock CInt
val

-- | Set the outgoing interface address of the multicast.
setInterface :: Socket -> HostName -> IO ()
setInterface :: Socket -> HostName -> IO ()
setInterface Socket
sock HostName
host = HostName -> IO CInt -> IO ()
maybeIOError HostName
"setInterface" (IO CInt -> IO ()) -> IO CInt -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    Word32
addr <- HostName -> IO Word32
Network.Multicast.inet_addr HostName
host
    CInt -> Socket -> Word32 -> IO CInt
forall a. Storable a => CInt -> Socket -> a -> IO CInt
doSetSocketOption CInt
_IP_MULTICAST_IF Socket
sock Word32
addr

-- | Make the socket listen on multicast datagrams sent by the specified 'HostName'.
addMembership :: Socket -> HostName -> Maybe HostName -> IO ()
addMembership :: Socket -> HostName -> Maybe HostName -> IO ()
addMembership Socket
s HostName
host = HostName -> IO CInt -> IO ()
maybeIOError HostName
"addMembership" (IO CInt -> IO ())
-> (Maybe HostName -> IO CInt) -> Maybe HostName -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CInt -> Socket -> HostName -> Maybe HostName -> IO CInt
doMulticastGroup CInt
_IP_ADD_MEMBERSHIP Socket
s HostName
host

-- | Stop the socket from listening on multicast datagrams sent by the specified 'HostName'.
dropMembership :: Socket -> HostName -> Maybe HostName -> IO ()
dropMembership :: Socket -> HostName -> Maybe HostName -> IO ()
dropMembership Socket
s HostName
host = HostName -> IO CInt -> IO ()
maybeIOError HostName
"dropMembership" (IO CInt -> IO ())
-> (Maybe HostName -> IO CInt) -> Maybe HostName -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CInt -> Socket -> HostName -> Maybe HostName -> IO CInt
doMulticastGroup CInt
_IP_DROP_MEMBERSHIP Socket
s HostName
host

maybeIOError :: String -> IO CInt -> IO ()
maybeIOError :: HostName -> IO CInt -> IO ()
maybeIOError HostName
name IO CInt
f = IO CInt
f IO CInt -> (CInt -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \CInt
err -> case CInt
err of
    CInt
0 -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    CInt
_ -> IOError -> IO ()
forall a. IOError -> IO a
ioError (HostName -> Errno -> Maybe Handle -> Maybe HostName -> IOError
errnoToIOError HostName
name (CInt -> Errno
Errno (CInt -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral CInt
err)) Maybe Handle
forall a. Maybe a
Nothing Maybe HostName
forall a. Maybe a
Nothing)

doMulticastGroup :: CInt -> Socket -> HostName -> Maybe HostName -> IO CInt
doMulticastGroup :: CInt -> Socket -> HostName -> Maybe HostName -> IO CInt
doMulticastGroup CInt
flag Socket
sock HostName
host Maybe HostName
local = Int -> (Ptr Any -> IO CInt) -> IO CInt
forall a b. Int -> (Ptr a -> IO b) -> IO b
allocaBytes (Int
8) ((Ptr Any -> IO CInt) -> IO CInt)
-> (Ptr Any -> IO CInt) -> IO CInt
forall a b. (a -> b) -> a -> b
$ \Ptr Any
mReqPtr -> do
{-# LINE 149 "src/Network/Multicast.hsc" #-}
    addr <- Network.Multicast.inet_addr host
    iface <- case local of
        Nothing -> return (0 `asTypeOf` addr)
{-# LINE 152 "src/Network/Multicast.hsc" #-}
        Just loc -> Network.Multicast.inet_addr loc
    (\hsc_ptr -> pokeByteOff hsc_ptr 0) mReqPtr addr
{-# LINE 154 "src/Network/Multicast.hsc" #-}
    (\hsc_ptr -> pokeByteOff hsc_ptr 4) mReqPtr iface
{-# LINE 155 "src/Network/Multicast.hsc" #-}
    fd <- (ioCompat fdSocket) sock
    c_setsockopt fd _IPPROTO_IP flag (castPtr mReqPtr) ((8))
{-# LINE 157 "src/Network/Multicast.hsc" #-}


{-# LINE 176 "src/Network/Multicast.hsc" #-}

foreign import ccall unsafe "setsockopt"
    c_setsockopt :: CInt -> CInt -> CInt -> Ptr CInt -> CInt -> IO CInt

getLastError :: CInt -> IO CInt
getLastError :: CInt -> IO CInt
getLastError = CInt -> IO CInt
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return

_IP_MULTICAST_IF, _IP_MULTICAST_TTL, _IP_MULTICAST_LOOP, _IP_ADD_MEMBERSHIP, _IP_DROP_MEMBERSHIP :: CInt
_IP_MULTICAST_IF :: CInt
_IP_MULTICAST_IF    = CInt
32
{-# LINE 185 "src/Network/Multicast.hsc" #-}
_IP_MULTICAST_TTL   = 33
{-# LINE 186 "src/Network/Multicast.hsc" #-}
_IP_MULTICAST_LOOP  = 34
{-# LINE 187 "src/Network/Multicast.hsc" #-}
_IP_ADD_MEMBERSHIP  = 35
{-# LINE 188 "src/Network/Multicast.hsc" #-}
_IP_DROP_MEMBERSHIP = 36
{-# LINE 189 "src/Network/Multicast.hsc" #-}


{-# LINE 191 "src/Network/Multicast.hsc" #-}

_IPPROTO_IP :: CInt
_IPPROTO_IP :: CInt
_IPPROTO_IP = CInt
0
{-# LINE 194 "src/Network/Multicast.hsc" #-}