1{-# LANGUAGE CPP #-} 2{-# LANGUAGE RecordWildCards #-} 3{-# OPTIONS_GHC -fno-warn-orphans #-} 4 5#include "HsNet.h" 6##include "HsNetDef.h" 7 8module Network.Socket.Info where 9 10import Foreign.Marshal.Alloc (alloca, allocaBytes) 11import Foreign.Marshal.Utils (maybeWith, with) 12import GHC.IO.Exception (IOErrorType(NoSuchThing)) 13import System.IO.Error (ioeSetErrorString, mkIOError) 14 15import Network.Socket.Imports 16import Network.Socket.Internal 17import Network.Socket.Syscall 18import Network.Socket.Types 19 20----------------------------------------------------------------------------- 21 22-- | Either a host name e.g., @\"haskell.org\"@ or a numeric host 23-- address string consisting of a dotted decimal IPv4 address or an 24-- IPv6 address e.g., @\"192.168.0.1\"@. 25type HostName = String 26-- | Either a service name e.g., @\"http\"@ or a numeric port number. 27type ServiceName = String 28 29----------------------------------------------------------------------------- 30-- Address and service lookups 31 32-- | Flags that control the querying behaviour of 'getAddrInfo'. 33-- For more information, see <https://tools.ietf.org/html/rfc3493#page-25> 34data AddrInfoFlag = 35 -- | The list of returned 'AddrInfo' values will 36 -- only contain IPv4 addresses if the local system has at least 37 -- one IPv4 interface configured, and likewise for IPv6. 38 -- (Only some platforms support this.) 39 AI_ADDRCONFIG 40 -- | If 'AI_ALL' is specified, return all matching IPv6 and 41 -- IPv4 addresses. Otherwise, this flag has no effect. 42 -- (Only some platforms support this.) 43 | AI_ALL 44 -- | The 'addrCanonName' field of the first returned 45 -- 'AddrInfo' will contain the "canonical name" of the host. 46 | AI_CANONNAME 47 -- | The 'HostName' argument /must/ be a numeric 48 -- address in string form, and network name lookups will not be 49 -- attempted. 50 | AI_NUMERICHOST 51 -- | The 'ServiceName' argument /must/ be a port 52 -- number in string form, and service name lookups will not be 53 -- attempted. (Only some platforms support this.) 54 | AI_NUMERICSERV 55 -- | If no 'HostName' value is provided, the network 56 -- address in each 'SockAddr' 57 -- will be left as a "wild card". 58 -- This is useful for server applications that 59 -- will accept connections from any client. 60 | AI_PASSIVE 61 -- | If an IPv6 lookup is performed, and no IPv6 62 -- addresses are found, IPv6-mapped IPv4 addresses will be 63 -- returned. (Only some platforms support this.) 64 | AI_V4MAPPED 65 deriving (Eq, Read, Show) 66 67aiFlagMapping :: [(AddrInfoFlag, CInt)] 68 69aiFlagMapping = 70 [ 71#if HAVE_DECL_AI_ADDRCONFIG 72 (AI_ADDRCONFIG, #const AI_ADDRCONFIG), 73#else 74 (AI_ADDRCONFIG, 0), 75#endif 76#if HAVE_DECL_AI_ALL 77 (AI_ALL, #const AI_ALL), 78#else 79 (AI_ALL, 0), 80#endif 81 (AI_CANONNAME, #const AI_CANONNAME), 82 (AI_NUMERICHOST, #const AI_NUMERICHOST), 83#if HAVE_DECL_AI_NUMERICSERV 84 (AI_NUMERICSERV, #const AI_NUMERICSERV), 85#else 86 (AI_NUMERICSERV, 0), 87#endif 88 (AI_PASSIVE, #const AI_PASSIVE), 89#if HAVE_DECL_AI_V4MAPPED 90 (AI_V4MAPPED, #const AI_V4MAPPED) 91#else 92 (AI_V4MAPPED, 0) 93#endif 94 ] 95 96-- | Indicate whether the given 'AddrInfoFlag' will have any effect on 97-- this system. 98addrInfoFlagImplemented :: AddrInfoFlag -> Bool 99addrInfoFlagImplemented f = packBits aiFlagMapping [f] /= 0 100 101data AddrInfo = AddrInfo { 102 addrFlags :: [AddrInfoFlag] 103 , addrFamily :: Family 104 , addrSocketType :: SocketType 105 , addrProtocol :: ProtocolNumber 106 , addrAddress :: SockAddr 107 , addrCanonName :: Maybe String 108 } deriving (Eq, Show) 109 110instance Storable AddrInfo where 111 sizeOf _ = #const sizeof(struct addrinfo) 112 alignment _ = alignment (0 :: CInt) 113 114 peek p = do 115 ai_flags <- (#peek struct addrinfo, ai_flags) p 116 ai_family <- (#peek struct addrinfo, ai_family) p 117 ai_socktype <- (#peek struct addrinfo, ai_socktype) p 118 ai_protocol <- (#peek struct addrinfo, ai_protocol) p 119 ai_addr <- (#peek struct addrinfo, ai_addr) p >>= peekSockAddr 120 ai_canonname_ptr <- (#peek struct addrinfo, ai_canonname) p 121 122 ai_canonname <- if ai_canonname_ptr == nullPtr 123 then return Nothing 124 else Just <$> peekCString ai_canonname_ptr 125 126 return $ AddrInfo { 127 addrFlags = unpackBits aiFlagMapping ai_flags 128 , addrFamily = unpackFamily ai_family 129 , addrSocketType = unpackSocketType ai_socktype 130 , addrProtocol = ai_protocol 131 , addrAddress = ai_addr 132 , addrCanonName = ai_canonname 133 } 134 135 poke p (AddrInfo flags family sockType protocol _ _) = do 136 let c_stype = packSocketType sockType 137 138 (#poke struct addrinfo, ai_flags) p (packBits aiFlagMapping flags) 139 (#poke struct addrinfo, ai_family) p (packFamily family) 140 (#poke struct addrinfo, ai_socktype) p c_stype 141 (#poke struct addrinfo, ai_protocol) p protocol 142 143 -- stuff below is probably not needed, but let's zero it for safety 144 145 (#poke struct addrinfo, ai_addrlen) p (0::CSize) 146 (#poke struct addrinfo, ai_addr) p nullPtr 147 (#poke struct addrinfo, ai_canonname) p nullPtr 148 (#poke struct addrinfo, ai_next) p nullPtr 149 150-- | Flags that control the querying behaviour of 'getNameInfo'. 151-- For more information, see <https://tools.ietf.org/html/rfc3493#page-30> 152data NameInfoFlag = 153 -- | Resolve a datagram-based service name. This is 154 -- required only for the few protocols that have different port 155 -- numbers for their datagram-based versions than for their 156 -- stream-based versions. 157 NI_DGRAM 158 -- | If the hostname cannot be looked up, an IO error is thrown. 159 | NI_NAMEREQD 160 -- | If a host is local, return only the hostname part of the FQDN. 161 | NI_NOFQDN 162 -- | The name of the host is not looked up. 163 -- Instead, a numeric representation of the host's 164 -- address is returned. For an IPv4 address, this will be a 165 -- dotted-quad string. For IPv6, it will be colon-separated 166 -- hexadecimal. 167 | NI_NUMERICHOST 168 -- | The name of the service is not 169 -- looked up. Instead, a numeric representation of the 170 -- service is returned. 171 | NI_NUMERICSERV 172 deriving (Eq, Read, Show) 173 174niFlagMapping :: [(NameInfoFlag, CInt)] 175 176niFlagMapping = [(NI_DGRAM, #const NI_DGRAM), 177 (NI_NAMEREQD, #const NI_NAMEREQD), 178 (NI_NOFQDN, #const NI_NOFQDN), 179 (NI_NUMERICHOST, #const NI_NUMERICHOST), 180 (NI_NUMERICSERV, #const NI_NUMERICSERV)] 181 182-- | Default hints for address lookup with 'getAddrInfo'. 183-- 184-- >>> addrFlags defaultHints 185-- [] 186-- >>> addrFamily defaultHints 187-- AF_UNSPEC 188-- >>> addrSocketType defaultHints 189-- NoSocketType 190-- >>> addrProtocol defaultHints 191-- 0 192 193defaultHints :: AddrInfo 194defaultHints = AddrInfo { 195 addrFlags = [] 196 , addrFamily = AF_UNSPEC 197 , addrSocketType = NoSocketType 198 , addrProtocol = defaultProtocol 199 , addrAddress = SockAddrInet 0 0 200 , addrCanonName = Nothing 201 } 202 203----------------------------------------------------------------------------- 204-- | Resolve a host or service name to one or more addresses. 205-- The 'AddrInfo' values that this function returns contain 'SockAddr' 206-- values that you can pass directly to 'connect' or 207-- 'bind'. 208-- 209-- This function is protocol independent. It can return both IPv4 and 210-- IPv6 address information. 211-- 212-- The 'AddrInfo' argument specifies the preferred query behaviour, 213-- socket options, or protocol. You can override these conveniently 214-- using Haskell's record update syntax on 'defaultHints', for example 215-- as follows: 216-- 217-- >>> let hints = defaultHints { addrFlags = [AI_NUMERICHOST], addrSocketType = Stream } 218-- 219-- You must provide a 'Just' value for at least one of the 'HostName' 220-- or 'ServiceName' arguments. 'HostName' can be either a numeric 221-- network address (dotted quad for IPv4, colon-separated hex for 222-- IPv6) or a hostname. In the latter case, its addresses will be 223-- looked up unless 'AI_NUMERICHOST' is specified as a hint. If you 224-- do not provide a 'HostName' value /and/ do not set 'AI_PASSIVE' as 225-- a hint, network addresses in the result will contain the address of 226-- the loopback interface. 227-- 228-- If the query fails, this function throws an IO exception instead of 229-- returning an empty list. Otherwise, it returns a non-empty list 230-- of 'AddrInfo' values. 231-- 232-- There are several reasons why a query might result in several 233-- values. For example, the queried-for host could be multihomed, or 234-- the service might be available via several protocols. 235-- 236-- Note: the order of arguments is slightly different to that defined 237-- for @getaddrinfo@ in RFC 2553. The 'AddrInfo' parameter comes first 238-- to make partial application easier. 239-- 240-- >>> addr:_ <- getAddrInfo (Just hints) (Just "127.0.0.1") (Just "http") 241-- >>> addrAddress addr 242-- 127.0.0.1:80 243 244getAddrInfo 245 :: Maybe AddrInfo -- ^ preferred socket type or protocol 246 -> Maybe HostName -- ^ host name to look up 247 -> Maybe ServiceName -- ^ service name to look up 248 -> IO [AddrInfo] -- ^ resolved addresses, with "best" first 249getAddrInfo hints node service = alloc getaddrinfo 250 where 251 alloc body = withSocketsDo $ maybeWith withCString node $ \c_node -> 252 maybeWith withCString service $ \c_service -> 253 maybeWith with filteredHints $ \c_hints -> 254 alloca $ \ptr_ptr_addrs -> 255 body c_node c_service c_hints ptr_ptr_addrs 256 getaddrinfo c_node c_service c_hints ptr_ptr_addrs = do 257 ret <- c_getaddrinfo c_node c_service c_hints ptr_ptr_addrs 258 if ret == 0 then do 259 ptr_addrs <- peek ptr_ptr_addrs 260 ais <- followAddrInfo ptr_addrs 261 c_freeaddrinfo ptr_addrs 262 -- POSIX requires that getaddrinfo(3) returns at least one addrinfo. 263 -- See: http://pubs.opengroup.org/onlinepubs/9699919799/functions/getaddrinfo.html 264 case ais of 265 [] -> ioError $ mkIOError NoSuchThing message Nothing Nothing 266 _ -> return ais 267 else do 268 err <- gai_strerror ret 269 ioError $ ioeSetErrorString 270 (mkIOError NoSuchThing message Nothing Nothing) 271 err 272 message = concat [ 273 "Network.Socket.getAddrInfo (called with preferred socket type/protocol: " 274 , maybe "Nothing" show hints 275 , ", host name: " 276 , show node 277 , ", service name: " 278 , show service 279 , ")" 280 ] 281#if defined(darwin_HOST_OS) 282 -- Leaving out the service and using AI_NUMERICSERV causes a 283 -- segfault on OS X 10.8.2. This code removes AI_NUMERICSERV 284 -- (which has no effect) in that case. 285 toHints h = h { addrFlags = delete AI_NUMERICSERV (addrFlags h) } 286 filteredHints = case service of 287 Nothing -> toHints <$> hints 288 _ -> hints 289#else 290 filteredHints = hints 291#endif 292 293followAddrInfo :: Ptr AddrInfo -> IO [AddrInfo] 294followAddrInfo ptr_ai 295 | ptr_ai == nullPtr = return [] 296 | otherwise = do 297 a <- peek ptr_ai 298 as <- (# peek struct addrinfo, ai_next) ptr_ai >>= followAddrInfo 299 return (a : as) 300 301foreign import ccall safe "hsnet_getaddrinfo" 302 c_getaddrinfo :: CString -> CString -> Ptr AddrInfo -> Ptr (Ptr AddrInfo) 303 -> IO CInt 304 305foreign import ccall safe "hsnet_freeaddrinfo" 306 c_freeaddrinfo :: Ptr AddrInfo -> IO () 307 308gai_strerror :: CInt -> IO String 309 310#ifdef HAVE_GAI_STRERROR 311gai_strerror n = c_gai_strerror n >>= peekCString 312 313foreign import ccall safe "gai_strerror" 314 c_gai_strerror :: CInt -> IO CString 315#else 316gai_strerror n = ioError $ userError $ "Network.Socket.gai_strerror not supported: " ++ show n 317#endif 318 319----------------------------------------------------------------------------- 320 321withCStringIf :: Bool -> Int -> (CSize -> CString -> IO a) -> IO a 322withCStringIf False _ f = f 0 nullPtr 323withCStringIf True n f = allocaBytes n (f (fromIntegral n)) 324 325-- | Resolve an address to a host or service name. 326-- This function is protocol independent. 327-- The list of 'NameInfoFlag' values controls query behaviour. 328-- 329-- If a host or service's name cannot be looked up, then the numeric 330-- form of the address or service will be returned. 331-- 332-- If the query fails, this function throws an IO exception. 333-- 334-- >>> addr:_ <- getAddrInfo (Just defaultHints) (Just "127.0.0.1") (Just "http") 335-- >>> getNameInfo [NI_NUMERICHOST, NI_NUMERICSERV] True True $ addrAddress addr 336-- (Just "127.0.0.1",Just "80") 337{- 338-- >>> getNameInfo [] True True $ addrAddress addr 339-- (Just "localhost",Just "http") 340-} 341getNameInfo 342 :: [NameInfoFlag] -- ^ flags to control lookup behaviour 343 -> Bool -- ^ whether to look up a hostname 344 -> Bool -- ^ whether to look up a service name 345 -> SockAddr -- ^ the address to look up 346 -> IO (Maybe HostName, Maybe ServiceName) 347getNameInfo flags doHost doService addr = alloc getnameinfo 348 where 349 alloc body = withSocketsDo $ 350 withCStringIf doHost (# const NI_MAXHOST) $ \c_hostlen c_host -> 351 withCStringIf doService (# const NI_MAXSERV) $ \c_servlen c_serv -> 352 withSockAddr addr $ \ptr_addr sz -> 353 body c_hostlen c_host c_servlen c_serv ptr_addr sz 354 getnameinfo c_hostlen c_host c_servlen c_serv ptr_addr sz = do 355 ret <- c_getnameinfo ptr_addr 356 (fromIntegral sz) 357 c_host 358 c_hostlen 359 c_serv 360 c_servlen 361 (packBits niFlagMapping flags) 362 if ret == 0 then do 363 let peekIf doIf c_val = 364 if doIf then Just <$> peekCString c_val else return Nothing 365 host <- peekIf doHost c_host 366 serv <- peekIf doService c_serv 367 return (host, serv) 368 else do 369 err <- gai_strerror ret 370 ioError $ ioeSetErrorString 371 (mkIOError NoSuchThing message Nothing Nothing) 372 err 373 message = concat [ 374 "Network.Socket.getNameInfo (called with flags: " 375 , show flags 376 , ", hostname lookup: " 377 , show doHost 378 , ", service name lookup: " 379 , show doService 380 , ", socket address: " 381 , show addr 382 , ")" 383 ] 384 385foreign import ccall safe "hsnet_getnameinfo" 386 c_getnameinfo :: Ptr SockAddr -> CInt{-CSockLen???-} -> CString -> CSize -> CString 387 -> CSize -> CInt -> IO CInt 388 389-- | Pack a list of values into a bitmask. The possible mappings from 390-- value to bit-to-set are given as the first argument. We assume 391-- that each value can cause exactly one bit to be set; unpackBits will 392-- break if this property is not true. 393 394----------------------------------------------------------------------------- 395 396packBits :: (Eq a, Num b, Bits b) => [(a, b)] -> [a] -> b 397packBits mapping xs = foldl' pack 0 mapping 398 where 399 pack acc (k, v) | k `elem` xs = acc .|. v 400 | otherwise = acc 401 402-- | Unpack a bitmask into a list of values. 403unpackBits :: (Num b, Bits b) => [(a, b)] -> b -> [a] 404-- Be permissive and ignore unknown bit values. At least on OS X, 405-- getaddrinfo returns an ai_flags field with bits set that have no 406-- entry in <netdb.h>. 407unpackBits [] _ = [] 408unpackBits ((k,v):xs) r 409 | r .&. v /= 0 = k : unpackBits xs (r .&. complement v) 410 | otherwise = unpackBits xs r 411 412----------------------------------------------------------------------------- 413-- SockAddr 414 415instance Show SockAddr where 416#if defined(DOMAIN_SOCKET_SUPPORT) 417 showsPrec _ (SockAddrUnix str) = showString str 418#else 419 showsPrec _ SockAddrUnix{} = error "showsPrec: not supported" 420#endif 421 showsPrec _ (SockAddrInet port ha) 422 = showHostAddress ha 423 . showString ":" 424 . shows port 425 showsPrec _ (SockAddrInet6 port _ ha6 _) 426 = showChar '[' 427 . showHostAddress6 ha6 428 . showString "]:" 429 . shows port 430 431 432-- Taken from on the implementation of showIPv4 in Data.IP.Addr 433showHostAddress :: HostAddress -> ShowS 434showHostAddress ip = 435 let (u3, u2, u1, u0) = hostAddressToTuple ip in 436 foldr1 (.) . intersperse (showChar '.') $ map showInt [u3, u2, u1, u0] 437 438-- Taken from showIPv6 in Data.IP.Addr. 439 440-- | Show an IPv6 address in the most appropriate notation, based on recommended 441-- representation proposed by <http://tools.ietf.org/html/rfc5952 RFC 5952>. 442-- 443-- /The implementation is completely compatible with the current implementation 444-- of the `inet_ntop` function in glibc./ 445showHostAddress6 :: HostAddress6 -> ShowS 446showHostAddress6 ha6@(a1, a2, a3, a4) 447 -- IPv4-Mapped IPv6 Address 448 | a1 == 0 && a2 == 0 && a3 == 0xffff = 449 showString "::ffff:" . showHostAddress a4 450 -- IPv4-Compatible IPv6 Address (exclude IPRange ::/112) 451 | a1 == 0 && a2 == 0 && a3 == 0 && a4 >= 0x10000 = 452 showString "::" . showHostAddress a4 453 -- length of longest run > 1, replace it with "::" 454 | end - begin > 1 = 455 showFields prefix . showString "::" . showFields suffix 456 | otherwise = 457 showFields fields 458 where 459 fields = 460 let (u7, u6, u5, u4, u3, u2, u1, u0) = hostAddress6ToTuple ha6 in 461 [u7, u6, u5, u4, u3, u2, u1, u0] 462 showFields = foldr (.) id . intersperse (showChar ':') . map showHex 463 prefix = take begin fields -- fields before "::" 464 suffix = drop end fields -- fields after "::" 465 begin = end + diff -- the longest run of zeros 466 (diff, end) = minimum $ 467 scanl (\c i -> if i == 0 then c - 1 else 0) 0 fields `zip` [0..] 468 469----------------------------------------------------------------------------- 470 471-- | A utility function to open a socket with `AddrInfo`. 472-- This is a just wrapper for the following code: 473-- 474-- > \addr -> socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr) 475openSocket :: AddrInfo -> IO Socket 476openSocket addr = socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr) 477