module Network.Hermes.Net(connectStream,streamServer,Address(..),resolve,reverseLookup) where
import Control.Concurrent
import Control.Exception
import Control.Monad
import Data.Maybe
import System.IO
import Network.Socket
import Foreign
import Foreign.C
import Network.Hermes.Protocol
import Network.Hermes.Misc
connectStream :: Address -> IO Handle
connectStream address = do
ip <- resolve address
s <- case ip of
SockAddrInet _ _ -> socket AF_INET Stream defaultProtocol
SockAddrInet6 _ _ _ _ -> socket AF_INET6 Stream defaultProtocol
SockAddrUnix _ -> socket AF_UNIX Stream defaultProtocol
connect s ip
socketToHandle s ReadWriteMode
resolve :: Address -> IO SockAddr
resolve (Unix path) = return $ SockAddrUnix path
resolve address = do
fits <- getAddrInfo (Just defaultHints{addrFlags=[AI_ADDRCONFIG,AI_NUMERICSERV]})
(Just $ ghead address)
(Just $ show (ghead address :: Int))
let fits' = flip filter (map addrAddress fits) $ \fit ->
case (fit,address) of
(_,IP _ _) -> True
(SockAddrInet _ _, IPv4 _ _) -> True
(SockAddrInet6 _ _ _ _, IPv6 _ _) -> True
_ -> False
when (null fits') $ throwIO $ DNSFailure address
return $ head fits'
streamServer :: Address
-> (Handle -> Address -> IO ())
-> IO (IO ())
streamServer address act = block $ do
socks <- listenAt address
threads <- forM socks $ \server -> forkIO $ flip finally (sClose server) $ unblock $ forever $ do
(sock,sockAddr) <- accept server
address <- reverseLookup sockAddr
handle <- socketToHandle sock ReadWriteMode
trapForkIO "hermes.net.streamServer" $ act handle address `finally` hClose handle
return $ mapM_ killThread threads
reverseLookup :: SockAddr -> IO Address
reverseLookup (SockAddrUnix path) = return $ Unix path
reverseLookup sockAddr = do
(Just host, Just (read -> port)) <- getNameInfo [NI_NUMERICSERV] True True sockAddr
return $ case sockAddr of
SockAddrInet _ _ -> IPv4 host port
SockAddrInet6 _ _ _ _ -> IPv6 host port
type SockLen = Word32
iPPROTO_IPV6 :: CInt
iPPROTO_IPV6 = 41
iPV6_V6ONLY :: CInt
iPV6_V6ONLY = 26
foreign import ccall unsafe "setsockopt" _setsockopt :: CInt -> CInt -> CInt -> Ptr CInt -> SockLen -> IO ()
tryListenAt :: Family -> HostName -> Int -> IO (Maybe Socket)
tryListenAt family host port = do
addr <- getAddrInfo (Just defaultHints{addrFamily=family,addrFlags=[AI_PASSIVE,AI_ADDRCONFIG]})
(if null host then Nothing else Just host)
(Just (show port))
case addr of
[] -> return Nothing
((addrAddress -> address):_) -> do
s <- socket family Stream defaultProtocol
setSocketOption s ReuseAddr 1
when (family == AF_INET6) $ do
alloca $ \intptr -> do
poke intptr 1
_setsockopt (fdSocket s) iPPROTO_IPV6 iPV6_V6ONLY intptr ((4))
bindSocket s address
listen s 3
return $ Just s
listenAt :: Address -> IO [Socket]
listenAt (IP host port) = do
v4 <- tryListenAt AF_INET host port
v6 <- tryListenAt AF_INET6 host port
when (isNothing v4 && isNothing v6) (error "listenAt: No good exception, FIXME")
return $ concat $ [maybeToList v4,maybeToList v6]
listenAt (IPv4 host port) = do
Just s <- tryListenAt AF_INET host port
return [s]
listenAt (IPv6 host port) = do
Just s <- tryListenAt AF_INET6 host port
return [s]