#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, sClose)
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)
| UnixSocket String
#endif
deriving (Show, Eq)
connectTo :: HostName
-> PortID
-> IO Handle
#if defined(IPV6_SOCKET_SUPPORT)
connectTo hostname (Service serv) = connect' "Network.connectTo" hostname serv
connectTo hostname (PortNumber port) = connect' "Network.connectTo" 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)
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' :: String -> HostName -> ServiceName -> IO Handle
connect' caller 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 caller $ 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
bind 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
bind sock (SockAddrInet port iNADDR_ANY)
listen sock maxListenQueue
return sock
)
#endif
#if !defined(mingw32_HOST_OS)
listenOn (UnixSocket path) =
bracketOnError
(socket AF_UNIX Stream 0)
(sClose)
(\sock -> do
setSocketOption sock ReuseAddr 1
bind 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
bind 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)
SockAddrUnix {} -> ioError $ userError "Network.accept: peer socket address 'SockAddrUnix' not supported on this platform."
#else
SockAddrUnix a -> return a
#endif
#if defined(CAN_SOCKET_SUPPORT)
SockAddrCan {} -> ioError $ userError "Network.accept: peer socket address 'SockAddrCan' not supported."
#else
SockAddrCan {} -> ioError $ userError "Network.accept: peer socket address 'SockAddrCan' not supported on this platform."
#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)
accept sock@(MkSocket _ AF_UNIX _ _ _) = do
~(sock', (SockAddrUnix path)) <- Socket.accept sock
handle <- socketToHandle sock' ReadWriteMode
return (handle, path, 1)
#endif
accept (MkSocket _ family _ _ _) =
ioError $ userError $ "Network.accept: address family '" ++
show family ++ "' not supported."
sClose :: Socket -> IO ()
sClose = close
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
case sockaddr of
SockAddrInet port _ -> return $ PortNumber port
#if defined(IPV6_SOCKET_SUPPORT)
SockAddrInet6 port _ _ _ -> return $ PortNumber port
#else
SockAddrInet6 {} -> ioError $ userError "Network.socketPort: socket address 'SockAddrInet6' not supported on this platform."
#endif
#if defined(mingw32_HOST_OS)
SockAddrUnix {} -> ioError $ userError "Network.socketPort: socket address 'SockAddrUnix' not supported on this platform."
#else
SockAddrUnix path -> return $ UnixSocket path
#endif
SockAddrCan {} -> ioError $ userError "Network.socketPort: socket address 'SockAddrCan' not supported."
bracketOnError
:: IO a
-> (a -> IO b)
-> (a -> IO c)
-> IO c
bracketOnError = Exception.bracketOnError
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
tryIO :: IO a -> IO (Either Exception.IOException a)
tryIO m = catchIO (liftM Right m) (return . Left)
firstSuccessful :: String -> [IO a] -> IO a
firstSuccessful caller = go Nothing
where
go _ (p:ps) =
do r <- tryIO p
case r of
Right x -> return x
Left e -> go (Just e) ps
go Nothing [] = ioError $ userError $ caller ++ ": firstSuccessful: empty list"
go (Just e) [] = Exception.throwIO e