1 files changed, 84 insertions, 20 deletions

diff --git a/src/Propellor/Info.hs b/src/Propellor/Info.hs
index 7eb7d4a8..b87369c3 100644
--- a/src/Propellor/Info.hs
+++ b/src/Propellor/Info.hs
@@ -1,9 +1,30 @@
-{-# LANGUAGE PackageImports #-}
+{-# LANGUAGE PackageImports, TypeFamilies, DataKinds, PolyKinds #-}
 
-module Propellor.Info where
+module Propellor.Info (
+	osDebian,
+	osBuntish,
+	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
@@ -13,21 +34,67 @@ import Data.Monoid
 import Control.Applicative
 import Prelude
 
-pureInfoProperty :: (IsInfo v) => Desc -> v -> Property HasInfo
-pureInfoProperty desc v = pureInfoProperty' desc (addInfo mempty v)
+-- | Adds info to a Property.
+--
+-- The new Property will include HasInfo in its metatypes.
+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
+
+-- | Adds more info to a Property that already HasInfo.
+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' :: Desc -> Info -> Property HasInfo
-pureInfoProperty' desc i = infoProperty ("has " ++ desc) (return NoChange) i mempty
+-- | 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 (getInfo . hostInfo)
+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 "jessie") "amd64"
+osDebian :: DebianSuite -> Architecture -> Property (HasInfo + Debian)
+osDebian suite arch = tightenTargets $ os (System (Debian suite) arch)
 
--- | Specifies the operating system of a host.
+-- | Specifies that a host's operating system is a well-known Debian
+-- derivative founded by a space tourist.
 --
--- This only provides info for other Properties, so they can act
--- conditionally on the os.
-os :: System -> Property HasInfo
+-- (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)
+
+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.
@@ -43,11 +110,11 @@ getOS = fromInfoVal <$> askInfo
 -- 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
+ipv4 :: String -> Property (HasInfo + UnixLike)
 ipv4 = addDNS . Address . IPv4
 
 -- | Indicate that a host has an AAAA record in the DNS.
-ipv6 :: String -> Property HasInfo
+ipv6 :: String -> Property (HasInfo + UnixLike)
 ipv6 = addDNS . Address . IPv6
 
 -- | Indicates another name for the host in the DNS.
@@ -56,14 +123,14 @@ ipv6 = addDNS . Address . IPv6
 -- 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
+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` (toDnsInfo $ S.singleton $ CNAME $ AbsDomain d)
 
-addDNS :: Record -> Property HasInfo
+addDNS :: Record -> Property (HasInfo + UnixLike)
 addDNS r = pureInfoProperty (rdesc r) (toDnsInfo (S.singleton r))
   where
 	rdesc (CNAME d) = unwords ["alias", ddesc d]
@@ -86,7 +153,7 @@ 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 $ getInfo $ hostInfo h)
+	map (\h -> map (\aka -> (aka, h)) $ fromAliasesInfo $ fromInfo $ hostInfo h)
 
 findHost :: [Host] -> HostName -> Maybe Host
 findHost l hn = (findHostNoAlias l hn) <|> (findAlias l hn)
@@ -98,10 +165,7 @@ findAlias :: [Host] -> HostName -> Maybe Host
 findAlias l hn = M.lookup hn (aliasMap l)
 
 getAddresses :: Info -> [IPAddr]
-getAddresses = mapMaybe getIPAddr . S.toList . fromDnsInfo . getInfo
+getAddresses = mapMaybe getIPAddr . S.toList . fromDnsInfo . fromInfo
 
 hostAddresses :: HostName -> [Host] -> [IPAddr]
 hostAddresses hn hosts = maybe [] (getAddresses . hostInfo) (findHost hosts hn)
-
-addHostInfo ::IsInfo v => Host -> v -> Host
-addHostInfo h v = h { hostInfo = addInfo (hostInfo h) v }