{-# LINE 1 "Z/IO/Network/DNS.hsc" #-}
{-|
Module      : Z.IO.Network.DNS
Description : DNS and reverse DNS
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           GHC.Generics
import           Z.Data.CBytes              as CBytes
import           Z.Data.Text.ShowT          (ShowT(..))
import           Z.Data.JSON                (EncodeJSON, ToValue, FromValue)
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, Ord, Read, Show, Generic)
    deriving anyclass (ShowT, EncodeJSON, ToValue, FromValue)

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" #-}
    ]

-- | 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, Ord, Show, Generic)
    deriving anyclass (ShowT, EncodeJSON, ToValue, FromValue)


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

    peek p = do
        ai_flags <- ((\hsc_ptr -> peekByteOff hsc_ptr 0)) p
{-# LINE 141 "Z/IO/Network/DNS.hsc" #-}
        ai_family <- ((\hsc_ptr -> peekByteOff hsc_ptr 4)) p
{-# LINE 142 "Z/IO/Network/DNS.hsc" #-}
        ai_socktype <- ((\hsc_ptr -> peekByteOff hsc_ptr 8)) p
{-# LINE 143 "Z/IO/Network/DNS.hsc" #-}
        ai_protocol <- ((\hsc_ptr -> peekByteOff hsc_ptr 12)) p
{-# LINE 144 "Z/IO/Network/DNS.hsc" #-}
        ai_addr <- ((\hsc_ptr -> peekByteOff hsc_ptr 24)) p >>= peekSocketAddr
{-# LINE 145 "Z/IO/Network/DNS.hsc" #-}
        ai_canonname_ptr <- ((\hsc_ptr -> peekByteOff hsc_ptr 32)) p
{-# LINE 146 "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 159 "Z/IO/Network/DNS.hsc" #-}
        ((\hsc_ptr -> pokeByteOff hsc_ptr 4)) p family
{-# LINE 160 "Z/IO/Network/DNS.hsc" #-}
        ((\hsc_ptr -> pokeByteOff hsc_ptr 8)) p sockType
{-# LINE 161 "Z/IO/Network/DNS.hsc" #-}
        ((\hsc_ptr -> pokeByteOff hsc_ptr 12)) p protocol
{-# LINE 162 "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 164 "Z/IO/Network/DNS.hsc" #-}
        ((\hsc_ptr -> pokeByteOff hsc_ptr 24)) p nullPtr
{-# LINE 165 "Z/IO/Network/DNS.hsc" #-}
        ((\hsc_ptr -> pokeByteOff hsc_ptr 32)) p nullPtr
{-# LINE 166 "Z/IO/Network/DNS.hsc" #-}
        ((\hsc_ptr -> pokeByteOff hsc_ptr 40)) p nullPtr
{-# LINE 167 "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 195 "Z/IO/Network/DNS.hsc" #-}
                 (NI_NAMEREQD, 8),
{-# LINE 196 "Z/IO/Network/DNS.hsc" #-}
                 (NI_NOFQDN, 4),
{-# LINE 197 "Z/IO/Network/DNS.hsc" #-}
                 (NI_NUMERICHOST, 1),
{-# LINE 198 "Z/IO/Network/DNS.hsc" #-}
                 (NI_NUMERICSERV, 2)]
{-# LINE 199 "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    = SocketAddrIPv4 ipv4Any portAny
  , 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 283 "Z/IO/Network/DNS.hsc" #-}
    filteredHints = hints

{-# LINE 285 "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 294 "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 330 "Z/IO/Network/DNS.hsc" #-}
    s_len = if doService then (32) else 0
{-# LINE 331 "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