{-# LINE 1 "Z/IO/Network/DNS.hsc" #-}
module Z.IO.Network.DNS (
getAddrInfo
, HostName
, ServiceName
, AddrInfoFlag(..), addrInfoFlagImplemented, addrInfoFlagMapping
, AddrInfo(..), defaultHints, followAddrInfo
, getNameInfo
, NameInfoFlag(..), nameInfoFlagMapping
) where
import Data.Bits
import Data.List as List
import Data.Word
import Foreign.C.Types
import Foreign.Marshal.Utils
import Foreign.Ptr
import Foreign.Storable
import GHC.Generics
import Z.Data.CBytes as CBytes
import Z.Data.Text.Print (Print(..))
import Z.Data.JSON (JSON)
import Z.Foreign
import Z.IO.Exception
import Z.IO.Network.SocketAddr
import Z.IO.UV.Win
type HostName = CBytes
type ServiceName = CBytes
data AddrInfoFlag =
AI_ADDRCONFIG
| AI_ALL
| AI_CANONNAME
| AI_NUMERICHOST
| AI_NUMERICSERV
| AI_PASSIVE
| AI_V4MAPPED
deriving (Eq, Ord, Read, Show, Generic)
deriving anyclass (Print, JSON)
addrInfoFlagMapping :: [(AddrInfoFlag, CInt)]
addrInfoFlagMapping =
[
{-# LINE 95 "Z/IO/Network/DNS.hsc" #-}
(AI_ADDRCONFIG, 32),
{-# LINE 96 "Z/IO/Network/DNS.hsc" #-}
{-# LINE 99 "Z/IO/Network/DNS.hsc" #-}
{-# LINE 100 "Z/IO/Network/DNS.hsc" #-}
(AI_ALL, 16),
{-# LINE 101 "Z/IO/Network/DNS.hsc" #-}
{-# LINE 104 "Z/IO/Network/DNS.hsc" #-}
(AI_CANONNAME, 2),
{-# LINE 105 "Z/IO/Network/DNS.hsc" #-}
(AI_NUMERICHOST, 4),
{-# LINE 106 "Z/IO/Network/DNS.hsc" #-}
{-# LINE 107 "Z/IO/Network/DNS.hsc" #-}
(AI_NUMERICSERV, 1024),
{-# LINE 108 "Z/IO/Network/DNS.hsc" #-}
{-# LINE 111 "Z/IO/Network/DNS.hsc" #-}
(AI_PASSIVE, 1),
{-# LINE 112 "Z/IO/Network/DNS.hsc" #-}
{-# LINE 113 "Z/IO/Network/DNS.hsc" #-}
(AI_V4MAPPED, 8)
{-# LINE 114 "Z/IO/Network/DNS.hsc" #-}
{-# LINE 117 "Z/IO/Network/DNS.hsc" #-}
]
addrInfoFlagImplemented :: AddrInfoFlag -> Bool
{-# INLINABLE addrInfoFlagImplemented #-}
addrInfoFlagImplemented f = packBits addrInfoFlagMapping [f] /= 0
data AddrInfo = AddrInfo {
addrFlags :: [AddrInfoFlag]
, addrFamily :: SocketFamily
, addrSocketType :: SocketType
, addrProtocol :: ProtocolNumber
, addrAddress :: SocketAddr
, addrCanonName :: CBytes
} deriving (Eq, Ord, Show, Generic)
deriving anyclass (Print, JSON)
instance Storable AddrInfo where
{-# INLINABLE sizeOf #-}
sizeOf _ = 48
{-# LINE 139 "Z/IO/Network/DNS.hsc" #-}
{-# INLINABLE alignment #-}
alignment _ = alignment (0 :: CInt)
{-# INLINABLE peek #-}
peek p = do
ai_flags <- ((\hsc_ptr -> peekByteOff hsc_ptr 0)) p
{-# LINE 145 "Z/IO/Network/DNS.hsc" #-}
ai_family <- ((\hsc_ptr -> peekByteOff hsc_ptr 4)) p
{-# LINE 146 "Z/IO/Network/DNS.hsc" #-}
ai_socktype <- ((\hsc_ptr -> peekByteOff hsc_ptr 8)) p
{-# LINE 147 "Z/IO/Network/DNS.hsc" #-}
ai_protocol <- ((\hsc_ptr -> peekByteOff hsc_ptr 12)) p
{-# LINE 148 "Z/IO/Network/DNS.hsc" #-}
ai_addr <- ((\hsc_ptr -> peekByteOff hsc_ptr 24)) p >>= peekSocketAddr
{-# LINE 149 "Z/IO/Network/DNS.hsc" #-}
ai_canonname_ptr <- ((\hsc_ptr -> peekByteOff hsc_ptr 32)) p
{-# LINE 150 "Z/IO/Network/DNS.hsc" #-}
ai_canonname <- fromCString ai_canonname_ptr
return $ AddrInfo {
addrFlags = unpackBits addrInfoFlagMapping ai_flags
, addrFamily = ai_family
, addrSocketType = ai_socktype
, addrProtocol = ai_protocol
, addrAddress = ai_addr
, addrCanonName = ai_canonname
}
{-# INLINABLE poke #-}
poke p (AddrInfo flags family sockType protocol _ _) = do
((\hsc_ptr -> pokeByteOff hsc_ptr 0)) p (packBits addrInfoFlagMapping flags)
{-# LINE 164 "Z/IO/Network/DNS.hsc" #-}
((\hsc_ptr -> pokeByteOff hsc_ptr 4)) p family
{-# LINE 165 "Z/IO/Network/DNS.hsc" #-}
((\hsc_ptr -> pokeByteOff hsc_ptr 8)) p sockType
{-# LINE 166 "Z/IO/Network/DNS.hsc" #-}
((\hsc_ptr -> pokeByteOff hsc_ptr 12)) p protocol
{-# LINE 167 "Z/IO/Network/DNS.hsc" #-}
((\hsc_ptr -> pokeByteOff hsc_ptr 16)) p (0::CSize)
{-# LINE 169 "Z/IO/Network/DNS.hsc" #-}
((\hsc_ptr -> pokeByteOff hsc_ptr 24)) p nullPtr
{-# LINE 170 "Z/IO/Network/DNS.hsc" #-}
((\hsc_ptr -> pokeByteOff hsc_ptr 32)) p nullPtr
{-# LINE 171 "Z/IO/Network/DNS.hsc" #-}
((\hsc_ptr -> pokeByteOff hsc_ptr 40)) p nullPtr
{-# LINE 172 "Z/IO/Network/DNS.hsc" #-}
data NameInfoFlag =
NI_DGRAM
| NI_NAMEREQD
| NI_NOFQDN
| NI_NUMERICHOST
| NI_NUMERICSERV
deriving (Eq, Read, Show)
nameInfoFlagMapping :: [(NameInfoFlag, CInt)]
{-# INLINABLE nameInfoFlagMapping #-}
nameInfoFlagMapping = [(NI_DGRAM, 16),
{-# LINE 200 "Z/IO/Network/DNS.hsc" #-}
(NI_NAMEREQD, 8),
{-# LINE 201 "Z/IO/Network/DNS.hsc" #-}
(NI_NOFQDN, 4),
{-# LINE 202 "Z/IO/Network/DNS.hsc" #-}
(NI_NUMERICHOST, 1),
{-# LINE 203 "Z/IO/Network/DNS.hsc" #-}
(NI_NUMERICSERV, 2)]
{-# LINE 204 "Z/IO/Network/DNS.hsc" #-}
defaultHints :: AddrInfo
{-# INLINABLE defaultHints #-}
defaultHints = AddrInfo {
addrFlags = []
, addrFamily = AF_UNSPEC
, addrSocketType = SOCK_ANY
, addrProtocol = IPPROTO_DEFAULT
, addrAddress = SocketAddrIPv4 ipv4Any portAny
, addrCanonName = empty
}
getAddrInfo
:: Maybe AddrInfo
-> HostName
-> ServiceName
-> IO [AddrInfo]
{-# INLINABLE getAddrInfo #-}
getAddrInfo hints host service = withUVInitDo $
bracket
(do withCBytes host $ \ ptr_h ->
withCBytes service $ \ ptr_s ->
maybeWith with filteredHints $ \ ptr_hints ->
fst <$> allocPrimSafe (\ ptr_ptr_addrs -> do
throwUVIfMinus_ $ hs_getaddrinfo ptr_h ptr_s ptr_hints ptr_ptr_addrs))
freeaddrinfo
followAddrInfo
where
{-# LINE 290 "Z/IO/Network/DNS.hsc" #-}
filteredHints = hints
{-# LINE 292 "Z/IO/Network/DNS.hsc" #-}
followAddrInfo :: Ptr AddrInfo -> IO [AddrInfo]
{-# INLINABLE followAddrInfo #-}
followAddrInfo ptr_ai
| ptr_ai == nullPtr = return []
| otherwise = do
!a <- peek ptr_ai
as <- ((\hsc_ptr -> peekByteOff hsc_ptr 40)) ptr_ai >>= followAddrInfo
{-# LINE 302 "Z/IO/Network/DNS.hsc" #-}
return (a : as)
getNameInfo
:: [NameInfoFlag]
-> Bool
-> Bool
-> SocketAddr
-> IO (HostName, ServiceName)
{-# INLINABLE getNameInfo #-}
getNameInfo flags doHost doService addr = withUVInitDo $ do
(host, (service, _)) <- allocCBytes (fromIntegral h_len) $ \ ptr_h ->
allocCBytes (fromIntegral s_len) $ \ ptr_s ->
withSocketAddr addr $ \ ptr_addr ->
throwUVIfMinus_ $ hs_getnameinfo ptr_addr addr_len ptr_h h_len ptr_s s_len cflag
return (host, service)
where
addr_len = sizeOfSocketAddr addr
h_len = if doHost then (1025) else 0
{-# LINE 339 "Z/IO/Network/DNS.hsc" #-}
s_len = if doService then (32) else 0
{-# LINE 340 "Z/IO/Network/DNS.hsc" #-}
cflag = packBits nameInfoFlagMapping flags
packBits :: (Eq a, Num b, Bits b) => [(a, b)] -> [a] -> b
{-# INLINABLE packBits #-}
packBits mapping xs = List.foldl' go 0 mapping
where
go acc (k, v) | k `elem` xs = acc .|. v
| otherwise = acc
unpackBits :: (Num b, Bits b) => [(a, b)] -> b -> [a]
{-# INLINABLE unpackBits #-}
unpackBits [] _ = []
unpackBits ((k,v):xs) r
| r .&. v /= 0 = k : unpackBits xs (r .&. complement v)
| otherwise = unpackBits xs r
foreign import ccall safe "hs_getaddrinfo"
hs_getaddrinfo :: Ptr Word8
-> Ptr Word8
-> Ptr AddrInfo
-> Ptr (Ptr AddrInfo)
-> IO Int
foreign import ccall unsafe "freeaddrinfo" freeaddrinfo :: Ptr AddrInfo -> IO ()
foreign import ccall safe "hs_getnameinfo"
hs_getnameinfo :: Ptr SocketAddr
-> CSize
-> CString
-> CSize
-> CString
-> CSize
-> CInt
-> IO Int