network-3.2.6.0: Network/Socket/Info.hsc
{-# LANGUAGE CPP #-}
{-# LANGUAGE RecordWildCards #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
#include "HsNet.h"
##include "HsNetDef.h"
module Network.Socket.Info where
import Data.List.NonEmpty (NonEmpty(..))
import qualified Data.List.NonEmpty as NE
import Foreign.Marshal.Alloc (alloca, allocaBytes)
import Foreign.Marshal.Utils (maybeWith, with)
import GHC.IO.Exception (IOErrorType(NoSuchThing))
import System.IO.Error (ioeSetErrorString, mkIOError)
import Network.Socket.Imports
import Network.Socket.Internal
import Network.Socket.Syscall
import Network.Socket.Types
-----------------------------------------------------------------------------
-- | Either a host name e.g., @\"haskell.org\"@ or a numeric host
-- address string consisting of a dotted decimal IPv4 address or an
-- IPv6 address e.g., @\"192.168.0.1\"@.
type HostName = String
-- | Either a service name e.g., @\"http\"@ or a numeric port number.
type ServiceName = String
-----------------------------------------------------------------------------
-- Address and service lookups
-- | Flags that control the querying behaviour of 'getAddrInfo'.
-- For more information, see <https://tools.ietf.org/html/rfc3493#page-25>
data AddrInfoFlag =
-- | The list of returned 'AddrInfo' values will
-- only contain IPv4 addresses if the local system has at least
-- one IPv4 interface configured, and likewise for IPv6.
-- (Only some platforms support this.)
AI_ADDRCONFIG
-- | If 'AI_ALL' is specified, return all matching IPv6 and
-- IPv4 addresses. Otherwise, this flag has no effect.
-- (Only some platforms support this.)
| AI_ALL
-- | The 'addrCanonName' field of the first returned
-- 'AddrInfo' will contain the "canonical name" of the host.
| AI_CANONNAME
-- | The 'HostName' argument /must/ be a numeric
-- address in string form, and network name lookups will not be
-- attempted.
| AI_NUMERICHOST
-- | The 'ServiceName' argument /must/ be a port
-- number in string form, and service name lookups will not be
-- attempted. (Only some platforms support this.)
| AI_NUMERICSERV
-- | If no 'HostName' value is provided, the network
-- address in each 'SockAddr'
-- will be left as a "wild card".
-- This is useful for server applications that
-- will accept connections from any client.
| AI_PASSIVE
-- | If an IPv6 lookup is performed, and no IPv6
-- addresses are found, IPv6-mapped IPv4 addresses will be
-- returned. (Only some platforms support this.)
| AI_V4MAPPED
deriving (Eq, Read, Show)
aiFlagMapping :: [(AddrInfoFlag, CInt)]
aiFlagMapping =
[
#if HAVE_DECL_AI_ADDRCONFIG
(AI_ADDRCONFIG, #const AI_ADDRCONFIG),
#else
(AI_ADDRCONFIG, 0),
#endif
#if HAVE_DECL_AI_ALL
(AI_ALL, #const AI_ALL),
#else
(AI_ALL, 0),
#endif
(AI_CANONNAME, #const AI_CANONNAME),
(AI_NUMERICHOST, #const AI_NUMERICHOST),
#if HAVE_DECL_AI_NUMERICSERV
(AI_NUMERICSERV, #const AI_NUMERICSERV),
#else
(AI_NUMERICSERV, 0),
#endif
(AI_PASSIVE, #const AI_PASSIVE),
#if HAVE_DECL_AI_V4MAPPED
(AI_V4MAPPED, #const AI_V4MAPPED)
#else
(AI_V4MAPPED, 0)
#endif
]
-- | Indicate whether the given 'AddrInfoFlag' will have any effect on
-- this system.
addrInfoFlagImplemented :: AddrInfoFlag -> Bool
addrInfoFlagImplemented f = packBits aiFlagMapping [f] /= 0
data AddrInfo = AddrInfo {
addrFlags :: [AddrInfoFlag]
, addrFamily :: Family
, addrSocketType :: SocketType
, addrProtocol :: ProtocolNumber
, addrAddress :: SockAddr
, addrCanonName :: Maybe String
} deriving (Eq, Show)
instance Storable AddrInfo where
sizeOf ~_ = #const sizeof(struct addrinfo)
alignment ~_ = alignment (0 :: CInt)
peek p = do
ai_flags <- (#peek struct addrinfo, ai_flags) p
ai_family <- (#peek struct addrinfo, ai_family) p
ai_socktype <- (#peek struct addrinfo, ai_socktype) p
ai_protocol <- (#peek struct addrinfo, ai_protocol) p
ai_addr <- (#peek struct addrinfo, ai_addr) p >>= peekSockAddr
ai_canonname_ptr <- (#peek struct addrinfo, ai_canonname) p
ai_canonname <- if ai_canonname_ptr == nullPtr
then return Nothing
else Just <$> peekCString ai_canonname_ptr
return $ AddrInfo {
addrFlags = unpackBits aiFlagMapping ai_flags
, addrFamily = unpackFamily ai_family
, addrSocketType = unpackSocketType ai_socktype
, addrProtocol = ai_protocol
, addrAddress = ai_addr
, addrCanonName = ai_canonname
}
poke p (AddrInfo flags family sockType protocol _ _) = do
let c_stype = packSocketType sockType
(#poke struct addrinfo, ai_flags) p (packBits aiFlagMapping flags)
(#poke struct addrinfo, ai_family) p (packFamily family)
(#poke struct addrinfo, ai_socktype) p c_stype
(#poke struct addrinfo, ai_protocol) p protocol
-- stuff below is probably not needed, but let's zero it for safety
(#poke struct addrinfo, ai_addrlen) p (0::CSize)
(#poke struct addrinfo, ai_addr) p nullPtr
(#poke struct addrinfo, ai_canonname) p nullPtr
(#poke struct addrinfo, ai_next) p nullPtr
-- | Flags that control the querying behaviour of 'getNameInfo'.
-- For more information, see <https://tools.ietf.org/html/rfc3493#page-30>
data NameInfoFlag =
-- | Resolve a datagram-based service name. This is
-- required only for the few protocols that have different port
-- numbers for their datagram-based versions than for their
-- stream-based versions.
NI_DGRAM
-- | If the hostname cannot be looked up, an IO error is thrown.
| NI_NAMEREQD
-- | If a host is local, return only the hostname part of the FQDN.
| NI_NOFQDN
-- | The name of the host is not looked up.
-- Instead, a numeric representation of the host's
-- address is returned. For an IPv4 address, this will be a
-- dotted-quad string. For IPv6, it will be colon-separated
-- hexadecimal.
| NI_NUMERICHOST
-- | The name of the service is not
-- looked up. Instead, a numeric representation of the
-- service is returned.
| NI_NUMERICSERV
deriving (Eq, Read, Show)
niFlagMapping :: [(NameInfoFlag, CInt)]
niFlagMapping = [(NI_DGRAM, #const NI_DGRAM),
(NI_NAMEREQD, #const NI_NAMEREQD),
(NI_NOFQDN, #const NI_NOFQDN),
(NI_NUMERICHOST, #const NI_NUMERICHOST),
(NI_NUMERICSERV, #const NI_NUMERICSERV)]
-- | Default hints for address lookup with 'getAddrInfo'.
--
-- >>> addrFlags defaultHints
-- []
-- >>> addrFamily defaultHints
-- AF_UNSPEC
-- >>> addrSocketType defaultHints
-- NoSocketType
-- >>> addrProtocol defaultHints
-- 0
defaultHints :: AddrInfo
defaultHints = AddrInfo {
addrFlags = []
, addrFamily = AF_UNSPEC
, addrSocketType = NoSocketType
, addrProtocol = defaultProtocol
, addrAddress = SockAddrInet 0 0
, addrCanonName = Nothing
}
class GetAddrInfo t where
-----------------------------------------------------------------------------
-- | Resolve a host or service name to one or more addresses.
-- The 'AddrInfo' values that this function returns contain 'SockAddr'
-- values that you can pass directly to 'connect' or
-- 'bind'.
--
-- This function calls @getaddrinfo(3)@, which never successfully returns
-- with an empty list. If the query fails, 'getAddrInfo' throws an IO
-- exception.
--
-- For backwards-compatibility reasons, a hidden 'GetAddrInfo' class is used
-- to make the result polymorphic. It only has instances for @[]@ (lists)
-- and 'NonEmpty'. Use of 'NonEmpty' is recommended.
--
-- This function is protocol independent. It can return both IPv4 and
-- IPv6 address information.
--
-- The 'AddrInfo' argument specifies the preferred query behaviour,
-- socket options, or protocol. You can override these conveniently
-- using Haskell's record update syntax on 'defaultHints', for example
-- as follows:
--
-- >>> let hints = defaultHints { addrFlags = [AI_NUMERICHOST], addrSocketType = Stream }
--
-- You must provide a 'Just' value for at least one of the 'HostName'
-- or 'ServiceName' arguments. 'HostName' can be either a numeric
-- network address (dotted quad for IPv4, colon-separated hex for
-- IPv6) or a hostname. In the latter case, its addresses will be
-- looked up unless 'AI_NUMERICHOST' is specified as a hint. If you
-- do not provide a 'HostName' value /and/ do not set 'AI_PASSIVE' as
-- a hint, network addresses in the result will contain the address of
-- the loopback interface.
--
-- There are several reasons why a query might result in several
-- values. For example, the queried-for host could be multihomed, or
-- the service might be available via several protocols.
--
-- Note: the order of arguments is slightly different to that defined
-- for @getaddrinfo@ in RFC 2553. The 'AddrInfo' parameter comes first
-- to make partial application easier.
--
-- >>> import qualified Data.List.NonEmpty as NE
-- >>> addr <- NE.head <$> getAddrInfo (Just hints) (Just "127.0.0.1") (Just "http")
-- >>> addrAddress addr
-- 127.0.0.1:80
--
-- Polymorphic version: @since 3.2.3.0
getAddrInfo
:: Maybe AddrInfo -- ^ preferred socket type or protocol
-> Maybe HostName -- ^ host name to look up
-> Maybe ServiceName -- ^ service name to look up
-> IO (t AddrInfo) -- ^ resolved addresses, with "best" first
instance GetAddrInfo [] where
getAddrInfo = getAddrInfoList
instance GetAddrInfo NE.NonEmpty where
getAddrInfo = getAddrInfoNE
getAddrInfoNE
:: Maybe AddrInfo -- ^ preferred socket type or protocol
-> Maybe HostName -- ^ host name to look up
-> Maybe ServiceName -- ^ service name to look up
-> IO (NonEmpty AddrInfo) -- ^ resolved addresses, with "best" first
getAddrInfoNE hints node service = alloc getaddrinfo
where
alloc body = withSocketsDo $ maybeWith withCString node $ \c_node ->
maybeWith withCString service $ \c_service ->
maybeWith with filteredHints $ \c_hints ->
alloca $ \ptr_ptr_addrs ->
body c_node c_service c_hints ptr_ptr_addrs
getaddrinfo c_node c_service c_hints ptr_ptr_addrs = do
ret <- c_getaddrinfo c_node c_service c_hints ptr_ptr_addrs
if ret == 0 then do
ptr_addrs <- peek ptr_ptr_addrs
ais <- followAddrInfo ptr_addrs
return ais
else do
err <- gai_strerror ret
ioError $ ioeSetErrorString
(mkIOError NoSuchThing message Nothing Nothing)
err
message = concat [
"Network.Socket.getAddrInfo (called with preferred socket type/protocol: "
, maybe "Nothing" show hints
, ", host name: "
, maybe "Nothing" show node
, ", service name: "
, maybe "Nothing" show service
, ")"
]
#if defined(darwin_HOST_OS)
-- Leaving out the service and using AI_NUMERICSERV causes a
-- segfault on OS X 10.8.2. This code removes AI_NUMERICSERV
-- (which has no effect) in that case.
toHints h = h { addrFlags = delete AI_NUMERICSERV (addrFlags h) }
filteredHints = case service of
Nothing -> toHints <$> hints
_ -> hints
#else
filteredHints = hints
#endif
getAddrInfoList
:: Maybe AddrInfo
-> Maybe HostName
-> Maybe ServiceName
-> IO [AddrInfo]
getAddrInfoList hints node service =
-- getAddrInfo never returns an empty list.
NE.toList <$> getAddrInfoNE hints node service
followAddrInfo :: Ptr AddrInfo -> IO (NonEmpty AddrInfo)
followAddrInfo ptr_ai
-- POSIX requires that getaddrinfo(3) returns at least one addrinfo.
-- See: http://pubs.opengroup.org/onlinepubs/9699919799/functions/getaddrinfo.html
| ptr_ai == nullPtr = ioError $ mkIOError NoSuchThing "getaddrinfo must return at least one addrinfo" Nothing Nothing
| otherwise = do
a <- peek ptr_ai
ptr <- (# peek struct addrinfo, ai_next) ptr_ai
(a :|) <$> go ptr
where
go :: Ptr AddrInfo -> IO [AddrInfo]
go ptr
| ptr == nullPtr = return []
| otherwise = do
a' <- peek ptr
ptr' <- (# peek struct addrinfo, ai_next) ptr
as' <- go ptr'
return (a':as')
foreign import ccall safe "hsnet_getaddrinfo"
c_getaddrinfo :: CString -> CString -> Ptr AddrInfo -> Ptr (Ptr AddrInfo)
-> IO CInt
foreign import ccall safe "hsnet_freeaddrinfo"
c_freeaddrinfo :: Ptr AddrInfo -> IO ()
gai_strerror :: CInt -> IO String
#ifdef HAVE_GAI_STRERROR
gai_strerror n = c_gai_strerror n >>= peekCString
foreign import ccall safe "gai_strerror"
c_gai_strerror :: CInt -> IO CString
#else
gai_strerror n = ioError $ userError $ "Network.Socket.gai_strerror not supported: " ++ show n
#endif
-----------------------------------------------------------------------------
withCStringIf :: Bool -> Int -> (CSize -> CString -> IO a) -> IO a
withCStringIf False _ f = f 0 nullPtr
withCStringIf True n f = allocaBytes n (f (fromIntegral n))
-- | Resolve an address to a host or service name.
-- This function is protocol independent.
-- The list of 'NameInfoFlag' values controls query behaviour.
--
-- If a host or service's name cannot be looked up, then the numeric
-- form of the address or service will be returned.
--
-- If the query fails, this function throws an IO exception.
--
-- >>> addr:_ <- getAddrInfo (Just defaultHints) (Just "127.0.0.1") (Just "http")
-- >>> getNameInfo [NI_NUMERICHOST, NI_NUMERICSERV] True True $ addrAddress addr
-- (Just "127.0.0.1",Just "80")
{-
-- >>> getNameInfo [] True True $ addrAddress addr
-- (Just "localhost",Just "http")
-}
getNameInfo
:: [NameInfoFlag] -- ^ flags to control lookup behaviour
-> Bool -- ^ whether to look up a hostname
-> Bool -- ^ whether to look up a service name
-> SockAddr -- ^ the address to look up
-> IO (Maybe HostName, Maybe ServiceName)
getNameInfo flags doHost doService addr = alloc getnameinfo
where
alloc body = withSocketsDo $
withCStringIf doHost (# const NI_MAXHOST) $ \c_hostlen c_host ->
withCStringIf doService (# const NI_MAXSERV) $ \c_servlen c_serv ->
withSockAddr addr $ \ptr_addr sz ->
body c_hostlen c_host c_servlen c_serv ptr_addr sz
getnameinfo c_hostlen c_host c_servlen c_serv ptr_addr sz = do
ret <- c_getnameinfo ptr_addr
(fromIntegral sz)
c_host
c_hostlen
c_serv
c_servlen
(packBits niFlagMapping flags)
if ret == 0 then do
let peekIf doIf c_val =
if doIf then Just <$> peekCString c_val else return Nothing
host <- peekIf doHost c_host
serv <- peekIf doService c_serv
return (host, serv)
else do
err <- gai_strerror ret
ioError $ ioeSetErrorString
(mkIOError NoSuchThing message Nothing Nothing)
err
message = concat [
"Network.Socket.getNameInfo (called with flags: "
, show flags
, ", hostname lookup: "
, show doHost
, ", service name lookup: "
, show doService
, ", socket address: "
, show addr
, ")"
]
foreign import ccall safe "hsnet_getnameinfo"
c_getnameinfo :: Ptr SockAddr -> CInt{-CSockLen???-} -> CString -> CSize -> CString
-> CSize -> CInt -> IO CInt
-- | Pack a list of values into a bitmask. The possible mappings from
-- value to bit-to-set are given as the first argument. We assume
-- that each value can cause exactly one bit to be set; unpackBits will
-- break if this property is not true.
-----------------------------------------------------------------------------
packBits :: (Eq a, Num b, Bits b) => [(a, b)] -> [a] -> b
packBits mapping xs = foldl' pack 0 mapping
where
pack acc (k, v) | k `elem` xs = acc .|. v
| otherwise = acc
-- | Unpack a bitmask into a list of values.
unpackBits :: (Num b, Bits b) => [(a, b)] -> b -> [a]
-- Be permissive and ignore unknown bit values. At least on OS X,
-- getaddrinfo returns an ai_flags field with bits set that have no
-- entry in <netdb.h>.
unpackBits [] _ = []
unpackBits ((k,v):xs) r
| r .&. v /= 0 = k : unpackBits xs (r .&. complement v)
| otherwise = unpackBits xs r
-----------------------------------------------------------------------------
-- SockAddr
-- |
--
-- >>> SockAddrInet6 80 0 (0,0,0xffff,0x01020304) 0
-- [::ffff:1.2.3.4]:80
instance Show SockAddr where
showsPrec _ (SockAddrUnix str) = showString str
showsPrec _ (SockAddrInet port ha)
= showHostAddress ha
. showString ":"
. shows port
showsPrec _ (SockAddrInet6 port _ ha6 _)
= showChar '['
. showHostAddress6 ha6
. showString "]:"
. shows port
-- Taken from on the implementation of showIPv4 in Data.IP.Addr
showHostAddress :: HostAddress -> ShowS
showHostAddress ip =
let (u3, u2, u1, u0) = hostAddressToTuple ip in
foldr1 (.) . intersperse (showChar '.') $ map showInt [u3, u2, u1, u0]
showHostAddress' :: HostAddress -> ShowS
showHostAddress' ip =
let (u3, u2, u1, u0) = hostAddressToTuple' ip in
foldr1 (.) . intersperse (showChar '.') $ map showInt [u3, u2, u1, u0]
-- Taken from showIPv6 in Data.IP.Addr.
-- | Show an IPv6 address in the most appropriate notation, based on recommended
-- representation proposed by <http://tools.ietf.org/html/rfc5952 RFC 5952>.
--
-- /The implementation is completely compatible with the current implementation
-- of the `inet_ntop` function in glibc./
showHostAddress6 :: HostAddress6 -> ShowS
showHostAddress6 ha6@(a1, a2, a3, a4)
-- IPv4-Mapped IPv6 Address
| a1 == 0 && a2 == 0 && a3 == 0xffff =
showString "::ffff:" . showHostAddress' a4
-- IPv4-Compatible IPv6 Address (exclude IPRange ::/112)
| a1 == 0 && a2 == 0 && a3 == 0 && a4 >= 0x10000 =
showString "::" . showHostAddress' a4
-- length of longest run > 1, replace it with "::"
| end - begin > 1 =
showFields prefix . showString "::" . showFields suffix
| otherwise =
showFields fields
where
fields =
let (u7, u6, u5, u4, u3, u2, u1, u0) = hostAddress6ToTuple ha6 in
[u7, u6, u5, u4, u3, u2, u1, u0]
showFields = foldr (.) id . intersperse (showChar ':') . map showHex
prefix = take begin fields -- fields before "::"
suffix = drop end fields -- fields after "::"
begin = end + diff -- the longest run of zeros
(diff, end) = minimum $
scanl (\c i -> if i == 0 then c - 1 else 0) 0 fields `zip` [0..]
-----------------------------------------------------------------------------
-- | A utility function to open a socket with `AddrInfo`.
-- This is a just wrapper for the following code:
--
-- > \addr -> socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)
openSocket :: AddrInfo -> IO Socket
openSocket addr = socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)