diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,18 @@ +Copyright 2008 by Audrey Tang + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to +deal in the Software without restriction, including without limitation the +rights to use, copy, modify, merge, publish, distribute, sublicense, and/or +sell copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in +all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL +THE AUTHORS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER +IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN +CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,5 @@ +#!/usr/bin/env runhaskell +> module Main where +> import Distribution.Simple +> main :: IO () +> main = defaultMain diff --git a/network-multicast.cabal b/network-multicast.cabal new file mode 100644 --- /dev/null +++ b/network-multicast.cabal @@ -0,0 +1,17 @@ +name: network-multicast +version: 0.0.1 +copyright: 2008 Audrey Tang +license: BSD3 +license-file: LICENSE +author: Audrey Tang +maintainer: Audrey Tang +synopsis: Simple multicast library +description: The "Network.Multicast" module is for sending + UDP datagrams over multicast (class D) addresses. +stability: experimental +build-type: Simple +extensions: ForeignFunctionInterface +exposed-modules: Network.Multicast +build-depends: base, network +category: Network +hs-source-dirs: src diff --git a/src/Network/Multicast.hsc b/src/Network/Multicast.hsc new file mode 100644 --- /dev/null +++ b/src/Network/Multicast.hsc @@ -0,0 +1,132 @@ +----------------------------------------------------------------------------- +-- | +-- 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. +-- +----------------------------------------------------------------------------- +#include +#include + +module Network.Multicast ( + -- * Simple sending and receiving + multicastSender, multicastReceiver + -- * Additional Socket operations + , addMembership, dropMembership, setLoopbackMode + -- * Loopback flags + , 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 + +-- | 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 noLoopback +-- > let loop = do +-- > sendTo sock "Hello, world" addr +-- > loop in loop +-- +multicastSender :: HostName -> PortNumber -> LoopbackMode -> IO (Socket, SockAddr) +multicastSender host port loop = do + proto <- getProtocolNumber "udp" + let hints = defaultHints + { addrFlags = [AI_ADDRCONFIG] + , addrProtocol = proto + , addrSocketType = Datagram + } + (addr:_) <- getAddrInfo (Just hints) (Just host) (Just $ show port) + sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr) + if loop then return () else setLoopbackMode sock loop + return (sock, addrAddress 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 host port = do + proto <- getProtocolNumber "udp" + let hints = defaultHints + { addrFlags = [AI_PASSIVE] + , addrProtocol = proto + , addrSocketType = Datagram + } + (addr:_) <- getAddrInfo (Just hints) (Just host) (Just $ show port) + sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr) + addMembership sock host + setSocketOption sock ReusePort 1 + bindSocket sock (addrAddress addr) + return sock + +-- | 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 (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) + +-- | Make the socket listen on multicast datagrams sent by the specified 'HostName'. +addMembership :: Socket -> HostName -> IO () +addMembership s = maybeIOError "addMembership" . doMulticastGroup _IP_ADD_MEMBERSHIP s + +-- | Stop the socket from listening on multicast datagrams sent by the specified 'HostName'. +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 #{size struct ip_mreq} $ \mReqPtr -> do + addr <- inet_addr host + #{poke struct ip_mreq, imr_multiaddr} mReqPtr addr + #{poke struct ip_mreq, imr_interface} mReqPtr (#{const INADDR_ANY} `asTypeOf` addr) + c_setsockopt s _IPPROTO_IP flag (castPtr mReqPtr) (#{size struct ip_mreq}) + +foreign import ccall unsafe "setsockopt" + c_setsockopt :: CInt -> CInt -> CInt -> Ptr CInt -> CInt -> IO CInt + +_IPPROTO_IP :: CInt +_IPPROTO_IP = #const IPPROTO_IP + +_IP_ADD_MEMBERSHIP, _IP_DROP_MEMBERSHIP, _IP_MULTICAST_LOOP :: CInt +_IP_ADD_MEMBERSHIP = #const IP_ADD_MEMBERSHIP +_IP_DROP_MEMBERSHIP = #const IP_DROP_MEMBERSHIP +_IP_MULTICAST_LOOP = #const IP_MULTICAST_LOOP