{-# LANGUAGE CApiFFI            #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE OverloadedStrings  #-}
{-# LANGUAGE RecordWildCards    #-}
{-# LANGUAGE Trustworthy        #-}

-- |
-- Copyright: © 2017 Herbert Valerio Riedel
-- SPDX-License-Identifier: GPL-2.0-or-later
--
-- This module implements an API for accessing
-- the [Domain Name Service (DNS)](https://tools.ietf.org/html/rfc1035)
-- resolver service via the standard @libresolv@ system library
-- on Unix systems.
--
module Network.DNS
    ( -- ** High level API
      queryA
    , queryAAAA
    , queryCNAME
    , queryPTR
    , querySRV
    , queryTXT

      -- * Mid-level API
    , query
    , DnsException(..)

      -- * Low-level API
    , resIsReentrant
    , queryRaw
    , sendRaw
    , mkQueryRaw

    , decodeMessage
    , encodeMessage
    , mkQueryMsg

      -- * Types
      -- ** Basic types

      -- *** Names/Labels
    , Label
    , Labels(..)
    , IsLabels(..)

    , Name(..)
    , caseFoldName

      -- *** Character strings
    , CharStr(..)

      -- *** IP addresses
    , IPv4(..), arpaIPv4
    , IPv6(..), arpaIPv6

      -- *** RR TTL & Class
    , TTL(..)

    , Class(..)
    , classIN

      -- *** Message types
    , Type(..)
    , TypeSym(..)
    , typeFromSym
    , typeToSym

      -- ** Messages

    , Msg(..)

    , MsgHeader(..)
    , MsgHeaderFlags(..), QR(..)
    , MsgQuestion(..)
    , MsgRR(..)

    , RData(..)
    , rdType

    , SRV(..)
    )
    where

import           Control.Exception
import           Data.Bits             (unsafeShiftR, (.&.))
import           Data.Typeable         (Typeable)
import           Foreign.C
import           Foreign.Marshal.Alloc
import           Numeric               (showInt)
import           Prelude

import qualified Data.ByteString       as BS
import qualified Data.ByteString.Char8 as BSC

import           Compat

import           Network.DNS.FFI
import           Network.DNS.Message

-- | Exception thrown in case of errors while encoding or decoding into a 'Msg'.
--
-- @since 0.1.1.0
data DnsException = DnsEncodeException
                  | DnsDecodeException
                  deriving (Int -> DnsException -> ShowS
[DnsException] -> ShowS
DnsException -> String
(Int -> DnsException -> ShowS)
-> (DnsException -> String)
-> ([DnsException] -> ShowS)
-> Show DnsException
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [DnsException] -> ShowS
$cshowList :: [DnsException] -> ShowS
show :: DnsException -> String
$cshow :: DnsException -> String
showsPrec :: Int -> DnsException -> ShowS
$cshowsPrec :: Int -> DnsException -> ShowS
Show, Typeable)

instance Exception DnsException

-- | Send a query via @res_query(3)@ and decode its response into a 'Msg'
--
-- Throws 'DnsException' in case of encoding or decoding errors. May throw other IO exceptions in case of network errors.
--
-- === Example
--
-- >>> query classIN (Name "_mirrors.hackage.haskell.org") TypeTXT
-- Just (Msg{msgHeader = MsgHeader{mhId    = 56694,
--                                 mhFlags = MsgHeaderFlags{mhQR = IsResponse, mhOpcode = 0, mhAA = False,
--                                                          mhTC = False, mhRD = True, mhRA = True, mhZ = False,
--                                                          mhAD = False, mhCD = False, mhRCode = 0},
--                                 mhQDCount = 1, mhANCount = 1, mhNSCount = 0, mhARCount = 1},
--           msgQD = [MsgQuestion (Name "_mirrors.hackage.haskell.org.") (Type 16) (Class 1)],
--           msgAN = [MsgRR{rrName  = Name "_mirrors.hackage.haskell.org.",
--                          rrClass = Class 1, rrTTL = TTL 299,
--                          rrData  = RDataTXT ["0.urlbase=http://hackage.fpcomplete.com/",
--                                              "1.urlbase=http://objects-us-west-1.dream.io/hackage-mirror/"]}],
--           msgNS = [],
--           msgAR = [MsgRR{rrName = Name ".", rrClass = Class 512, rrTTL = TTL 32768, rrData = RDataOPT ""}]
--       })
--
query :: IsLabels n => Class -> n -> TypeSym -> IO (Msg n)
query :: Class -> n -> TypeSym -> IO (Msg n)
query Class
cls n
name0 TypeSym
qtype
  | Just Name
name <- n -> Maybe Name
forall n. IsLabels n => n -> Maybe Name
toName n
name0 = do
      ByteString
bs <- Class -> Name -> Type -> IO ByteString
queryRaw Class
cls Name
name (TypeSym -> Type
typeFromSym TypeSym
qtype)
      Maybe (Msg n)
msg <- Maybe (Msg n) -> IO (Maybe (Msg n))
forall a. a -> IO a
evaluate (ByteString -> Maybe (Msg n)
forall n. IsLabels n => ByteString -> Maybe (Msg n)
decodeMessage ByteString
bs)
      IO (Msg n) -> (Msg n -> IO (Msg n)) -> Maybe (Msg n) -> IO (Msg n)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (DnsException -> IO (Msg n)
forall e a. Exception e => e -> IO a
throwIO DnsException
DnsDecodeException) Msg n -> IO (Msg n)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Msg n)
msg
  | Bool
otherwise = DnsException -> IO (Msg n)
forall e a. Exception e => e -> IO a
throwIO DnsException
DnsEncodeException

-- | Send a query via @res_query(3)@, the return value is the raw binary response message.
--
-- You can use 'decodeMessage' to decode the response message.
queryRaw :: Class -> Name -> Type -> IO BS.ByteString
queryRaw :: Class -> Name -> Type -> IO ByteString
queryRaw (Class Word16
cls) (Name ByteString
name) Type
qtype = (Ptr CResState -> IO ByteString) -> IO ByteString
forall a. (Ptr CResState -> IO a) -> IO a
withCResState ((Ptr CResState -> IO ByteString) -> IO ByteString)
-> (Ptr CResState -> IO ByteString) -> IO ByteString
forall a b. (a -> b) -> a -> b
$ \Ptr CResState
stptr -> do
    Int -> (Ptr CChar -> IO ByteString) -> IO ByteString
forall a b. Int -> (Ptr a -> IO b) -> IO b
allocaBytes Int
forall a. Num a => a
max_msg_size ((Ptr CChar -> IO ByteString) -> IO ByteString)
-> (Ptr CChar -> IO ByteString) -> IO ByteString
forall a b. (a -> b) -> a -> b
$ \Ptr CChar
resptr -> do
        Ptr CChar
_ <- Ptr CChar -> CInt -> CSize -> IO (Ptr CChar)
forall a. Ptr a -> CInt -> CSize -> IO (Ptr a)
c_memset Ptr CChar
resptr CInt
0 CSize
forall a. Num a => a
max_msg_size
        ByteString -> (Ptr CChar -> IO ByteString) -> IO ByteString
forall a. ByteString -> (Ptr CChar -> IO a) -> IO a
BS.useAsCString ByteString
name ((Ptr CChar -> IO ByteString) -> IO ByteString)
-> (Ptr CChar -> IO ByteString) -> IO ByteString
forall a b. (a -> b) -> a -> b
$ \Ptr CChar
dn -> do

            CInt
rc1 <- Ptr CResState -> IO CInt
c_res_opt_set_use_dnssec Ptr CResState
stptr
            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (CInt
rc1 CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
== CInt
0) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
                String -> IO ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"res_init(3) failed"

            IO ()
resetErrno
            CInt
reslen <- Ptr CResState
-> Ptr CChar -> CInt -> CInt -> Ptr CChar -> CInt -> IO CInt
c_res_query Ptr CResState
stptr Ptr CChar
dn (Word16 -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
cls) CInt
qtypeVal Ptr CChar
resptr CInt
forall a. Num a => a
max_msg_size

            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (CInt
reslen CInt -> CInt -> Bool
forall a. Ord a => a -> a -> Bool
<= CInt
forall a. Num a => a
max_msg_size) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
                String -> IO ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"res_query(3) message size overflow"

            Errno
errno <- IO Errno
getErrno

            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (CInt
reslen CInt -> CInt -> Bool
forall a. Ord a => a -> a -> Bool
< CInt
0) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
                Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Errno
errno Errno -> Errno -> Bool
forall a. Eq a => a -> a -> Bool
== Errno
eOK) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
                    String -> IO ()
forall a. String -> IO a
throwErrno String
"res_query"

                String -> IO ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"res_query(3) failed"

            CStringLen -> IO ByteString
BS.packCStringLen (Ptr CChar
resptr, CInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral CInt
reslen)

  where
    -- The DNS protocol is inherently 16-bit-offset based; so 64KiB is
    -- a reasonable maximum message size most implementations seem to
    -- support.
    max_msg_size :: Num a => a
    max_msg_size :: a
max_msg_size = a
0x10000

    qtypeVal :: CInt
    qtypeVal :: CInt
qtypeVal = case Type
qtype of Type Word16
w -> Word16 -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
w

-- | Send a raw preformatted query via @res_send(3)@.
sendRaw :: BS.ByteString -> IO BS.ByteString
sendRaw :: ByteString -> IO ByteString
sendRaw ByteString
req = (Ptr CResState -> IO ByteString) -> IO ByteString
forall a. (Ptr CResState -> IO a) -> IO a
withCResState ((Ptr CResState -> IO ByteString) -> IO ByteString)
-> (Ptr CResState -> IO ByteString) -> IO ByteString
forall a b. (a -> b) -> a -> b
$ \Ptr CResState
stptr -> do
    Int -> (Ptr CChar -> IO ByteString) -> IO ByteString
forall a b. Int -> (Ptr a -> IO b) -> IO b
allocaBytes Int
forall a. Num a => a
max_msg_size ((Ptr CChar -> IO ByteString) -> IO ByteString)
-> (Ptr CChar -> IO ByteString) -> IO ByteString
forall a b. (a -> b) -> a -> b
$ \Ptr CChar
resptr -> do
        Ptr CChar
_ <- Ptr CChar -> CInt -> CSize -> IO (Ptr CChar)
forall a. Ptr a -> CInt -> CSize -> IO (Ptr a)
c_memset Ptr CChar
resptr CInt
0 CSize
forall a. Num a => a
max_msg_size
        ByteString -> (CStringLen -> IO ByteString) -> IO ByteString
forall a. ByteString -> (CStringLen -> IO a) -> IO a
BS.useAsCStringLen ByteString
req ((CStringLen -> IO ByteString) -> IO ByteString)
-> (CStringLen -> IO ByteString) -> IO ByteString
forall a b. (a -> b) -> a -> b
$ \(Ptr CChar
reqptr,Int
reqlen) -> do
            CInt
rc1 <- Ptr CResState -> IO CInt
c_res_opt_set_use_dnssec Ptr CResState
stptr
            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (CInt
rc1 CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
== CInt
0) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
                String -> IO ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"res_init(3) failed"

            IO ()
resetErrno
            CInt
reslen <- Ptr CResState -> Ptr CChar -> CInt -> Ptr CChar -> CInt -> IO CInt
c_res_send Ptr CResState
stptr Ptr CChar
reqptr (Int -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
reqlen) Ptr CChar
resptr CInt
forall a. Num a => a
max_msg_size

            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (CInt
reslen CInt -> CInt -> Bool
forall a. Ord a => a -> a -> Bool
<= CInt
forall a. Num a => a
max_msg_size) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
                String -> IO ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"res_send(3) message size overflow"

            Errno
errno <- IO Errno
getErrno

            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (CInt
reslen CInt -> CInt -> Bool
forall a. Ord a => a -> a -> Bool
< CInt
0) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
                Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Errno
errno Errno -> Errno -> Bool
forall a. Eq a => a -> a -> Bool
== Errno
eOK) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
                    String -> IO ()
forall a. String -> IO a
throwErrno String
"res_send"

                String -> IO ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"res_send(3) failed"

            CStringLen -> IO ByteString
BS.packCStringLen (Ptr CChar
resptr, CInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral CInt
reslen)

  where
    -- The DNS protocol is inherently 16-bit-offset based; so 64KiB is
    -- a reasonable maximum message size most implementations seem to
    -- support.
    max_msg_size :: Num a => a
    max_msg_size :: a
max_msg_size = a
0x10000

-- | Construct a DNS query 'Msg' in the style of 'mkQueryRaw'
mkQueryMsg :: IsLabels n => Class -> n -> Type -> Msg n
mkQueryMsg :: Class -> n -> Type -> Msg n
mkQueryMsg Class
cls n
l Type
qtype = MsgHeader
-> [MsgQuestion n] -> [MsgRR n] -> [MsgRR n] -> [MsgRR n] -> Msg n
forall l.
MsgHeader
-> [MsgQuestion l] -> [MsgRR l] -> [MsgRR l] -> [MsgRR l] -> Msg l
Msg (MsgHeader :: Word16
-> MsgHeaderFlags
-> Word16
-> Word16
-> Word16
-> Word16
-> MsgHeader
MsgHeader{Word16
MsgHeaderFlags
mhARCount :: Word16
mhNSCount :: Word16
mhANCount :: Word16
mhQDCount :: Word16
mhFlags :: MsgHeaderFlags
mhId :: Word16
mhARCount :: Word16
mhNSCount :: Word16
mhANCount :: Word16
mhQDCount :: Word16
mhFlags :: MsgHeaderFlags
mhId :: Word16
..})
                             [n -> Type -> Class -> MsgQuestion n
forall l. l -> Type -> Class -> MsgQuestion l
MsgQuestion n
l Type
qtype Class
cls]
                             []
                             []
                             [MsgRR :: forall l. l -> Class -> TTL -> RData l -> MsgRR l
MsgRR {n
TTL
Class
RData n
forall l. RData l
rrData :: RData n
rrTTL :: TTL
rrClass :: Class
rrName :: n
rrData :: forall l. RData l
rrTTL :: TTL
rrClass :: Class
rrName :: n
..}]
  where
    mhId :: Word16
mhId      = Word16
31337
    mhFlags :: MsgHeaderFlags
mhFlags   = MsgHeaderFlags :: QR
-> Word8
-> Bool
-> Bool
-> Bool
-> Bool
-> Bool
-> Bool
-> Bool
-> Word8
-> MsgHeaderFlags
MsgHeaderFlags
      { mhQR :: QR
mhQR     = QR
IsQuery
      , mhOpcode :: Word8
mhOpcode = Word8
0
      , mhAA :: Bool
mhAA     = Bool
False
      , mhTC :: Bool
mhTC     = Bool
False
      , mhRD :: Bool
mhRD     = Bool
True
      , mhRA :: Bool
mhRA     = Bool
False
      , mhZ :: Bool
mhZ      = Bool
False
      , mhAD :: Bool
mhAD     = Bool
True
      , mhCD :: Bool
mhCD     = Bool
False
      , mhRCode :: Word8
mhRCode  = Word8
0
      }

    mhQDCount :: Word16
mhQDCount = Word16
1
    mhANCount :: Word16
mhANCount = Word16
0
    mhNSCount :: Word16
mhNSCount = Word16
0
    mhARCount :: Word16
mhARCount = Word16
1

    rrName :: n
rrName  = Labels -> n
forall s. IsLabels s => Labels -> s
fromLabels Labels
Root
    rrClass :: Class
rrClass = Word16 -> Class
Class Word16
512
    rrTTL :: TTL
rrTTL   = Int32 -> TTL
TTL Int32
0x8000
    rrData :: RData l
rrData  = ByteString -> RData l
forall l. ByteString -> RData l
RDataOPT ByteString
""



-- | Use @res_mkquery(3)@ to construct a DNS query message.
mkQueryRaw :: Class -> Name -> Type -> IO BS.ByteString
mkQueryRaw :: Class -> Name -> Type -> IO ByteString
mkQueryRaw (Class Word16
cls) (Name ByteString
name) Type
qtype = (Ptr CResState -> IO ByteString) -> IO ByteString
forall a. (Ptr CResState -> IO a) -> IO a
withCResState ((Ptr CResState -> IO ByteString) -> IO ByteString)
-> (Ptr CResState -> IO ByteString) -> IO ByteString
forall a b. (a -> b) -> a -> b
$ \Ptr CResState
stptr -> do
    Int -> (Ptr CChar -> IO ByteString) -> IO ByteString
forall a b. Int -> (Ptr a -> IO b) -> IO b
allocaBytes Int
forall a. Num a => a
max_msg_size ((Ptr CChar -> IO ByteString) -> IO ByteString)
-> (Ptr CChar -> IO ByteString) -> IO ByteString
forall a b. (a -> b) -> a -> b
$ \Ptr CChar
resptr -> do
        Ptr CChar
_ <- Ptr CChar -> CInt -> CSize -> IO (Ptr CChar)
forall a. Ptr a -> CInt -> CSize -> IO (Ptr a)
c_memset Ptr CChar
resptr CInt
0 CSize
forall a. Num a => a
max_msg_size
        ByteString -> (Ptr CChar -> IO ByteString) -> IO ByteString
forall a. ByteString -> (Ptr CChar -> IO a) -> IO a
BS.useAsCString ByteString
name ((Ptr CChar -> IO ByteString) -> IO ByteString)
-> (Ptr CChar -> IO ByteString) -> IO ByteString
forall a b. (a -> b) -> a -> b
$ \Ptr CChar
dn -> do

            CInt
rc1 <- Ptr CResState -> IO CInt
c_res_opt_set_use_dnssec Ptr CResState
stptr
            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (CInt
rc1 CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
== CInt
0) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
                String -> IO ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"res_init(3) failed"

            IO ()
resetErrno
            CInt
reslen <- Ptr CResState
-> Ptr CChar -> CInt -> CInt -> Ptr CChar -> CInt -> IO CInt
c_res_mkquery Ptr CResState
stptr Ptr CChar
dn (Word16 -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
cls) CInt
qtypeVal Ptr CChar
resptr CInt
forall a. Num a => a
max_msg_size

            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (CInt
reslen CInt -> CInt -> Bool
forall a. Ord a => a -> a -> Bool
<= CInt
forall a. Num a => a
max_msg_size) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
                String -> IO ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"res_mkquery(3) message size overflow"

            Errno
errno <- IO Errno
getErrno

            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (CInt
reslen CInt -> CInt -> Bool
forall a. Ord a => a -> a -> Bool
< CInt
0) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
                Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Errno
errno Errno -> Errno -> Bool
forall a. Eq a => a -> a -> Bool
== Errno
eOK) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
                    String -> IO ()
