{-# LINE 1 "src/Network/DNS/FFI.hsc" #-}
{-# LANGUAGE CApiFFI #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DeriveFoldable             #-}
{-# LANGUAGE DeriveFunctor              #-}
{-# LANGUAGE DeriveTraversable          #-}

-- |
-- Copyright: © 2017 Herbert Valerio Riedel
-- License: GPLv3
--
module Network.DNS.FFI where

import           Control.Applicative as App
import           Control.DeepSeq
import           Control.Exception
import           Control.Monad
import           Data.Bits
import           Data.ByteString (ByteString)
import qualified Data.ByteString as BS
import qualified Data.Foldable as F
import           Data.Int
import qualified Data.Traversable as T
import           Data.Word
import           Foreign.C.Types
import           Foreign.Marshal.Alloc
import           Foreign.Ptr
import           Foreign.Storable
import           Numeric (showHex)




type DWORD = Word32
{-# LINE 36 "src/Network/DNS/FFI.hsc" #-}
type WORD  = Word16
{-# LINE 37 "src/Network/DNS/FFI.hsc" #-}
type BOOL  = Int32
{-# LINE 38 "src/Network/DNS/FFI.hsc" #-}

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

-- | Cache time-to-live expressed in seconds
newtype TTL  = TTL Int32 deriving (Eq,Ord,Read,Show,NFData)

-- | @\<character-string\>@ as per [RFC 1035, section 3.3](https://tools.ietf.org/html/rfc1035#section-3.3).
--
-- A sequence of up to 255 octets
--
-- The limit of 255 octets is caused by the encoding which uses by a
-- prefixed octet denoting the length.
newtype CharStr = CharStr ByteString deriving (Eq,Ord,Read,Show)

instance NFData CharStr where rnf (CharStr !_) = ()

-- | @\<domain-name\>@ as per [RFC 1035, section 3.3](https://tools.ietf.org/html/rfc1035#section-3.3).
--
-- A domain-name represented as a series of labels separated by dots.
newtype Name    = Name ByteString deriving (Eq,Ord,Read,Show)

instance NFData Name where rnf (Name !_) = ()


-- | An IPv6 address
--
-- The IP address is represented in network order,
-- i.e. @2606:2800:220:1:248:1893:25c8:1946@ is
-- represented as @(IPv6 0x2606280002200001 0x248189325c81946)@.
data IPv6 = IPv6 !Word64 !Word64
          deriving (Eq,Ord,Read)

instance Show IPv6 where
    showsPrec p (IPv6 hi lo) = showParen (p >= 11) (showString "IPv6 0x" . showHex hi . showString " 0x" . showHex lo)

instance NFData IPv6 where
  rnf (IPv6 _ _) = ()

mkIPv6 :: Word32 -> Word32 -> Word32 -> Word32 -> IPv6
mkIPv6 a b c d = IPv6 (mkW64 a b) (mkW64 c d)
  where
    mkW64 x y = (fromIntegral (byteSwap32 x) `shiftL` 32) .|. fromIntegral (byteSwap32 y) :: Word64

-- | An IPv4 address
--
-- The IP address is represented in network order, i.e. @127.0.0.1@ is
-- represented as @(IPv4 0x7f000001)@.
data IPv4 = IPv4 !Word32
          deriving (Eq,Ord,Read)

instance NFData IPv4 where
  rnf (IPv4 _) = ()

mkIPv4 :: Word32 -> IPv4
mkIPv4 a = IPv4 (byteSwap32 a)

instance Show IPv4 where
    showsPrec p (IPv4 n) = showParen (p >= 11) (showString "IPv4 0x" . showHex n)

-- | @SRV@ Record data as per [RFC 2782](https://tools.ietf.org/html/rfc2782)
data SRV l = SRV { srvPriority :: !Word16
                 , srvWeight   :: !Word16
                 , srvPort     :: !Word16
                 , srvTarget   :: !l
                 } deriving (Eq,Read,Show,Functor,F.Foldable,T.Traversable)

instance NFData l => NFData (SRV l) where
  rnf (SRV _ _ _ l) = rnf l

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

dnsQuery :: Bool -> Name -> DnsType -> IO (Either Int [DnsRecord])
dnsQuery exact (Name n) ty = do
  alloca $ \pst -> do
    BS.useAsCString n $ \n' ->
      bracket (c_dns_query n' (fromDnsType ty) pst)
              (c_free_record)
              $ \p0 -> do
                st <- peek pst
                if (st /= 0)
                  then pure (Left (fromIntegral st))
                  else do
                    tmp <- travRecs (peekRec n') p0
                    if exact
                      then pure (Right [ r | (b,r) <- tmp, b ])
                      else pure (Right (map snd tmp))


foreign import capi safe "hs_windns.h hs_dns_query" c_dns_query :: Ptr CChar -> WORD -> Ptr CLong -> IO (Ptr DnsRecord)

foreign import capi unsafe "hs_windns.h hs_free_record" c_free_record :: Ptr DnsRecord -> IO (Ptr DnsRecord)

foreign import capi unsafe "hs_windns.h DnsNameCompare_A" c_dns_name_eq :: Ptr CChar -> Ptr CChar -> IO BOOL


travRecs :: (Ptr DnsRecord -> IO a) -> Ptr DnsRecord -> IO [a]
travRecs f p0 = go [] p0
  where
    go acc p
      | p == nullPtr = App.pure (reverse acc)
      | otherwise    = do
          x <- f p
          p' <- next p
          go (x:acc) p'

    next :: Ptr DnsRecord -> IO (Ptr DnsRecord)
    next = (\hsc_ptr -> peekByteOff hsc_ptr 0)
{-# LINE 145 "src/Network/DNS/FFI.hsc" #-}


peekRec :: Ptr CChar -> Ptr DnsRecord -> IO (Bool,DnsRecord)
peekRec n0 p = do
  drNamePtr <- (\hsc_ptr -> peekByteOff hsc_ptr 8) p
{-# LINE 150 "src/Network/DNS/FFI.hsc" #-}
  same <- c_dns_name_eq n0 drNamePtr
  drName <- Name <$> BS.packCString drNamePtr
  drType <- toDnsType <$> (\hsc_ptr -> peekByteOff hsc_ptr 16) p
{-# LINE 153 "src/Network/DNS/FFI.hsc" #-}
  drTTL  <- TTL . fromIntegral <$> ((\hsc_ptr -> peekByteOff hsc_ptr 24) p :: IO DWORD)
{-# LINE 154 "src/Network/DNS/FFI.hsc" #-}

  drData <- case drType of
              DnsTypeA    -> DnsDataA . mkIPv4 <$> (\hsc_ptr -> peekByteOff hsc_ptr 32) p
{-# LINE 157 "src/Network/DNS/FFI.hsc" #-}
              DnsTypeAAAA -> DnsDataAAAA <$> (mkIPv6 <$> (\hsc_ptr -> peekByteOff hsc_ptr 32) p
{-# LINE 158 "src/Network/DNS/FFI.hsc" #-}
                                                     <*> (\hsc_ptr -> peekByteOff hsc_ptr 36) p
{-# LINE 159 "src/Network/DNS/FFI.hsc" #-}
                                                     <*> (\hsc_ptr -> peekByteOff hsc_ptr 40) p
{-# LINE 160 "src/Network/DNS/FFI.hsc" #-}
                                                     <*> (\hsc_ptr -> peekByteOff hsc_ptr 44) p)
{-# LINE 161 "src/Network/DNS/FFI.hsc" #-}
              DnsTypeTXT  -> do
                cnt <- (\hsc_ptr -> peekByteOff hsc_ptr 32) p
{-# LINE 163 "src/Network/DNS/FFI.hsc" #-}
                let ptr0 = (\hsc_ptr -> hsc_ptr `plusPtr` 40) p
{-# LINE 164 "src/Network/DNS/FFI.hsc" #-}
                tptrs <- forM [0.. fromIntegral (cnt :: DWORD)-1] (peekElemOff ptr0)
                DnsDataTXT <$> mapM (fmap CharStr . BS.packCString) tptrs

              DnsTypeCNAME -> do
                cnamptr <- (\hsc_ptr -> peekByteOff hsc_ptr 32) p
{-# LINE 169 "src/Network/DNS/FFI.hsc" #-}
                DnsDataCNAME . Name <$> BS.packCString cnamptr

              DnsTypeSRV -> do
                namptr      <- (\hsc_ptr -> peekByteOff hsc_ptr 32) p
{-# LINE 173 "src/Network/DNS/FFI.hsc" #-}
                srvTarget   <- Name <$> BS.packCString namptr
                srvPort     <- (\hsc_ptr -> peekByteOff hsc_ptr 44) p
{-# LINE 175 "src/Network/DNS/FFI.hsc" #-}
                srvWeight   <- (\hsc_ptr -> peekByteOff hsc_ptr 42) p
{-# LINE 176 "src/Network/DNS/FFI.hsc" #-}
                srvPriority <- (\hsc_ptr -> peekByteOff hsc_ptr 40) p
{-# LINE 177 "src/Network/DNS/FFI.hsc" #-}

                pure $! DnsDataSRV (SRV {..})

              DnsType w -> pure (DnsData w)

  evaluate $ force (same /= 0,DnsRecord{..})

data DnsRecord = DnsRecord
    { drName :: !Name
    , drType :: !DnsType
    , drTTL  :: !TTL
    , drData :: !DnsData
    } deriving Show

instance NFData DnsRecord where
  rnf (DnsRecord n y t d) = n `deepseq` y `deepseq` t `deepseq` d `deepseq` ()


data DnsData = DnsDataA    !IPv4
             | DnsDataAAAA !IPv6
             | DnsDataTXT  [CharStr]
             | DnsDataCNAME !Name
             | DnsDataSRV  !(SRV Name)
             | DnsData     !WORD -- unknown/unsupported
             deriving Show

instance NFData DnsData where
  rnf (DnsDataA _) = ()
  rnf (DnsDataAAAA {}) = ()
  rnf (DnsDataTXT ts) = rnf ts
  rnf (DnsDataCNAME n) = rnf n
  rnf (DnsDataSRV srv) = rnf srv
  rnf (DnsData _) = ()

dnsDataType :: DnsData -> DnsType
dnsDataType DnsDataA {}     = DnsTypeA
dnsDataType DnsDataAAAA {}  = DnsTypeAAAA
dnsDataType DnsDataTXT {}   = DnsTypeTXT
dnsDataType DnsDataCNAME {} = DnsTypeCNAME
dnsDataType DnsDataSRV {}   = DnsTypeSRV
dnsDataType (DnsData w)     = DnsType w

data DnsType = DnsTypeA
             | DnsTypeAAAA
             | DnsTypeTXT
             | DnsTypeCNAME
             | DnsTypeSRV
             | DnsType !WORD
             deriving (Show)

instance NFData DnsType where rnf t = seq t ()

eqType :: DnsType -> DnsType -> Bool
eqType x y = fromDnsType x == fromDnsType y

fromDnsType :: DnsType -> WORD
fromDnsType x = case x of
  DnsTypeA     -> 1
{-# LINE 235 "src/Network/DNS/FFI.hsc" #-}
  DnsTypeAAAA  -> 28
{-# LINE 236 "src/Network/DNS/FFI.hsc" #-}
  DnsTypeTXT   -> 16
{-# LINE 237 "src/Network/DNS/FFI.hsc" #-}
  DnsTypeCNAME -> 5
{-# LINE 238 "src/Network/DNS/FFI.hsc" #-}
  DnsTypeSRV   -> 33
{-# LINE 239 "src/Network/DNS/FFI.hsc" #-}
  DnsType w    -> w

toDnsType :: WORD -> DnsType
toDnsType w = case w of
  1  -> DnsTypeA
{-# LINE 244 "src/Network/DNS/FFI.hsc" #-}
  28  -> DnsTypeAAAA
{-# LINE 245 "src/Network/DNS/FFI.hsc" #-}
  16  -> DnsTypeTXT
{-# LINE 246 "src/Network/DNS/FFI.hsc" #-}
  5 -> DnsTypeCNAME
{-# LINE 247 "src/Network/DNS/FFI.hsc" #-}
  33   -> DnsTypeSRV
{-# LINE 248 "src/Network/DNS/FFI.hsc" #-}
  _                       -> DnsType w



{-# LINE 258 "src/Network/DNS/FFI.hsc" #-}