{-# 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 HostAddress
inet_addr = (HostEntry -> HostAddress) -> IO HostEntry -> IO HostAddress
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap HostEntry -> HostAddress
hostAddress (IO HostEntry -> IO HostAddress)
-> (HostName -> IO HostEntry) -> HostName -> IO HostAddress
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 host :: HostName
host port :: PortNumber
port = do
    SockAddr
addr  <- (HostAddress -> SockAddr) -> IO HostAddress -> IO SockAddr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (PortNumber -> HostAddress -> SockAddr
SockAddrInet PortNumber
port) (HostName -> IO HostAddress
Network.Multicast.inet_addr HostName
host)
    ProtocolNumber
proto <- HostName -> IO ProtocolNumber
getProtocolNumber "udp"
    Socket
sock  <- Family -> SocketType -> ProtocolNumber -> IO Socket
socket Family
AF_INET SocketType
Datagram ProtocolNumber
proto
    (Socket, SockAddr) -> IO (Socket, SockAddr)
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 host :: HostName
host port :: 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
      ProtocolNumber
proto <- HostName -> IO ProtocolNumber
getProtocolNumber "udp"
      Socket
sock  <- Family -> SocketType -> ProtocolNumber -> IO Socket
socket Family
AF_INET SocketType
Datagram ProtocolNumber
proto

{-# LINE 90 "src/Network/Multicast.hsc" #-}
      Socket -> SocketOption -> Int -> IO ()
setSocketOption Socket
sock SocketOption
ReuseAddr 1
      Socket -> IO Socket
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 sock :: Socket
sock = do
      Socket -> SockAddr -> IO ()
bind Socket
sock (SockAddr -> IO ()) -> SockAddr -> IO ()
forall a b. (a -> b) -> a -> b
$ PortNumber -> HostAddress -> SockAddr
SockAddrInet PortNumber
port HostAddress
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 (m :: * -> *) a. Monad m => a -> m a
return Socket
sock

iNADDR_ANY :: HostAddress
iNADDR_ANY :: HostAddress
iNADDR_ANY = HostAddress -> HostAddress
Network.Multicast.htonl 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 ProtocolNumber) -> Socket -> IO ProtocolNumber
ioCompat = (Socket -> IO ProtocolNumber) -> Socket -> IO ProtocolNumber
forall a. a -> a
id
instance IOCompat (Socket -> CInt) where ioCompat :: (Socket -> ProtocolNumber) -> Socket -> IO ProtocolNumber
ioCompat = (ProtocolNumber -> IO ProtocolNumber
forall (m :: * -> *) a. Monad m => a -> m a
return (ProtocolNumber -> IO ProtocolNumber)
-> (Socket -> ProtocolNumber) -> Socket -> IO ProtocolNumber
forall b c a. (b -> c) -> (a -> b) -> a -> c
.)

doSetSocketOption :: Storable a => CInt -> Socket -> a -> IO CInt
doSetSocketOption :: ProtocolNumber -> Socket -> a -> IO ProtocolNumber
doSetSocketOption ip_multicast_option :: ProtocolNumber
ip_multicast_option sock :: Socket
sock x :: a
x = (Ptr a -> IO ProtocolNumber) -> IO ProtocolNumber
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca ((Ptr a -> IO ProtocolNumber) -> IO ProtocolNumber)
-> (Ptr a -> IO ProtocolNumber) -> IO ProtocolNumber
forall a b. (a -> b) -> a -> b
$ \ptr :: Ptr a
ptr -> do
    Ptr a -> a -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke Ptr a
ptr a
x
    ProtocolNumber
fd <- ((Socket -> IO ProtocolNumber) -> Socket -> IO ProtocolNumber
forall f. IOCompat f => f -> Socket -> IO ProtocolNumber
ioCompat Socket -> IO ProtocolNumber
fdSocket) Socket
sock
    ProtocolNumber
-> ProtocolNumber
-> ProtocolNumber
-> Ptr ProtocolNumber
-> ProtocolNumber
-> IO ProtocolNumber
c_setsockopt ProtocolNumber
fd ProtocolNumber
_IPPROTO_IP ProtocolNumber
ip_multicast_option (Ptr a -> Ptr ProtocolNumber
forall a b. Ptr a -> Ptr b
castPtr Ptr a
ptr) (Int -> ProtocolNumber
forall a. Enum a => Int -> a
toEnum (Int -> ProtocolNumber) -> Int -> ProtocolNumber
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 sock :: Socket
sock mode :: LoopbackMode
mode = HostName -> IO ProtocolNumber -> IO ()
maybeIOError "setLoopbackMode" (IO ProtocolNumber -> IO ()) -> IO ProtocolNumber -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    let loop :: CUChar
loop = if LoopbackMode
mode then 1 else 0 :: CUChar
    ProtocolNumber -> Socket -> CUChar -> IO ProtocolNumber
forall a.
Storable a =>
ProtocolNumber -> Socket -> a -> IO ProtocolNumber
doSetSocketOption ProtocolNumber
_IP_MULTICAST_LOOP Socket
sock CUChar
loop

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

-- | Set the outgoing interface address of the multicast.
setInterface :: Socket -> HostName -> IO ()
setInterface :: Socket -> HostName -> IO ()
setInterface sock :: Socket
sock host :: HostName
host = HostName -> IO ProtocolNumber -> IO ()
maybeIOError "setInterface" (IO ProtocolNumber -> IO ()) -> IO ProtocolNumber -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    HostAddress
addr <- HostName -> IO HostAddress
Network.Multicast.inet_addr HostName
host
    ProtocolNumber -> Socket -> HostAddress -> IO ProtocolNumber
forall a.
Storable a =>
ProtocolNumber -> Socket -> a -> IO ProtocolNumber
doSetSocketOption ProtocolNumber
_IP_MULTICAST_IF Socket
sock HostAddress
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 s :: Socket
s host :: HostName
host = HostName -> IO ProtocolNumber -> IO ()
maybeIOError "addMembership" (IO ProtocolNumber -> IO ())
-> (Maybe HostName -> IO ProtocolNumber) -> Maybe HostName -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProtocolNumber
-> Socket -> HostName -> Maybe HostName -> IO ProtocolNumber
doMulticastGroup ProtocolNumber
_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 s :: Socket
s host :: HostName
host = HostName -> IO ProtocolNumber -> IO ()
maybeIOError "dropMembership" (IO ProtocolNumber -> IO ())
-> (Maybe HostName -> IO ProtocolNumber) -> Maybe HostName -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProtocolNumber
-> Socket -> HostName -> Maybe HostName -> IO ProtocolNumber
doMulticastGroup ProtocolNumber
_IP_DROP_MEMBERSHIP Socket
s HostName
host

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

doMulticastGroup :: CInt -> Socket -> HostName -> Maybe HostName -> IO CInt
doMulticastGroup :: ProtocolNumber
-> Socket -> HostName -> Maybe HostName -> IO ProtocolNumber
doMulticastGroup flag :: ProtocolNumber
flag sock :: Socket
sock host :: HostName
host local :: Maybe HostName
local = Int -> (Ptr Any -> IO ProtocolNumber) -> IO ProtocolNumber
forall a b. Int -> (Ptr a -> IO b) -> IO b
allocaBytes (8) ((Ptr Any -> IO ProtocolNumber) -> IO ProtocolNumber)
-> (Ptr Any -> IO ProtocolNumber) -> IO ProtocolNumber
forall a b. (a -> b) -> a -> b
$ \mReqPtr :: 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 :: ProtocolNumber -> IO ProtocolNumber
getLastError = ProtocolNumber -> IO ProtocolNumber
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 :: ProtocolNumber
_IP_MULTICAST_IF    = 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 :: ProtocolNumber
_IPPROTO_IP = 0
{-# LINE 194 "src/Network/Multicast.hsc" #-}