forall a. String -> IO a
throwErrno String
"res_query"

                String -> IO ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"res_mkquery(3) failed"

            CStringLen -> IO ByteString
BS.packCStringLen (Ptr CChar
resptr, CInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral CInt
reslen)

  where
    -- The DNS protocol is inherently 16-bit-offset based; so 64KiB is
    -- a reasonable maximum message size most implementations seem to
    -- support.
    max_msg_size :: Num a => a
    max_msg_size :: a
max_msg_size = a
0x10000

    qtypeVal :: CInt
    qtypeVal :: CInt
qtypeVal = case Type
qtype of Type Word16
w -> Word16 -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
w


----------------------------------------------------------------------------
-- Common High-level queries

-- | Normalise 'Name'
--
-- This function case folds 'Name's as described in
-- in [RFC 4343, section 3](https://tools.ietf.org/html/rfc4343#section-3)
-- by subtracting @0x20@ from all octets in the inclusive range
-- @[0x61..0x7A]@ (i.e. mapping @['a'..'z']@ to @['A'..'Z']@).
--
-- This operation is idempotent.
caseFoldName :: Name -> Name
caseFoldName :: Name -> Name
caseFoldName (Name ByteString
n) = (ByteString -> Name
Name ByteString
n'')
  where
    n' :: ByteString
n' = (Word8 -> Word8) -> ByteString -> ByteString
BS.map Word8 -> Word8
forall p. (Ord p, Num p) => p -> p
cf ByteString
n
    n'' :: ByteString
n'' | ByteString -> Bool
BS.null ByteString
n' = ByteString
"."
        | ByteString -> Word8
BS.last ByteString
n' Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
0x2e {- '.' -} = ByteString
n'
        | Bool
otherwise  = ByteString
n' ByteString -> ByteString -> ByteString
forall a. Monoid a => a -> a -> a
`mappend` ByteString
"."

    -- case fold (c.f. RFC4343)
    cf :: p -> p
cf p
w | p
0x61 p -> p -> Bool
forall a. Ord a => a -> a -> Bool
<= p
w Bool -> Bool -> Bool
&& p
w p -> p -> Bool
forall a. Ord a => a -> a -> Bool
<= p
0x7a  = p
w p -> p -> p
forall a. Num a => a -> a -> a
- p
0x20
         | Bool
otherwise               = p
w

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

-- | Query @A@ record (see [RFC 1035, section 3.4.1](https://tools.ietf.org/html/rfc1035#section-3.4.1)).
--
-- This query returns only exact matches (modulo 'foldCaseName').
-- E.g. in case of @CNAME@ responses even if the
-- answer section would contain @A@ records for the hostnames pointed
-- to by the @CNAME@. You can use 'query' if you need more control.
--
-- >>> queryA (Name "www.google.com")
-- [(TTL 72,IPv4 0xd83acde4)]
--
queryA :: Name -> IO [(TTL,IPv4)]
queryA :: Name -> IO [(TTL, IPv4)]
queryA Name
n = do
    Msg Name
res <- Class -> Name -> TypeSym -> IO (Msg Name)
forall n. IsLabels n => Class -> n -> TypeSym -> IO (Msg n)
query Class
classIN Name
n' TypeSym
TypeA
    [(TTL, IPv4)] -> IO [(TTL, IPv4)]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [ (TTL
ttl,IPv4
ip4) | MsgRR { rrData :: forall l. MsgRR l -> RData l
rrData = RDataA IPv4
ip4, rrTTL :: forall l. MsgRR l -> TTL
rrTTL = TTL
ttl, rrName :: forall l. MsgRR l -> l
rrName = Name
n1, rrClass :: forall l. MsgRR l -> Class
rrClass = Class Word16
1 } <- Msg Name -> [MsgRR Name]
forall l. Msg l -> [MsgRR l]
msgAN Msg Name
res, Name -> Name
caseFoldName Name
n1 Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
n' ]
  where
    n' :: Name
n' = Name -> Name
caseFoldName Name
n

-- | Query @AAAA@ records (see [RFC 3596](https://tools.ietf.org/html/rfc3596)).
--
-- This query returns only exact matches (modulo 'foldCaseName').
-- E.g. in case of @CNAME@ responses even if the answer section would
-- contain @A@ records for the hostnames pointed to by the
-- @CNAME@. You can use 'query' if you need more control.
--
-- >>> queryAAAA (Name "www.google.com")
-- [(TTL 299,IPv6 0x2a0014504001081e 0x2004)]
--
queryAAAA :: Name -> IO [(TTL,IPv6)]
queryAAAA :: Name -> IO [(TTL, IPv6)]
queryAAAA Name
n = do
    Msg Name
res <- Class -> Name -> TypeSym -> IO (Msg Name)
forall n. IsLabels n => Class -> n -> TypeSym -> IO (Msg n)
query Class
classIN Name
n' TypeSym
TypeAAAA
    [(TTL, IPv6)] -> IO [(TTL, IPv6)]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [ (TTL
ttl,IPv6
ip6) | MsgRR { rrData :: forall l. MsgRR l -> RData l
rrData = RDataAAAA IPv6
ip6, rrTTL :: forall l. MsgRR l -> TTL
rrTTL = TTL
ttl, rrName :: forall l. MsgRR l -> l
rrName = Name
n1, rrClass :: forall l. MsgRR l -> Class
rrClass = Class Word16
1 } <- Msg Name -> [MsgRR Name]
forall l. Msg l -> [MsgRR l]
msgAN Msg Name
res, Name -> Name
caseFoldName Name
n1 Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
n' ]
  where
    n' :: Name
n' = Name -> Name
caseFoldName Name
n

-- | Query @CNAME@ records (see [RFC 1035, section 3.3.1](https://tools.ietf.org/html/rfc1035#section-3.3.1)).
--
-- >>> queryCNAME (Name "hackage.haskell.org")
-- [(TTL 299,Name "j.global-ssl.fastly.net.")]
--
queryCNAME :: Name -> IO [(TTL,Name)]
queryCNAME :: Name -> IO [(TTL, Name)]
queryCNAME Name
n = do
    Msg Name
res <- Class -> Name -> TypeSym -> IO (Msg Name)
forall n. IsLabels n => Class -> n -> TypeSym -> IO (Msg n)
query Class
classIN Name
n' TypeSym
TypeAAAA
    [(TTL, Name)] -> IO [(TTL, Name)]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [ (TTL
ttl,Name
cname) | MsgRR { rrData :: forall l. MsgRR l -> RData l
rrData = RDataCNAME Name
cname, rrTTL :: forall l. MsgRR l -> TTL
rrTTL = TTL
ttl, rrName :: forall l. MsgRR l -> l
rrName = Name
n1, rrClass :: forall l. MsgRR l -> Class
rrClass = Class Word16
1 } <- Msg Name -> [MsgRR Name]
forall l. Msg l -> [MsgRR l]
msgAN Msg Name
res, Name -> Name
caseFoldName Name
n1 Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
n' ]
  where
    n' :: Name
n' = Name -> Name
caseFoldName Name
n

-- | Query @PTR@ records (see [RFC 1035, section 3.3.12](https://tools.ietf.org/html/rfc1035#section-3.3.12)).
--
-- >>> queryPTR (Name "4.4.8.8.in-addr.arpa.")
-- [(TTL 14390,Name "dns.google.")]
--
-- See also 'arpaIPv6' and 'arpaIPv4' for converting 'IPv6' and 'IPv4' values to the respective @.arpa."@ domain name for reverse lookups.
--
-- @since 0.1.2.0
queryPTR :: Name -> IO [(TTL,Name)]
queryPTR :: Name -> IO [(TTL, Name)]
queryPTR Name
n = do
    Msg Name
res <- Class -> Name -> TypeSym -> IO (Msg Name)
forall n. IsLabels n => Class -> n -> TypeSym -> IO (Msg n)
query Class
classIN Name
n' TypeSym
TypePTR
    [(TTL, Name)] -> IO [(TTL, Name)]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [ (TTL
ttl,Name
ptrs) | MsgRR { rrData :: forall l. MsgRR l -> RData l
rrData = RDataPTR Name
ptrs, rrTTL :: forall l. MsgRR l -> TTL
rrTTL = TTL
ttl, rrName :: forall l. MsgRR l -> l
rrName = Name
n1, rrClass :: forall l. MsgRR l -> Class
rrClass = Class Word16
1 } <- Msg Name -> [MsgRR Name]
forall l. Msg l -> [MsgRR l]
msgAN Msg Name
res, Name -> Name
caseFoldName Name
n1 Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
n' ]
  where
    n' :: Name
n' = Name -> Name
caseFoldName Name
n

-- | Query @TXT@ records (see [RFC 1035, section 3.3.14](https://tools.ietf.org/html/rfc1035#section-3.3.14)).
--
-- >>> queryTXT (Name "_mirrors.hackage.haskell.org")
-- [(TTL 299,["0.urlbase=http://hackage.fpcomplete.com/",
--            "1.urlbase=http://objects-us-west-1.dream.io/hackage-mirror/"])]
--
queryTXT :: Name -> IO [(TTL,[CharStr])]
queryTXT :: Name -> IO [(TTL, [CharStr])]
queryTXT Name
n = do
    Msg Name
res <- Class -> Name -> TypeSym -> IO (Msg Name)
forall n. IsLabels n => Class -> n -> TypeSym -> IO (Msg n)
query Class
classIN Name
n' TypeSym
TypeTXT
    [(TTL, [CharStr])] -> IO [(TTL, [CharStr])]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [ (TTL
ttl,[CharStr]
txts) | MsgRR { rrData :: forall l. MsgRR l -> RData l
rrData = RDataTXT [CharStr]
txts, rrTTL :: forall l. MsgRR l -> TTL
rrTTL = TTL
ttl, rrName :: forall l. MsgRR l -> l
rrName = Name
n1, rrClass :: forall l. MsgRR l -> Class
rrClass = Class Word16
1 } <- Msg Name -> [MsgRR Name]
forall l. Msg l -> [MsgRR l]
msgAN Msg Name
res, Name -> Name
caseFoldName Name
n1 Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
n' ]
  where
    n' :: Name
n' = Name -> Name
caseFoldName Name
n

-- | Query @SRV@ records (see [RFC 2782](https://tools.ietf.org/html/rfc2782)).
--
-- >>> querySRV (Name "_imap._tcp.gmail.com")
-- [(TTL 21599,SRV {srvPriority = 0, srvWeight = 0, srvPort = 0, srvTarget = Name "."})]
--
querySRV :: Name -> IO [(TTL,SRV Name)]
querySRV :: Name -> IO [(TTL, SRV Name)]
querySRV Name
n = do
    Msg Name
res <- Class -> Name -> TypeSym -> IO (Msg Name)
forall n. IsLabels n => Class -> n -> TypeSym -> IO (Msg n)
query Class
classIN Name
n' TypeSym
TypeSRV
    [(TTL, SRV Name)] -> IO [(TTL, SRV Name)]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [ (TTL
ttl,SRV Name
srv) | MsgRR { rrData :: forall l. MsgRR l -> RData l
rrData = RDataSRV SRV Name
srv, rrTTL :: forall l. MsgRR l -> TTL
rrTTL = TTL
ttl, rrName :: forall l. MsgRR l -> l
rrName = Name
n1, rrClass :: forall l. MsgRR l -> Class
rrClass = Class Word16
1 } <- Msg Name -> [MsgRR Name]
forall l. Msg l -> [MsgRR l]
msgAN Msg Name
res, Name -> Name
caseFoldName Name
n1 Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
n' ]
  where
    n' :: Name
n' = Name -> Name
caseFoldName Name
n


-- | Convert 'IPv4' address to @in-addr.arpa.@ 'Name' (see [RFC 1035, section 3.5](https://tools.ietf.org/html/rfc1035#section-3.5)).
--
-- >>> arpaIPv4 (IPv4 0x8080404)
-- Name "4.4.8.8.in-addr.arpa."
--
-- @since 0.1.2.0
arpaIPv4 :: IPv4 -> Name
arpaIPv4 :: IPv4 -> Name
arpaIPv4 (IPv4 Word32
w) = ByteString -> Name
Name (String -> ByteString
BSC.pack String
s)
  where
    s :: String
s = Word8 -> ShowS
forall a. Integral a => a -> ShowS
showInt Word8
o0 (Char
'.' Char -> ShowS
forall a. a -> [a] -> [a]
: Word8 -> ShowS
forall a. Integral a => a -> ShowS
showInt Word8
o1 (Char
'.' Char -> ShowS
forall a. a -> [a] -> [a]
: Word8 -> ShowS
forall a. Integral a => a -> ShowS
showInt Word8
o2 (Char
'.' Char -> ShowS
forall a. a -> [a] -> [a]
: Word8 -> ShowS
forall a. Integral a => a -> ShowS
showInt Word8
o3 String
".in-addr.arpa.")))

    o0, o1, o2, o3 :: Word8
    o0 :: Word8
o0 = Word32 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> Word8) -> Word32 -> Word8
forall a b. (a -> b) -> a -> b
$ Word32
w
    o1 :: Word8
o1 = Word32 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> Word8) -> Word32 -> Word8
forall a b. (a -> b) -> a -> b
$ Word32
w Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
`unsafeShiftR` Int
8
    o2 :: Word8
o2 = Word32 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> Word8) -> Word32 -> Word8
forall a b. (a -> b) -> a -> b
$ Word32
w Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
`unsafeShiftR` Int
16
    o3 :: Word8
o3 = Word32 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> Word8) -> Word32 -> Word8
forall a b. (a -> b) -> a -> b
$ Word32
w Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
`unsafeShiftR` Int
24

-- | Convert 'IPv6' address to @ip6.arpa.@ 'Name' (see [RFC 3596, section 2.5](https://tools.ietf.org/html/rfc3596#section-2.5)).
--
-- >>> arpaIPv6 (IPv6 0x2001486048600000 0x8844)
-- Name "4.4.8.8.0.0.0.0.0.0.0.0.0.0.0.0.0.0.0.0.0.6.8.4.0.6.8.4.1.0.0.2.ip6.arpa."
--
-- @since 0.1.2.0
arpaIPv6 :: IPv6 -> Name
arpaIPv6 :: IPv6 -> Name
arpaIPv6 (IPv6 Word64
hi Word64
lo) = ByteString -> Name
Name (String -> ByteString
BSC.pack String
s)
  where
    s :: String
s = Int -> Word64 -> ShowS
go Int
16 Word64
lo (Int -> Word64 -> ShowS
go Int
16 Word64
hi String
"ip6.arpa.")

    go :: Int -> Word64 -> ShowS
    go :: Int -> Word64 -> ShowS
go Int
0 Word64
_ String
cont = String
cont
    go Int
n Word64
w String
cont = Char
nib Char -> ShowS
forall a. a -> [a] -> [a]
: Char
'.' Char -> ShowS
forall a. a -> [a] -> [a]
: Int -> Word64 -> ShowS
go (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) Word64
w' String
cont
      where
        nib :: Char
        nib :: Char
nib | Word64
x Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
< Word64
10    = Int -> Char
forall a. Enum a => Int -> a
toEnum (Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64
0x30 Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Word64
x))
            | Bool
otherwise = Int -> Char
forall a. Enum a => Int -> a
toEnum (Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64
0x57 Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Word64
x))
        x :: Word64
x = Word64
w Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
.&. Word64
0xf
        w' :: Word64
w' = Word64
w Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
`unsafeShiftR` Int
4