summaryrefslogtreecommitdiff
path: root/src/Propellor/Info.hs
diff options
context:
space:
mode:
Diffstat (limited to 'src/Propellor/Info.hs')
-rw-r--r--src/Propellor/Info.hs108
1 files changed, 86 insertions, 22 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 #-}
-
-module Propellor.Info where
+{-# LANGUAGE PackageImports, TypeFamilies, DataKinds, PolyKinds #-}
+
+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)
-
-pureInfoProperty' :: Desc -> Info -> Property HasInfo
-pureInfoProperty' desc i = infoProperty ("has " ++ desc) (return NoChange) i mempty
+-- | 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
+
+-- | 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 }