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

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

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

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 :: forall {k} (metatypes' :: k) metatypes.
(MetaTypes metatypes' ~ (HasInfo + metatypes), SingI metatypes') =>
Property metatypes -> Info -> Property (MetaTypes metatypes')
setInfoProperty (Property metatypes
_ HostName
d Maybe (Propellor Result)
a Info
oldi [ChildProperty]
c) Info
newi =
	forall metatypes.
metatypes
-> HostName
-> Maybe (Propellor Result)
-> Info
-> [ChildProperty]
-> Property metatypes
Property forall {k} (t :: k). SingI t => Sing t
sing HostName
d Maybe (Propellor Result)
a (Info
oldi forall a. Semigroup a => a -> a -> a
<> Info
newi) [ChildProperty]
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 :: forall metatypes.
(IncludesInfo metatypes ~ 'True) =>
Property metatypes -> Info -> Property metatypes
addInfoProperty (Property metatypes
t HostName
d Maybe (Propellor Result)
a Info
oldi [ChildProperty]
c) Info
newi =
	forall metatypes.
metatypes
-> HostName
-> Maybe (Propellor Result)
-> Info
-> [ChildProperty]
-> Property metatypes
Property metatypes
t HostName
d Maybe (Propellor Result)
a (Info
oldi forall a. Semigroup a => a -> a -> a
<> Info
newi) [ChildProperty]
c

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

pureInfoProperty' :: Desc -> Info -> Property (HasInfo + UnixLike)
pureInfoProperty' :: HostName -> Info -> Property (HasInfo + UnixLike)
pureInfoProperty' HostName
desc Info
i = forall {k} (metatypes' :: k) metatypes.
(MetaTypes metatypes' ~ (HasInfo + metatypes), SingI metatypes') =>
Property metatypes -> Info -> Property (MetaTypes metatypes')
setInfoProperty Property UnixLike
p Info
i
  where
	p :: Property UnixLike
	p :: Property UnixLike
p = forall {k} (metatypes :: k).
SingI metatypes =>
HostName -> Propellor Result -> Property (MetaTypes metatypes)
property (HostName
"has " forall a. [a] -> [a] -> [a]
++ HostName
desc) (forall (m :: * -> *) a. Monad m => a -> m a
return Result
NoChange)

-- | Gets a value from the host's Info.
askInfo :: (IsInfo v) => Propellor v
askInfo :: forall v. IsInfo v => Propellor v
askInfo = forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (forall v. IsInfo v => Info -> v
fromInfo forall b c a. (b -> c) -> (a -> b) -> a -> c
. Host -> Info
hostInfo)

-- | Checks if a ContainerCapability is set in the current Info.
hasContainerCapability :: ContainerCapability -> Propellor Bool
hasContainerCapability :: ContainerCapability -> Propellor Bool
hasContainerCapability ContainerCapability
c = forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem ContainerCapability
c
	forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall v. IsInfo v => Propellor v
askInfo ::  Propellor [ContainerCapability])

-- | 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 "buster") X86_64
osDebian :: DebianSuite -> Architecture -> Property (HasInfo + Debian)
osDebian :: DebianSuite -> Architecture -> Property (HasInfo + Debian)
osDebian = DebianKernel
-> DebianSuite -> Architecture -> Property (HasInfo + Debian)
osDebian' DebianKernel
Linux

-- Use to specify a different `DebianKernel` than the default `Linux`
--
-- >	& osDebian' KFreeBSD (Stable "buster") X86_64
osDebian' :: DebianKernel -> DebianSuite -> Architecture -> Property (HasInfo + Debian)
osDebian' :: DebianKernel
-> DebianSuite -> Architecture -> Property (HasInfo + Debian)
osDebian' DebianKernel
kernel DebianSuite
suite Architecture
arch = forall (p :: * -> *) (untightened :: [MetaType])
       (tightened :: [MetaType]).
(TightenTargets p, TightenTargetsAllowed untightened tightened,
 SingI tightened) =>
p (MetaTypes untightened) -> p (MetaTypes tightened)
tightenTargets forall a b. (a -> b) -> a -> b
$ System -> Property (HasInfo + UnixLike)
os (Distribution -> Architecture -> System
System (DebianKernel -> DebianSuite -> Distribution
Debian DebianKernel
kernel DebianSuite
suite) Architecture
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 :: HostName -> Architecture -> Property (HasInfo + Buntish)
osBuntish HostName
release Architecture
arch = forall (p :: * -> *) (untightened :: [MetaType])
       (tightened :: [MetaType]).
(TightenTargets p, TightenTargetsAllowed untightened tightened,
 SingI tightened) =>
p (MetaTypes untightened) -> p (MetaTypes tightened)
tightenTargets forall a b. (a -> b) -> a -> b
$ System -> Property (HasInfo + UnixLike)
os (Distribution -> Architecture -> System
System (HostName -> Distribution
Buntish HostName
release) Architecture
arch)

-- | Specifies that a host's operating system is FreeBSD
-- and further indicates the release and architecture.
osFreeBSD :: FreeBSDRelease -> Architecture -> Property (HasInfo + FreeBSD)
osFreeBSD :: FreeBSDRelease -> Architecture -> Property (HasInfo + FreeBSD)
osFreeBSD FreeBSDRelease
release Architecture
arch = forall (p :: * -> *) (untightened :: [MetaType])
       (tightened :: [MetaType]).
(TightenTargets p, TightenTargetsAllowed untightened tightened,
 SingI tightened) =>
p (MetaTypes untightened) -> p (MetaTypes tightened)
tightenTargets forall a b. (a -> b) -> a -> b
$ System -> Property (HasInfo + UnixLike)
os (Distribution -> Architecture -> System
System (FreeBSDRelease -> Distribution
FreeBSD FreeBSDRelease
release) Architecture
arch)

-- | Specifies that a host's operating system is Arch Linux
osArchLinux :: Architecture -> Property (HasInfo + ArchLinux)
osArchLinux :: Architecture -> Property (HasInfo + ArchLinux)
osArchLinux Architecture
arch = forall (p :: * -> *) (untightened :: [MetaType])
       (tightened :: [MetaType]).
(TightenTargets p, TightenTargetsAllowed untightened tightened,
 SingI tightened) =>
p (MetaTypes untightened) -> p (MetaTypes tightened)
tightenTargets forall a b. (a -> b) -> a -> b
$ System -> Property (HasInfo + UnixLike)
os (Distribution -> Architecture -> System
System (Distribution
ArchLinux) Architecture
arch)

os :: System -> Property (HasInfo + UnixLike)
os :: System -> Property (HasInfo + UnixLike)
os System
system = forall v.
IsInfo v =>
HostName -> v -> Property (HasInfo + UnixLike)
pureInfoProperty (HostName
"Operating " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> HostName
show System
system) (forall v. v -> InfoVal v
InfoVal System
system)

--  Gets the operating system of a host, if it has been specified.
getOS :: Propellor (Maybe System)
getOS :: Propellor (Maybe System)
getOS = forall v. InfoVal v -> Maybe v
fromInfoVal forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall v. IsInfo v => Propellor v
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 :: HostName -> Property (HasInfo + UnixLike)
ipv4 = Bool -> Record -> Property (HasInfo + UnixLike)
addDNS Bool
False forall b c a. (b -> c) -> (a -> b) -> a -> c
. IPAddr -> Record
Address forall b c a. (b -> c) -> (a -> b) -> a -> c
. HostName -> IPAddr
IPv4

-- | Indicate that a host has an AAAA record in the DNS.
ipv6 :: String -> Property (HasInfo + UnixLike)
ipv6 :: HostName -> Property (HasInfo + UnixLike)
ipv6 = Bool -> Record -> Property (HasInfo + UnixLike)
addDNS Bool
False forall b c a. (b -> c) -> (a -> b) -> a -> c
. IPAddr -> Record
Address forall b c a. (b -> c) -> (a -> b) -> a -> c
. HostName -> IPAddr
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 :: HostName -> Property (HasInfo + UnixLike)
alias HostName
d = HostName -> Info -> Property (HasInfo + UnixLike)
pureInfoProperty' (HostName
"alias " forall a. [a] -> [a] -> [a]
++ HostName
d) forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => a
mempty
	forall v. IsInfo v => Info -> v -> Info
`addInfo` [HostName] -> AliasesInfo
toAliasesInfo [HostName
d]
	-- A CNAME is added here, but the DNS setup code converts it to an
	-- IP address when that makes sense.
	forall v. IsInfo v => Info -> v -> Info
`addInfo` (Set Record -> DnsInfoPropagated
toDnsInfoPropagated forall a b. (a -> b) -> a -> b
$ forall a. a -> Set a
S.singleton forall a b. (a -> b) -> a -> b
$ BindDomain -> Record
CNAME forall a b. (a -> b) -> a -> b
$ HostName -> BindDomain
AbsDomain HostName
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 :: Bool -> Record -> Property (HasInfo + UnixLike)
addDNS Bool
prop Record
r
	| Bool
prop = forall v.
IsInfo v =>
HostName -> v -> Property (HasInfo + UnixLike)
pureInfoProperty (Record -> HostName
rdesc Record
r) (Set Record -> DnsInfoPropagated
toDnsInfoPropagated Set Record
s)
	| Bool
otherwise = forall v.
IsInfo v =>
HostName -> v -> Property (HasInfo + UnixLike)
pureInfoProperty (Record -> HostName
rdesc Record
r) (Set Record -> DnsInfoUnpropagated
toDnsInfoUnpropagated Set Record
s)
  where
	s :: Set Record
s = forall a. a -> Set a
S.singleton Record
r

	rdesc :: Record -> HostName
rdesc (CNAME BindDomain
d) = [HostName] -> HostName
unwords [HostName
"alias", BindDomain -> HostName
ddesc BindDomain
d]
	rdesc (Address (IPv4 HostName
addr)) = [HostName] -> HostName
unwords [HostName
"ipv4", HostName
addr]
	rdesc (Address (IPv6 HostName
addr)) = [HostName] -> HostName
unwords [HostName
"ipv6", HostName
addr]
	rdesc (MX Int
n BindDomain
d) = [HostName] -> HostName
unwords [HostName
"MX", forall a. Show a => a -> HostName
show Int
n, BindDomain -> HostName
ddesc BindDomain
d]
	rdesc (NS BindDomain
d) = [HostName] -> HostName
unwords [HostName
"NS", BindDomain -> HostName
ddesc BindDomain
d]
	rdesc (TXT HostName
t) = [HostName] -> HostName
unwords [HostName
"TXT", HostName
t]
	rdesc (SRV Word16
x Word16
y Word16
z BindDomain
d) = [HostName] -> HostName
unwords [HostName
"SRV", forall a. Show a => a -> HostName
show Word16
x, forall a. Show a => a -> HostName
show Word16
y, forall a. Show a => a -> HostName
show Word16
z, BindDomain -> HostName
ddesc BindDomain
d]
	rdesc (SSHFP Int
x Int
y HostName
t) = [HostName] -> HostName
unwords [HostName
"SSHFP", forall a. Show a => a -> HostName
show Int
x, forall a. Show a => a -> HostName
show Int
y, HostName
t]
	rdesc (INCLUDE HostName
f) = [HostName] -> HostName
unwords [HostName
"$INCLUDE", HostName
f]
	rdesc (PTR HostName
x) = [HostName] -> HostName
unwords [HostName
"PTR", HostName
x]

	ddesc :: BindDomain -> HostName
ddesc (AbsDomain HostName
domain) = HostName
domain
	ddesc (RelDomain HostName
domain) = HostName
domain
	ddesc BindDomain
RootDomain = HostName
"@"

hostMap :: [Host] -> M.Map HostName Host
hostMap :: [Host] -> Map HostName Host
hostMap [Host]
l = forall k a. Ord k => [(k, a)] -> Map k a
M.fromList forall a b. (a -> b) -> a -> b
$ forall a b. [a] -> [b] -> [(a, b)]
zip (forall a b. (a -> b) -> [a] -> [b]
map Host -> HostName
hostName [Host]
l) [Host]
l

aliasMap :: [Host] -> M.Map HostName Host
aliasMap :: [Host] -> Map HostName Host
aliasMap = forall k a. Ord k => [(k, a)] -> Map k a
M.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall b c a. (b -> c) -> (a -> b) -> a -> c
.
	forall a b. (a -> b) -> [a] -> [b]
map (\Host
h -> forall a b. (a -> b) -> [a] -> [b]
map (\HostName
aka -> (HostName
aka, Host
h)) forall a b. (a -> b) -> a -> b
$ AliasesInfo -> [HostName]
fromAliasesInfo forall a b. (a -> b) -> a -> b
$ forall v. IsInfo v => Info -> v
fromInfo forall a b. (a -> b) -> a -> b
$ Host -> Info
hostInfo Host
h)

findHost :: [Host] -> HostName -> Maybe Host
findHost :: [Host] -> HostName -> Maybe Host
findHost [Host]
l HostName
hn = ([Host] -> HostName -> Maybe Host
findHostNoAlias [Host]
l HostName
hn) forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ([Host] -> HostName -> Maybe Host
findAlias [Host]
l HostName
hn)

findHostNoAlias :: [Host] -> HostName -> Maybe Host
findHostNoAlias :: [Host] -> HostName -> Maybe Host
findHostNoAlias [Host]
l HostName
hn = forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup HostName
hn ([Host] -> Map HostName Host
hostMap [Host]
l)

findAlias :: [Host] -> HostName -> Maybe Host
findAlias :: [Host] -> HostName -> Maybe Host
findAlias [Host]
l HostName
hn = forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup HostName
hn ([Host] -> Map HostName Host
aliasMap [Host]
l)

getAddresses :: Info -> [IPAddr]
getAddresses :: Info -> [IPAddr]
getAddresses = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Record -> Maybe IPAddr
getIPAddr forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Set a -> [a]
S.toList forall b c a. (b -> c) -> (a -> b) -> a -> c
. Info -> Set Record
getDnsInfo

hostAddresses :: HostName -> [Host] -> [IPAddr]
hostAddresses :: HostName -> [Host] -> [IPAddr]
hostAddresses HostName
hn [Host]
hosts = forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (Info -> [IPAddr]
getAddresses forall b c a. (b -> c) -> (a -> b) -> a -> c
. Host -> Info
hostInfo) ([Host] -> HostName -> Maybe Host
findHost [Host]
hosts HostName
hn)