#include "HsNetworkConfig.h"
#ifdef HAVE_GETADDRINFO
#define IPV6_SOCKET_SUPPORT 1
#endif
module Network
(
Socket
, PortID(..)
, HostName
, PortNumber
, withSocketsDo
, listenOn
, accept
, sClose
, connectTo
, sendTo
, recvFrom
, socketPort
) where
import Control.Monad (liftM)
import Data.Maybe (fromJust)
import Network.BSD
import Network.Socket hiding (accept, socketPort, recvFrom, sendTo, PortNumber)
import qualified Network.Socket as Socket (accept)
import System.IO
import Prelude
import qualified Control.Exception as Exception
data PortID =
Service String
| PortNumber PortNumber
#if !defined(mingw32_HOST_OS) && !defined(cygwin32_HOST_OS) && !defined(_WIN32)
| UnixSocket String
#endif
deriving (Show, Eq)
connectTo :: HostName
-> PortID
-> IO Handle
#if defined(IPV6_SOCKET_SUPPORT)
connectTo hostname (Service serv) = connect' hostname serv
connectTo hostname (PortNumber port) = connect' hostname (show port)
#else
connectTo hostname (Service serv) = do
proto <- getProtocolNumber "tcp"
bracketOnError
(socket AF_INET Stream proto)
(sClose)
(\sock -> do
port <- getServicePortNumber serv
he <- getHostByName hostname
connect sock (SockAddrInet port (hostAddress he))
socketToHandle sock ReadWriteMode
)
connectTo hostname (PortNumber port) = do
proto <- getProtocolNumber "tcp"
bracketOnError
(socket AF_INET Stream proto)
(sClose)
(\sock -> do
he <- getHostByName hostname
connect sock (SockAddrInet port (hostAddress he))
socketToHandle sock ReadWriteMode
)
#endif
#if !defined(mingw32_HOST_OS) && !defined(cygwin32_HOST_OS) && !defined(_WIN32)
connectTo _ (UnixSocket path) = do
bracketOnError
(socket AF_UNIX Stream 0)
(sClose)
(\sock -> do
connect sock (SockAddrUnix path)
socketToHandle sock ReadWriteMode
)
#endif
#if defined(IPV6_SOCKET_SUPPORT)
connect' :: HostName -> ServiceName -> IO Handle
connect' host serv = do
proto <- getProtocolNumber "tcp"
let hints = defaultHints { addrFlags = [AI_ADDRCONFIG]
, addrProtocol = proto
, addrSocketType = Stream }
addrs <- getAddrInfo (Just hints) (Just host) (Just serv)
firstSuccessful $ map tryToConnect addrs
where
tryToConnect addr =
bracketOnError
(socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr))
(sClose)
(\sock -> do
connect sock (addrAddress addr)
socketToHandle sock ReadWriteMode
)
#endif
listenOn :: PortID
-> IO Socket
#if defined(IPV6_SOCKET_SUPPORT)
listenOn (Service serv) = listen' serv
listenOn (PortNumber port) = listen' (show port)
#else
listenOn (Service serv) = do
proto <- getProtocolNumber "tcp"
bracketOnError
(socket AF_INET Stream proto)
(sClose)
(\sock -> do
port <- getServicePortNumber serv
setSocketOption sock ReuseAddr 1
bindSocket sock (SockAddrInet port iNADDR_ANY)
listen sock maxListenQueue
return sock
)
listenOn (PortNumber port) = do
proto <- getProtocolNumber "tcp"
bracketOnError
(socket AF_INET Stream proto)
(sClose)
(\sock -> do
setSocketOption sock ReuseAddr 1
bindSocket sock (SockAddrInet port iNADDR_ANY)
listen sock maxListenQueue
return sock
)
#endif
#if !defined(mingw32_HOST_OS) && !defined(cygwin32_HOST_OS) && !defined(_WIN32)
listenOn (UnixSocket path) =
bracketOnError
(socket AF_UNIX Stream 0)
(sClose)
(\sock -> do
setSocketOption sock ReuseAddr 1
bindSocket sock (SockAddrUnix path)
listen sock maxListenQueue
return sock
)
#endif
#if defined(IPV6_SOCKET_SUPPORT)
listen' :: ServiceName -> IO Socket
listen' serv = do
proto <- getProtocolNumber "tcp"
let hints = defaultHints { addrFlags = [AI_ADDRCONFIG, AI_PASSIVE]
, addrSocketType = Stream
, addrProtocol = proto }
addrs <- getAddrInfo (Just hints) Nothing (Just serv)
let addrs' = filter (\x -> addrFamily x == AF_INET6) addrs
addr = if null addrs' then head addrs else head addrs'
bracketOnError
(socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr))
(sClose)
(\sock -> do
setSocketOption sock ReuseAddr 1
bindSocket sock (addrAddress addr)
listen sock maxListenQueue
return sock
)
#endif
accept :: Socket
-> IO (Handle,
HostName,
PortNumber)
accept sock@(MkSocket _ AF_INET _ _ _) = do
~(sock', (SockAddrInet port haddr)) <- Socket.accept sock
peer <- catchIO
(do
(HostEntry peer _ _ _) <- getHostByAddr AF_INET haddr
return peer
)
(\_e -> inet_ntoa haddr)
handle <- socketToHandle sock' ReadWriteMode
return (handle, peer, port)
#if defined(IPV6_SOCKET_SUPPORT)
accept sock@(MkSocket _ AF_INET6 _ _ _) = do
(sock', addr) <- Socket.accept sock
peer <- catchIO ((fromJust . fst) `liftM` getNameInfo [] True False addr) $
\_ -> case addr of
SockAddrInet _ a -> inet_ntoa a
SockAddrInet6 _ _ a _ -> return (show a)
# if !defined(mingw32_HOST_OS) && !defined(cygwin32_HOST_OS) && !defined(_WIN32)
SockAddrUnix a -> return a
# endif
handle <- socketToHandle sock' ReadWriteMode
let port = case addr of
SockAddrInet p _ -> p
SockAddrInet6 p _ _ _ -> p
_ -> 1
return (handle, peer, port)
#endif
#if !defined(mingw32_HOST_OS) && !defined(cygwin32_HOST_OS) && !defined(_WIN32)
accept sock@(MkSocket _ AF_UNIX _ _ _) = do
~(sock', (SockAddrUnix path)) <- Socket.accept sock
handle <- socketToHandle sock' ReadWriteMode
return (handle, path, 1)
#endif
accept (MkSocket _ family _ _ _) =
error $ "Sorry, address family " ++ (show family) ++ " is not supported!"
sendTo :: HostName
-> PortID
-> String
-> IO ()
sendTo h p msg = do
s <- connectTo h p
hPutStr s msg
hClose s
recvFrom :: HostName
-> PortID
-> IO String
#if defined(IPV6_SOCKET_SUPPORT)
recvFrom host port = do
proto <- getProtocolNumber "tcp"
let hints = defaultHints { addrFlags = [AI_ADDRCONFIG]
, addrProtocol = proto
, addrSocketType = Stream }
allowed <- map addrAddress `liftM` getAddrInfo (Just hints) (Just host)
Nothing
s <- listenOn port
let waiting = do
(s', addr) <- Socket.accept s
if not (addr `oneOf` allowed)
then sClose s' >> waiting
else socketToHandle s' ReadMode >>= hGetContents
waiting
where
a@(SockAddrInet _ ha) `oneOf` ((SockAddrInet _ hb):bs)
| ha == hb = True
| otherwise = a `oneOf` bs
a@(SockAddrInet6 _ _ ha _) `oneOf` ((SockAddrInet6 _ _ hb _):bs)
| ha == hb = True
| otherwise = a `oneOf` bs
_ `oneOf` _ = False
#else
recvFrom host port = do
ip <- getHostByName host
let ipHs = hostAddresses ip
s <- listenOn port
let
waiting = do
~(s', SockAddrInet _ haddr) <- Socket.accept s
he <- getHostByAddr AF_INET haddr
if not (any (`elem` ipHs) (hostAddresses he))
then do
sClose s'
waiting
else do
h <- socketToHandle s' ReadMode
msg <- hGetContents h
return msg
message <- waiting
return message
#endif
socketPort :: Socket -> IO PortID
socketPort s = do
sockaddr <- getSocketName s
return (portID sockaddr)
where
portID sa =
case sa of
SockAddrInet port _ -> PortNumber port
#if defined(IPV6_SOCKET_SUPPORT)
SockAddrInet6 port _ _ _ -> PortNumber port
#endif
#if !defined(mingw32_HOST_OS) && !defined(cygwin32_HOST_OS) && !defined(_WIN32)
SockAddrUnix path -> UnixSocket path
#endif
bracketOnError
:: IO a
-> (a -> IO b)
-> (a -> IO c)
-> IO c
#if __GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ < 606
bracketOnError before after thing =
Exception.block (do
a <- before
r <- Exception.catch
(Exception.unblock (thing a))
(\e -> do { after a; Exception.throw e })
return r
)
#else
bracketOnError = Exception.bracketOnError
#endif
catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a
#if MIN_VERSION_base(4,0,0)
catchIO = Exception.catch
#else
catchIO = Exception.catchJust Exception.ioErrors
#endif
firstSuccessful :: [IO a] -> IO a
firstSuccessful [] = error "firstSuccessful: empty list"
firstSuccessful (p:ps) = catchIO p $ \e ->
case ps of
[] -> Exception.throwIO e
_ -> firstSuccessful ps