    {-# LANGUAGE PackageImports, TypeFamilies, DataKinds, PolyKinds #-}

    module Propellor.Info (
    	osDebian,
    	osBuntish,
    	osArchLinux,
    	osFreeBSD,
    	setInfoProperty,
    	addInfoProperty,
    	pureInfoProperty,
    	pureInfoProperty',
    	askInfo,
    	getOS,
    	ipv4,
    	ipv6,
    	alias,
    	addDNS,
    	hostMap,
    	aliasMap,
    	findHost,
    	findHostNoAlias,
    	getAddresses,
    	hostAddresses,
    ) where

    import Propellor.Types
    import Propellor.Types.Info
    import Propellor.Types.MetaTypes

    import "mtl" Control.Monad.Reader
    import qualified Data.Set as S
    import qualified Data.Map as M
    import Data.Maybe
    import Data.Monoid
    import Control.Applicative
    import Prelude

    -- | Adds info to a Property.
    --
    -- The new Property will include HasInfo in its metatypes.
    setInfoProperty
    	-- -Wredundant-constraints is turned off because
    	-- this constraint appears redundant, but is actually
    	-- crucial.
    	:: (MetaTypes metatypes' ~ (+) HasInfo metatypes, SingI metatypes')
    	=> Property metatypes
    	-> Info
    	-> Property (MetaTypes metatypes')
    setInfoProperty (Property _ d a oldi c) newi =
    	Property sing d a (oldi <> newi) c

    -- | Adds more info to a Property that already HasInfo.
    addInfoProperty
    	-- -Wredundant-constraints is turned off because
    	-- this constraint appears redundant, but is actually
    	-- crucial.
    	:: (IncludesInfo metatypes ~ 'True)
    	=> Property metatypes
    	-> Info
    	-> Property metatypes
    addInfoProperty (Property t d a oldi c) newi =
    	Property t d a (oldi <> newi) c

    -- | Makes a property that does nothing but set some `Info`.
    pureInfoProperty :: (IsInfo v) => Desc -> v -> Property (HasInfo + UnixLike)
    pureInfoProperty desc v = pureInfoProperty' desc (toInfo v)

    pureInfoProperty' :: Desc -> Info -> Property (HasInfo + UnixLike)
    pureInfoProperty' desc i = setInfoProperty p i
      where
    	p :: Property UnixLike
    	p = property ("has " ++ desc) (return NoChange)

    -- | Gets a value from the host's Info.
    askInfo :: (IsInfo v) => Propellor v
    askInfo = asks (fromInfo . hostInfo)

    -- | Specifies that a host's operating system is Debian,
    -- and further indicates the suite and architecture.
    --
    -- This provides info for other Properties, so they can act
    -- conditionally on the details of the OS.
    --
    -- It also lets the type checker know that all the properties of the
    -- host must support Debian.
    --
    -- >	& osDebian (Stable "stretch") X86_64
    osDebian :: DebianSuite -> Architecture -> Property (HasInfo + Debian)
    osDebian = osDebian' Linux

    -- Use to specify a different `DebianKernel` than the default `Linux`
    --
    -- >	& osDebian' KFreeBSD (Stable "stretch") X86_64
    osDebian' :: DebianKernel -> DebianSuite -> Architecture -> Property (HasInfo + Debian)
    osDebian' kernel suite arch = tightenTargets $ os (System (Debian kernel suite) arch)

    -- | Specifies that a host's operating system is a well-known Debian
    -- derivative founded by a space tourist.
    --
    -- (The actual name of this distribution is not used in Propellor per
    -- <http://joeyh.name/blog/entry/trademark_nonsense/>)
    osBuntish :: Release -> Architecture -> Property (HasInfo + Buntish)
    osBuntish release arch = tightenTargets $ os (System (Buntish release) arch)

    -- | Specifies that a host's operating system is FreeBSD
    -- and further indicates the release and architecture.
    osFreeBSD :: FreeBSDRelease -> Architecture -> Property (HasInfo + FreeBSD)
    osFreeBSD release arch = tightenTargets $ os (System (FreeBSD release) arch)

    -- | Specifies that a host's operating system is Arch Linux
    osArchLinux :: Architecture -> Property (HasInfo + ArchLinux)
    osArchLinux arch = tightenTargets $ os (System (ArchLinux) arch)

    os :: System -> Property (HasInfo + UnixLike)
    os system = pureInfoProperty ("Operating " ++ show system) (InfoVal system)

    --  Gets the operating system of a host, if it has been specified.
    getOS :: Propellor (Maybe System)
    getOS = fromInfoVal <$> askInfo

    -- | Indicate that a host has an A record in the DNS.
    --
    -- When propellor is used to deploy a DNS server for a domain,
    -- the hosts in the domain are found by looking for these
    -- and similar properites.
    --
    -- When propellor --spin is used to deploy a host, it checks
    -- if the host's IP Property matches the DNS. If the DNS is missing or
    -- out of date, the host will instead be contacted directly by IP address.
    ipv4 :: String -> Property (HasInfo + UnixLike)
    ipv4 = addDNS False . Address . IPv4

    -- | Indicate that a host has an AAAA record in the DNS.
    ipv6 :: String -> Property (HasInfo + UnixLike)
    ipv6 = addDNS False . Address . IPv6

    -- | Indicates another name for the host in the DNS.
    --
    -- When the host's ipv4/ipv6 addresses are known, the alias is set up
    -- to use their address, rather than using a CNAME. This avoids various
    -- problems with CNAMEs, and also means that when multiple hosts have the
    -- same alias, a DNS round-robin is automatically set up.
    alias :: Domain -> Property (HasInfo + UnixLike)
    alias d = pureInfoProperty' ("alias " ++ d) $ mempty
    	`addInfo` toAliasesInfo [d]
    	-- A CNAME is added here, but the DNS setup code converts it to an
    	-- IP address when that makes sense.
    	`addInfo` (toDnsInfoPropagated $ S.singleton $ CNAME $ AbsDomain d)

    -- | Add a DNS Record.
    addDNS
    	:: Bool
    	-- ^ When used in a container, the DNS info will only
    	-- propagate out the the Host when this is True.
    	-> Record
    	-> Property (HasInfo + UnixLike)
    addDNS prop r
    	| prop = pureInfoProperty (rdesc r) (toDnsInfoPropagated s)
    	| otherwise = pureInfoProperty (rdesc r) (toDnsInfoUnpropagated s)
      where
    	s = S.singleton r

    	rdesc (CNAME d) = unwords ["alias", ddesc d]
    	rdesc (Address (IPv4 addr)) = unwords ["ipv4", addr]
    	rdesc (Address (IPv6 addr)) = unwords ["ipv6", addr]
    	rdesc (MX n d) = unwords ["MX", show n, ddesc d]
    	rdesc (NS d) = unwords ["NS", ddesc d]
    	rdesc (TXT t) = unwords ["TXT", t]
    	rdesc (SRV x y z d) = unwords ["SRV", show x, show y, show z, ddesc d]
    	rdesc (SSHFP x y t) = unwords ["SSHFP", show x, show y, t]
    	rdesc (INCLUDE f) = unwords ["$INCLUDE", f]
    	rdesc (PTR x) = unwords ["PTR", x]

    	ddesc (AbsDomain domain) = domain
    	ddesc (RelDomain domain) = domain
    	ddesc RootDomain = "@"

    hostMap :: [Host] -> M.Map HostName Host
    hostMap l = M.fromList $ zip (map hostName l) l

    aliasMap :: [Host] -> M.Map HostName Host
    aliasMap = M.fromList . concat .
    	map (\h -> map (\aka -> (aka, h)) $ fromAliasesInfo $ fromInfo $ hostInfo h)

    findHost :: [Host] -> HostName -> Maybe Host
    findHost l hn = (findHostNoAlias l hn) <|> (findAlias l hn)

    findHostNoAlias :: [Host] -> HostName -> Maybe Host
    findHostNoAlias l hn = M.lookup hn (hostMap l)

    findAlias :: [Host] -> HostName -> Maybe Host
    findAlias l hn = M.lookup hn (aliasMap l)

    getAddresses :: Info -> [IPAddr]
    getAddresses = mapMaybe getIPAddr . S.toList . getDnsInfo

    hostAddresses :: HostName -> [Host] -> [IPAddr]
    hostAddresses hn hosts = maybe [] (getAddresses . hostInfo) (findHost hosts hn)