{-# 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
setInfoProperty
:: (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
addInfoProperty
:: (IncludesInfo metatypes ~ 'True)
=> Property metatypes
-> Info
-> Property metatypes
addInfoProperty (Property t d a oldi c) newi =
Property t d a (oldi <> newi) c
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)
askInfo :: (IsInfo v) => Propellor v
askInfo = asks (fromInfo . hostInfo)
hasContainerCapability :: ContainerCapability -> Propellor Bool
hasContainerCapability c = elem c
<$> (askInfo :: Propellor [ContainerCapability])
osDebian :: DebianSuite -> Architecture -> Property (HasInfo + Debian)
osDebian = osDebian' Linux
osDebian' :: DebianKernel -> DebianSuite -> Architecture -> Property (HasInfo + Debian)
osDebian' kernel suite arch = tightenTargets $ os (System (Debian kernel suite) arch)
osBuntish :: Release -> Architecture -> Property (HasInfo + Buntish)
osBuntish release arch = tightenTargets $ os (System (Buntish release) arch)
osFreeBSD :: FreeBSDRelease -> Architecture -> Property (HasInfo + FreeBSD)
osFreeBSD release arch = tightenTargets $ os (System (FreeBSD release) arch)
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)
getOS :: Propellor (Maybe System)
getOS = fromInfoVal <$> askInfo
ipv4 :: String -> Property (HasInfo + UnixLike)
ipv4 = addDNS False . Address . IPv4
ipv6 :: String -> Property (HasInfo + UnixLike)
ipv6 = addDNS False . Address . IPv6
alias :: Domain -> Property (HasInfo + UnixLike)
alias d = pureInfoProperty' ("alias " ++ d) $ mempty
`addInfo` toAliasesInfo [d]
`addInfo` (toDnsInfoPropagated $ S.singleton $ CNAME $ AbsDomain d)
addDNS
:: Bool
-> 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)