{-# LINE 1 "Z/IO/Network/DNS.hsc" #-}
{-|
Module      : Z.IO.Network.DNS
Description : TCP/UDP socket address API
Copyright   : (c) Winterland, 2018
License     : BSD
Maintainer  : drkoster@qq.com
Stability   : experimental
Portability : non-portable

This module provides 'getAddrInfo' and 'getNameInfo'. <https://www.man7.org/linux/man-pages/man3/getnameinfo.3.html getnameinfo> and <https://man7.org/linux/man-pages/man3/getaddrinfo.3.html getaddrinfo> equivalent.

-}
module Z.IO.Network.DNS (
  -- * name to ip
    getAddrInfo
  , HostName
  , ServiceName
  , AddrInfoFlag(..), addrInfoFlagImplemented, addrInfoFlagMapping
  , AddrInfo(..), defaultHints, followAddrInfo
  -- * ip to name
  , 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           Z.Data.CBytes  as CBytes
import           Z.Foreign
import           Z.IO.Exception
import           Z.IO.Network.SocketAddr
import           Z.IO.UV.Win



-----------------------------------------------------------------------------

-- | 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       = CBytes
-- | Either a service name e.g., @\"http\"@ or a numeric port number.
type ServiceName    = CBytes

-----------------------------------------------------------------------------
-- 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 'SocketAddr'
    --   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)

addrInfoFlagMapping :: [(AddrInfoFlag, CInt)]
addrInfoFlagMapping =
    [

{-# LINE 91 "Z/IO/Network/DNS.hsc" #-}
     (AI_ADDRCONFIG, 32),
{-# LINE 92 "Z/IO/Network/DNS.hsc" #-}

{-# LINE 95 "Z/IO/Network/DNS.hsc" #-}

{-# LINE 96 "Z/IO/Network/DNS.hsc" #-}
     (AI_ALL, 16),
{-# LINE 97 "Z/IO/Network/DNS.hsc" #-}

{-# LINE 100 "Z/IO/Network/DNS.hsc" #-}
     (AI_CANONNAME, 2),
{-# LINE 101 "Z/IO/Network/DNS.hsc" #-}
     (AI_NUMERICHOST, 4),
{-# LINE 102 "Z/IO/Network/DNS.hsc" #-}

{-# LINE 103 "Z/IO/Network/DNS.hsc" #-}
     (AI_NUMERICSERV, 1024),
{-# LINE 104 "Z/IO/Network/DNS.hsc" #-}

{-# LINE 107 "Z/IO/Network/DNS.hsc" #-}
     (AI_PASSIVE, 1),
{-# LINE 108 "Z/IO/Network/DNS.hsc" #-}

{-# LINE 109 "Z/IO/Network/DNS.hsc" #-}
     (AI_V4MAPPED, 8)
{-# LINE 110 "Z/IO/Network/DNS.hsc" #-}

{-# LINE 113 "Z/IO/Network/DNS.hsc" #-}
    ]

-- | Indicate whether the given 'AddrInfoFlag' will have any effect on this system.
addrInfoFlagImplemented :: AddrInfoFlag -> Bool
addrInfoFlagImplemented f = packBits addrInfoFlagMapping [f] /= 0

-- | Address info
data AddrInfo = AddrInfo {
    addrFlags :: [AddrInfoFlag]
  , addrFamily :: SocketFamily
  , addrSocketType :: SocketType
  , addrProtocol :: ProtocolNumber
  , addrAddress :: SocketAddr
  , addrCanonName :: CBytes
  } deriving (Eq, Show)


instance Storable AddrInfo where
    sizeOf    _ = 48
{-# LINE 132 "Z/IO/Network/DNS.hsc" #-}
    alignment _ = alignment (0 :: CInt)

    peek p = do
        ai_flags <- ((\hsc_ptr -> peekByteOff hsc_ptr 0)) p
{-# LINE 136 "Z/IO/Network/DNS.hsc" #-}
        ai_family <- ((\hsc_ptr -> peekByteOff hsc_ptr 4)) p
{-# LINE 137 "Z/IO/Network/DNS.hsc" #-}
        ai_socktype <- ((\hsc_ptr -> peekByteOff hsc_ptr 8)) p
{-# LINE 138 "Z/IO/Network/DNS.hsc" #-}
        ai_protocol <- ((\hsc_ptr -> peekByteOff hsc_ptr 12)) p
{-# LINE 139 "Z/IO/Network/DNS.hsc" #-}
        ai_addr <- ((\hsc_ptr -> peekByteOff hsc_ptr 24)) p >>= peekSocketAddr
{-# LINE 140 "Z/IO/Network/DNS.hsc" #-}
        ai_canonname_ptr <- ((\hsc_ptr -> peekByteOff hsc_ptr 32)) p
{-# LINE 141 "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
          }

    poke p (AddrInfo flags family sockType protocol _ _) = do
        ((\hsc_ptr -> pokeByteOff hsc_ptr 0)) p (packBits addrInfoFlagMapping flags)
{-# LINE 154 "Z/IO/Network/DNS.hsc" #-}
        ((\hsc_ptr -> pokeByteOff hsc_ptr 4)) p family
{-# LINE 155 "Z/IO/Network/DNS.hsc" #-}
        ((\hsc_ptr -> pokeByteOff hsc_ptr 8)) p sockType
{-# LINE 156 "Z/IO/Network/DNS.hsc" #-}
        ((\hsc_ptr -> pokeByteOff hsc_ptr 12)) p protocol
{-# LINE 157 "Z/IO/Network/DNS.hsc" #-}
        -- stuff below is probably not needed, but let's zero it for safety
        ((\hsc_ptr -> pokeByteOff hsc_ptr 16)) p (0::CSize)
{-# LINE 159 "Z/IO/Network/DNS.hsc" #-}
        ((\hsc_ptr -> pokeByteOff hsc_ptr 24)) p nullPtr
{-# LINE 160 "Z/IO/Network/DNS.hsc" #-}
        ((\hsc_ptr -> pokeByteOff hsc_ptr 32)) p nullPtr
{-# LINE 161 "Z/IO/Network/DNS.hsc" #-}
        ((\hsc_ptr -> pokeByteOff hsc_ptr 40)) p nullPtr
{-# LINE 162 "Z/IO/Network/DNS.hsc" #-}

-- | 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)

nameInfoFlagMapping :: [(NameInfoFlag, CInt)]

nameInfoFlagMapping = [(NI_DGRAM, 16),
{-# LINE 190 "Z/IO/Network/DNS.hsc" #-}
                 (NI_NAMEREQD, 8),
{-# LINE 191 "Z/IO/Network/DNS.hsc" #-}
                 (NI_NOFQDN, 4),
{-# LINE 192 "Z/IO/Network/DNS.hsc" #-}
                 (NI_NUMERICHOST, 1),
{-# LINE 193 "Z/IO/Network/DNS.hsc" #-}
                 (NI_NUMERICSERV, 2)]
{-# LINE 194 "Z/IO/Network/DNS.hsc" #-}

-- | 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 = SOCK_ANY
  , addrProtocol   = IPPROTO_DEFAULT
  , addrAddress    = SocketAddrInet portAny inetAny
  , addrCanonName  = empty
  }

-----------------------------------------------------------------------------
-- | Resolve a host or service name to one or more addresses.
-- The 'AddrInfo' values that this function returns contain 'SocketAddr'
-- values that you can use to init TCP connection.
--
-- 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 non empty 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.
--
-- If the query fails, this function throws an IO exception instead of
-- returning an empty list.  Otherwise, it returns a non-empty list
-- of 'AddrInfo' values.
--
-- 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.
--
-- >>> addr:_ <- getAddrInfo (Just hints) "127.0.0.1" "http"
-- >>> addrAddress addr
-- 127.0.0.1:80
--
getAddrInfo
    :: Maybe AddrInfo -- ^ preferred socket type or protocol
    -> HostName -- ^ host name to look up
    -> ServiceName -- ^ service name to look up
    -> IO [AddrInfo] -- ^ resolved addresses, with "best" first
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 278 "Z/IO/Network/DNS.hsc" #-}
    filteredHints = hints

{-# LINE 280 "Z/IO/Network/DNS.hsc" #-}

-- | Peek @addrinfo@ linked list.
--
followAddrInfo :: Ptr AddrInfo -> IO [AddrInfo]
followAddrInfo ptr_ai
    | ptr_ai == nullPtr = return []
    | otherwise = do
        !a  <- peek ptr_ai
        as <- ((\hsc_ptr -> peekByteOff hsc_ptr 40)) ptr_ai >>= followAddrInfo
{-# LINE 289 "Z/IO/Network/DNS.hsc" #-}
        return (a : as)

-----------------------------------------------------------------------------


-- | 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) "127.0.0.1" "http"
-- >>> getNameInfo [NI_NUMERICHOST, NI_NUMERICSERV] True True $ addrAddress addr
-- ("127.0.0.1", "80")
{-
-- >>> getNameInfo [] True True $ addrAddress addr
-- ("localhost", "http")
-}
getNameInfo
    :: [NameInfoFlag] -- ^ flags to control lookup behaviour
    -> Bool -- ^ whether to look up a hostname
    -> Bool -- ^ whether to look up a service name
    -> SocketAddr -- ^ the address to look up
    -> IO (HostName, ServiceName)
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 325 "Z/IO/Network/DNS.hsc" #-}
    s_len = if doService then (32) else 0
{-# LINE 326 "Z/IO/Network/DNS.hsc" #-}
    cflag = packBits nameInfoFlagMapping flags


-----------------------------------------------------------------------------
-- | 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
{-# INLINE packBits #-}
packBits mapping xs = List.foldl' go 0 mapping
  where
    go 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]
{-# INLINE unpackBits #-}
-- 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

-----------------------------------------------------------------------------
foreign import ccall safe "hs_getaddrinfo"
    hs_getaddrinfo :: Ptr Word8 -- ^ host 
                   -> Ptr Word8 -- ^ service
                   -> Ptr AddrInfo   -- ^ hints
                   -> Ptr (Ptr AddrInfo) -- ^ output addrinfo linked list
                   -> IO Int

foreign import ccall unsafe "freeaddrinfo" freeaddrinfo :: Ptr AddrInfo -> IO ()

foreign import ccall safe "hs_getnameinfo"
    hs_getnameinfo :: Ptr SocketAddr
                      -> CSize
                      -> CString -- ^ output host 
                      -> CSize
                      -> CString -- ^ output service
                      -> CSize
                      -> CInt    -- ^ flags
                      -> IO Int