{-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving #-}
{-# LANGUAGE FlexibleInstances #-}

module Propellor.Types.Dns where

import Propellor.Types.OS (HostName)
import Propellor.Types.Empty
import Propellor.Types.Info
import Propellor.Types.ConfigurableValue
import Utility.Split

import Data.Word
import qualified Data.Map as M
import qualified Data.Set as S
import qualified Data.Semigroup as Sem
import Data.List
import Data.Monoid
import Prelude

type Domain = String

data IPAddr = IPv4 String | IPv6 String
        deriving (Read, Show, Eq, Ord)

instance ConfigurableValue IPAddr where
        val (IPv4 addr) = addr
        val (IPv6 addr) = addr

newtype AliasesInfo = AliasesInfo (S.Set HostName)
        deriving (Show, Eq, Ord, Sem.Semigroup, Monoid, Typeable)

instance IsInfo AliasesInfo where
        propagateInfo _ = PropagateInfo False

toAliasesInfo :: [HostName] -> AliasesInfo
toAliasesInfo l = AliasesInfo (S.fromList l)

fromAliasesInfo :: AliasesInfo -> [HostName]
fromAliasesInfo (AliasesInfo s) = S.toList s

-- | Use this for DNS Info that should propagate from a container to a
-- host. For example, this can be used for CNAME to make aliases
-- of the containers in the host be reflected in the DNS.
newtype DnsInfoPropagated = DnsInfoPropagated
        { fromDnsInfoPropagated :: S.Set Record }
        deriving (Show, Eq, Ord, Sem.Semigroup, Monoid, Typeable)

toDnsInfoPropagated :: S.Set Record -> DnsInfoPropagated
toDnsInfoPropagated = DnsInfoPropagated

instance IsInfo DnsInfoPropagated where
        propagateInfo _ = PropagateInfo True

-- | Use this for DNS Info that should not propagate from a container to a
-- host. For example, an IP address of a container should not influence
-- the host.
newtype DnsInfoUnpropagated = DnsInfoUnpropagated
        { fromDnsInfoUnpropagated :: S.Set Record }
        deriving (Show, Eq, Ord, Sem.Semigroup, Monoid, Typeable)

toDnsInfoUnpropagated :: S.Set Record -> DnsInfoUnpropagated
toDnsInfoUnpropagated = DnsInfoUnpropagated

-- | Get all DNS Info.
getDnsInfo :: Info -> S.Set Record
getDnsInfo i = fromDnsInfoUnpropagated (fromInfo i)
        `S.union` fromDnsInfoPropagated (fromInfo i)

instance IsInfo DnsInfoUnpropagated where
        propagateInfo _ = PropagateInfo False

-- | Represents a bind 9 named.conf file.
data NamedConf = NamedConf
        { confDomain :: Domain
        , confDnsServerType :: DnsServerType
        , confFile :: FilePath
        , confMasters :: [IPAddr]
        , confAllowTransfer :: [IPAddr]
        , confLines :: [String]
        }
        deriving (Show, Eq, Ord)

data DnsServerType = Master | Secondary
        deriving (Show, Eq, Ord)

-- | Represents a bind 9 zone file.
data Zone = Zone
        { zDomain :: Domain
        , zSOA :: SOA
        , zHosts :: [(BindDomain, Record)]
        }
        deriving (Read, Show, Eq)

-- | Every domain has a SOA record, which is big and complicated.
data SOA = SOA
        { sDomain :: BindDomain
        -- ^ Typically ns1.your.domain
        , sSerial :: SerialNumber
        -- ^ The most important parameter is the serial number,
        -- which must increase after each change.
        , sRefresh :: Integer
        , sRetry :: Integer
        , sExpire :: Integer
        , sNegativeCacheTTL :: Integer
        }
        deriving (Read, Show, Eq)

-- | Types of DNS records.
--
-- This is not a complete list, more can be added.
data Record
        = Address IPAddr
        | CNAME BindDomain
        | MX Int BindDomain
        | NS BindDomain
        | TXT String
        | SRV Word16 Word16 Word16 BindDomain
        | SSHFP Int Int String
        | INCLUDE FilePath
        | PTR ReverseIP
        deriving (Read, Show, Eq, Ord, Typeable)

-- | An in-addr.arpa record corresponding to an IPAddr.
type ReverseIP = String

reverseIP :: IPAddr -> ReverseIP
reverseIP (IPv4 addr) = intercalate "." (reverse $ splitc '.' addr) ++ ".in-addr.arpa"
reverseIP addr@(IPv6 _) = reverse (intersperse '.' $ replace ":" "" $ val $ canonicalIP addr) ++ ".ip6.arpa"

-- | Converts an IP address (particularly IPv6) to canonical, fully
-- expanded form.
canonicalIP :: IPAddr -> IPAddr
canonicalIP (IPv4 addr) = IPv4 addr
canonicalIP (IPv6 addr) = IPv6 $ intercalate ":" $ map canonicalGroup $ splitc ':' $ replaceImplicitGroups addr
  where
        canonicalGroup g
                | l <= 4    = replicate (4 - l) '0' ++ g
                | otherwise = error $ "IPv6 group " ++ g ++ "as more than 4 hex digits"
          where
                l = length g
        emptyGroups n = iterate (++ ":") "" !! n
        numberOfImplicitGroups a = 8 - length (splitc ':' $ replace "::" "" a)
        replaceImplicitGroups a = concat $ aux $ split "::" a
          where
                aux [] = []
                aux (x : xs) = x : emptyGroups (numberOfImplicitGroups a) : xs

getIPAddr :: Record -> Maybe IPAddr
getIPAddr (Address addr) = Just addr
getIPAddr _ = Nothing

getCNAME :: Record -> Maybe BindDomain
getCNAME (CNAME d) = Just d
getCNAME _ = Nothing

getNS :: Record -> Maybe BindDomain
getNS (NS d) = Just d
getNS _ = Nothing

-- | Bind serial numbers are unsigned, 32 bit integers.
type SerialNumber = Word32

-- | Domains in the zone file must end with a period if they are absolute.
--
-- Let's use a type to keep absolute domains straight from relative
-- domains.
--
-- The RootDomain refers to the top level of the domain, so can be used
-- to add nameservers, MX's, etc to a domain.
data BindDomain = RelDomain Domain | AbsDomain Domain | RootDomain
        deriving (Read, Show, Eq, Ord)

domainHostName :: BindDomain -> Maybe HostName
domainHostName (RelDomain d) = Just d
domainHostName (AbsDomain d) = Just d
domainHostName RootDomain = Nothing

newtype NamedConfMap = NamedConfMap (M.Map Domain NamedConf)
        deriving (Eq, Ord, Show, Typeable)

instance IsInfo NamedConfMap where
        propagateInfo _ = PropagateInfo False

-- | Adding a Master NamedConf stanza for a particulr domain always
-- overrides an existing Secondary stanza for that domain, while a
-- Secondary stanza is only added when there is no existing Master stanza.
instance Sem.Semigroup NamedConfMap where
        NamedConfMap old <> NamedConfMap new = NamedConfMap $
                M.unionWith combiner new old
          where
                combiner n o = case (confDnsServerType n, confDnsServerType o) of
                        (Secondary, Master) -> o
                        _  -> n

instance Monoid NamedConfMap where
        mempty = NamedConfMap M.empty
        mappend = (Sem.<>)

instance Empty NamedConfMap where
        isEmpty (NamedConfMap m) = isEmpty m

fromNamedConfMap :: NamedConfMap -> M.Map Domain NamedConf
fromNamedConfMap (NamedConfMap m) = m