new more expressive config.hs WIP

10 files changed, 206 insertions, 80 deletions

diff --git a/Propellor/Attr.hs b/Propellor/Attr.hs
new file mode 100644
index 00000000..4bc1c2c7
--- /dev/null
+++ b/Propellor/Attr.hs
@@ -0,0 +1,47 @@
+{-# LANGUAGE PackageImports #-}
+
+module Propellor.Attr where
+
+import Propellor.Types
+import Propellor.Types.Attr
+
+import "mtl" Control.Monad.Reader
+import qualified Data.Set as S
+import qualified Data.Map as M
+
+pureAttrProperty :: Desc -> (Attr -> Attr) -> AttrProperty 
+pureAttrProperty desc = AttrProperty $ Property ("has " ++ desc)
+	(return NoChange)
+
+hostname :: HostName -> AttrProperty
+hostname name = pureAttrProperty ("hostname " ++ name) $
+	\d -> d { _hostname = name }
+
+getHostName :: Propellor HostName
+getHostName = asks _hostname
+
+cname :: Domain -> AttrProperty
+cname domain = pureAttrProperty ("cname " ++ domain) (addCName domain)
+
+cnameFor :: IsProp p => Domain -> (Domain -> p) -> AttrProperty
+cnameFor domain mkp =
+	let p = mkp domain
+	in AttrProperty p (addCName domain)
+
+addCName :: HostName -> Attr -> Attr
+addCName domain d = d { _cnames = S.insert domain (_cnames d) }
+
+hostnameless :: Attr
+hostnameless = newAttr (error "hostname Attr not specified")
+
+hostAttr :: Host -> Attr
+hostAttr (Host _ mkattrs) = mkattrs hostnameless
+
+hostProperties :: Host -> [Property]
+hostProperties (Host ps _) = ps
+
+hostMap :: [Host] -> M.Map HostName Host
+hostMap l = M.fromList $ zip (map (_hostname . hostAttr) l) l 
+
+findHost :: [Host] -> HostName -> Maybe Host
+findHost l hn = M.lookup hn (hostMap l)
diff --git a/Propellor/CmdLine.hs b/Propellor/CmdLine.hs
index 2026c47a..5be91c4f 100644
--- a/Propellor/CmdLine.hs
+++ b/Propellor/CmdLine.hs
@@ -55,8 +55,8 @@ processCmdLine = go =<< getArgs
 			else return $ Run s
 	go _ = usage
 
-defaultMain :: [HostName -> Maybe [Property]] -> IO ()
-defaultMain getprops = do
+defaultMain :: [Host] -> IO ()
+defaultMain hostlist = do
 	DockerShim.cleanEnv
 	checkDebugMode
 	cmdline <- processCmdLine
@@ -64,25 +64,26 @@ defaultMain getprops = do
 	go True cmdline
   where
 	go _ (Continue cmdline) = go False cmdline
-	go _ (Set host field) = setPrivData host field
+	go _ (Set hn field) = setPrivData hn field
 	go _ (AddKey keyid) = addKey keyid
-	go _ (Chain host) = withprops host $ \hostattr ps -> do
-		r <- runPropellor hostattr $ ensureProperties ps
+	go _ (Chain hn) = withprops hn $ \attr ps -> do
+		r <- runPropellor attr $ ensureProperties ps
 		putStrLn $ "\n" ++ show r
-	go _ (Docker host) = Docker.chain host
+	go _ (Docker hn) = Docker.chain hn
 	go True cmdline@(Spin _) = buildFirst cmdline $ go False cmdline
 	go True cmdline = updateFirst cmdline $ go False cmdline
-	go False (Spin host) = withprops host $ const . const $ spin host
-	go False (Run host) = ifM ((==) 0 <$> getRealUserID)
-		( onlyProcess $ withprops host mainProperties
-		, go True (Spin host)
+	go False (Spin hn) = withprops hn $ const . const $ spin hn
+	go False (Run hn) = ifM ((==) 0 <$> getRealUserID)
+		( onlyProcess $ withprops hn mainProperties
+		, go True (Spin hn)
 		)
-	go False (Boot host) = onlyProcess $ withprops host $ boot
+	go False (Boot hn) = onlyProcess $ withprops hn boot
 
-	withprops host a = maybe (unknownhost host) (a hostattr) $
-		headMaybe $ catMaybes $ map (\get -> get host) getprops
-	  where
-		hostattr = mkHostAttr host
+	withprops :: HostName -> (Attr -> [Property] -> IO ()) -> IO ()
+	withprops hn a = maybe
+		(unknownhost hn)
+		(\h -> a (hostAttr h) (hostProperties h))
+		(findHost hostlist hn)
 
 onlyProcess :: IO a -> IO a
 onlyProcess a = bracket lock unlock (const a)
@@ -166,16 +167,16 @@ getCurrentGitSha1 :: String -> IO String
 getCurrentGitSha1 branchref = readProcess "git" ["show-ref", "--hash", branchref]
 
 spin :: HostName -> IO ()
-spin host = do
+spin hn = do
 	url <- getUrl
 	void $ gitCommit [Param "--allow-empty", Param "-a", Param "-m", Param "propellor spin"]
 	void $ boolSystem "git" [Param "push"]
-	cacheparams <- toCommand <$> sshCachingParams host
-	go cacheparams url =<< gpgDecrypt (privDataFile host)
+	cacheparams <- toCommand <$> sshCachingParams hn
+	go cacheparams url =<< gpgDecrypt (privDataFile hn)
   where
 	go cacheparams url privdata = withBothHandles createProcessSuccess (proc "ssh" $ cacheparams ++ [user, bootstrapcmd]) $ \(toh, fromh) -> do
 		let finish = do
-			senddata toh (privDataFile host) privDataMarker privdata
+			senddata toh (privDataFile hn) privDataMarker privdata
 			hClose toh
 			
 			-- Display remaining output.
@@ -188,10 +189,10 @@ spin host = do
 			NeedGitClone -> do
 				hClose toh
 				hClose fromh
-				sendGitClone host url
+				sendGitClone hn url
 				go cacheparams url privdata
 	
-	user = "root@"++host
+	user = "root@"++hn
 
 	bootstrapcmd = shellWrap $ intercalate " ; "
 		[ "if [ ! -d " ++ localdir ++ " ]"
@@ -202,7 +203,7 @@ spin host = do
 		, "else " ++ intercalate " && "
 			[ "cd " ++ localdir
 			, "if ! test -x ./propellor; then make deps build; fi"
-			, "./propellor --boot " ++ host
+			, "./propellor --boot " ++ hn
 			]
 		, "fi"
 		]
@@ -218,18 +219,18 @@ spin host = do
 	
 	showremote s = putStrLn s
 	senddata toh f marker s = void $
-		actionMessage ("Sending " ++ f ++ " (" ++ show (length s) ++ " bytes) to " ++ host) $ do
+		actionMessage ("Sending " ++ f ++ " (" ++ show (length s) ++ " bytes) to " ++ hn) $ do
 			sendMarked toh marker s
 			return True
 
 sendGitClone :: HostName -> String -> IO ()
-sendGitClone host url = void $ actionMessage ("Pushing git repository to " ++ host) $ do
+sendGitClone hn url = void $ actionMessage ("Pushing git repository to " ++ hn) $ do
 	branch <- getCurrentBranch
-	cacheparams <- sshCachingParams host
+	cacheparams <- sshCachingParams hn
 	withTmpFile "propellor.git" $ \tmp _ -> allM id
 		[ boolSystem "git" [Param "bundle", Param "create", File tmp, Param "HEAD"]
-		, boolSystem "scp" $ cacheparams ++ [File tmp, Param ("root@"++host++":"++remotebundle)]
-		, boolSystem "ssh" $ cacheparams ++ [Param ("root@"++host), Param $ unpackcmd branch]
+		, boolSystem "scp" $ cacheparams ++ [File tmp, Param ("root@"++hn++":"++remotebundle)]
+		, boolSystem "ssh" $ cacheparams ++ [Param ("root@"++hn), Param $ unpackcmd branch]
 		]
   where
 	remotebundle = "/usr/local/propellor.git"
@@ -277,15 +278,15 @@ fromMarked marker s
 	len = length marker
 	matches = filter (marker `isPrefixOf`) $ lines s
 
-boot :: HostAttr -> [Property] -> IO ()
-boot hostattr ps = do
+boot :: Attr -> [Property] -> IO ()
+boot attr ps = do
 	sendMarked stdout statusMarker $ show Ready
 	reply <- hGetContentsStrict stdin
 
 	makePrivDataDir
 	maybe noop (writeFileProtected privDataLocal) $
 		fromMarked privDataMarker reply
-	mainProperties hostattr ps
+	mainProperties attr ps
 
 addKey :: String -> IO ()
 addKey keyid = exitBool =<< allM id [ gpg, gitadd, gitcommit ]
@@ -347,11 +348,11 @@ checkDebugMode = go =<< getEnv "PROPELLOR_DEBUG"
 
 -- Parameters can be passed to both ssh and scp.
 sshCachingParams :: HostName -> IO [CommandParam]
-sshCachingParams hostname = do
+sshCachingParams hn = do
 	home <- myHomeDir
 	let cachedir = home </> ".ssh" </> "propellor"
 	createDirectoryIfMissing False cachedir
-	let socketfile = cachedir </> hostname ++ ".sock"
+	let socketfile = cachedir </> hn ++ ".sock"
 	return
 		[ Param "-o", Param ("ControlPath=" ++ socketfile)
 		, Params "-o ControlMaster=auto -o ControlPersist=yes"
diff --git a/Propellor/Engine.hs b/Propellor/Engine.hs
index c527dc38..81d979ac 100644
--- a/Propellor/Engine.hs
+++ b/Propellor/Engine.hs
@@ -12,12 +12,12 @@ import Propellor.Types
 import Propellor.Message
 import Propellor.Exception
 
-runPropellor :: HostAttr -> Propellor a -> IO a
-runPropellor hostattr a = runReaderT (runWithHostAttr a) hostattr
+runPropellor :: Attr -> Propellor a -> IO a
+runPropellor attr a = runReaderT (runWithAttr a) attr
 
-mainProperties :: HostAttr -> [Property] -> IO ()
-mainProperties hostattr ps = do
-	r <- runPropellor hostattr $
+mainProperties :: Attr -> [Property] -> IO ()
+mainProperties attr ps = do
+	r <- runPropellor attr $
 		ensureProperties [Property "overall" $ ensureProperties ps]
 	setTitle "propellor: done"
 	hFlush stdout
diff --git a/Propellor/PrivData.hs b/Propellor/PrivData.hs
index 7f5a23dc..5adc9e94 100644
--- a/Propellor/PrivData.hs
+++ b/Propellor/PrivData.hs
@@ -12,6 +12,7 @@ import Control.Monad
 import "mtl" Control.Monad.Reader
 
 import Propellor.Types
+import Propellor.Attr
 import Propellor.Message
 import Utility.Monad
 import Utility.PartialPrelude
diff --git a/Propellor/Property.hs b/Propellor/Property.hs
index 7af69ea8..ccc060ff 100644
--- a/Propellor/Property.hs
+++ b/Propellor/Property.hs
@@ -9,6 +9,8 @@ import Control.Monad.IfElse
 import "mtl" Control.Monad.Reader
 
 import Propellor.Types
+import Propellor.Types.Attr
+import Propellor.Attr
 import Propellor.Engine
 import Utility.Monad
 
@@ -94,17 +96,46 @@ boolProperty desc a = Property desc $ ifM (liftIO a)
 revert :: RevertableProperty -> RevertableProperty
 revert (RevertableProperty p1 p2) = RevertableProperty p2 p1
 
--- | Starts a list of Properties
-props :: [Property]
-props = []
+-- | Starts accumulating the properties of a Host.
+--
+-- > host "example.com"
+-- > 	& someproperty
+-- > 	! oldproperty
+-- > 	& otherproperty
+host :: HostName -> Host
+host hn = Host [] (\_ -> newAttr hn)
+
+-- | Adds a property to a Host
+-- Can add Properties, RevertableProperties, and AttrProperties
+(&) :: IsProp p => Host -> p -> Host
+(Host ps as) & p = Host (ps ++ [toProp p]) (as . getAttr p)
 
--- | Adds a property to the list.
--- Can add both Properties and RevertableProperties.
-(&) :: IsProp p => [Property] -> p -> [Property]
-ps & p = ps ++ [toProp p]
 infixl 1 &
 
--- | Adds a property to the list in reverted form.
-(!) :: [Property] -> RevertableProperty -> [Property]
-ps ! p = ps ++ [toProp $ revert p]
+-- | Adds a property to the Host in reverted form.
+(!) :: Host -> RevertableProperty -> Host
+(Host ps as) ! p = Host (ps ++ [toProp q]) (as . getAttr q)
+  where
+	q = revert p
+
 infixl 1 !
+
+-- | Makes a propertyList of a set of properties, using the same syntax
+-- used by `host`.
+--
+-- > template "my template" $ props
+-- 	& someproperty
+-- 	! oldproperty
+--
+-- Note that none of the properties can define Attrs, because
+-- they will not propigate out to the host that this is added to.
+--
+-- Unfortunately, this is not currently enforced at the type level, so
+-- attempting to set an Attr in here will be run time error.
+template :: Desc -> Host -> Property
+template desc h@(Host ps _)
+	| hostAttr h == hostAttr props = propertyList desc ps
+	| otherwise = error $ desc ++ ": template contains Attr"
+
+props :: Host
+props = Host [] (\_ -> hostnameless)
diff --git a/Propellor/Property/Apt.hs b/Propellor/Property/Apt.hs
index 937d1404..4da13a2f 100644
--- a/Propellor/Property/Apt.hs
+++ b/Propellor/Property/Apt.hs
@@ -180,8 +180,8 @@ reConfigure package vals = reconfigure `requires` setselections
 	setselections = Property "preseed" $ makeChange $
 		withHandle StdinHandle createProcessSuccess
 			(proc "debconf-set-selections" []) $ \h -> do
-				forM_ vals $ \(template, tmpltype, value) ->
-					hPutStrLn h $ unwords [package, template, tmpltype, value]
+				forM_ vals $ \(tmpl, tmpltype, value) ->
+					hPutStrLn h $ unwords [package, tmpl, tmpltype, value]
 				hClose h
 	reconfigure = cmdProperty "dpkg-reconfigure" ["-fnone", package]
 
diff --git a/Propellor/Property/Hostname.hs b/Propellor/Property/Hostname.hs
index 0708b3ff..03613ac9 100644
--- a/Propellor/Property/Hostname.hs
+++ b/Propellor/Property/Hostname.hs
@@ -13,14 +13,14 @@ sane :: Property
 sane = Property ("sane hostname") (ensureProperty . setTo =<< getHostName)
 
 setTo :: HostName -> Property
-setTo hostname = combineProperties desc go
-	`onChange` cmdProperty "hostname" [host]
+setTo hn = combineProperties desc go
+	`onChange` cmdProperty "hostname" [basehost]
   where
-	desc = "hostname " ++ hostname
-	(host, domain) = separate (== '.') hostname
+	desc = "hostname " ++ hn
+	(basehost, domain) = separate (== '.') hn
 
 	go = catMaybes
-		[ Just $ "/etc/hostname" `File.hasContent` [host]
+		[ Just $ "/etc/hostname" `File.hasContent` [basehost]
 		, if null domain
 			then Nothing 
 			else Just $ File.fileProperty desc
@@ -28,7 +28,7 @@ setTo hostname = combineProperties desc go
 		]
 	
 	hostip = "127.0.1.1"
-	hostline = hostip ++ "\t" ++ hostname ++ " " ++ host
+	hostline = hostip ++ "\t" ++ hn ++ " " ++ basehost
 
 	addhostline ls = hostline : filter (not . hashostip) ls
 	hashostip l = headMaybe (words l) == Just hostip
diff --git a/Propellor/Property/SiteSpecific/JoeySites.hs b/Propellor/Property/SiteSpecific/JoeySites.hs
index 029064dd..46373170 100644
--- a/Propellor/Property/SiteSpecific/JoeySites.hs
+++ b/Propellor/Property/SiteSpecific/JoeySites.hs
@@ -6,8 +6,8 @@ module Propellor.Property.SiteSpecific.JoeySites where
 import Propellor
 import qualified Propellor.Property.Apt as Apt
 
-oldUseNetshellBox :: Property
-oldUseNetshellBox = check (not <$> Apt.isInstalled "oldusenet") $
+oldUseNetShellBox :: Property
+oldUseNetShellBox = check (not <$> Apt.isInstalled "oldusenet") $
 	propertyList ("olduse.net shellbox")
 		[ Apt.installed (words "build-essential devscripts debhelper git libncursesw5-dev libpcre3-dev pkg-config bison libicu-dev libidn11-dev libcanlock2-dev libuu-dev ghc libghc-strptime-dev libghc-hamlet-dev libghc-ifelse-dev libghc-hxt-dev libghc-utf8-string-dev libghc-missingh-dev libghc-sha-dev")
 			`describe` "olduse.net build deps"
diff --git a/Propellor/Types.hs b/Propellor/Types.hs
index 6a1c888a..e6e02126 100644
--- a/Propellor/Types.hs
+++ b/Propellor/Types.hs
@@ -1,7 +1,33 @@
 {-# LANGUAGE PackageImports #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE ExistentialQuantification #-}
 
-module Propellor.Types where
+module Propellor.Types
+	( Host(..)
+	, Attr
+	, HostName
+	, UserName
+	, GroupName
+	, Propellor(..)
+	, Property(..)
+	, RevertableProperty(..)
+	, AttrProperty(..)
+	, IsProp
+	, describe
+	, toProp
+	, getAttr
+	, requires
+	, Desc
+	, Result(..)
+	, System(..)
+	, Distribution(..)
+	, DebianSuite(..)
+	, Release
+	, Architecture
+	, ActionResult(..)
+	, CmdLine(..)
+	, PrivDataField(..)
+	) where
 
 import Data.Monoid
 import Control.Applicative
@@ -9,44 +35,39 @@ import System.Console.ANSI
 import "mtl" Control.Monad.Reader
 import "MonadCatchIO-transformers" Control.Monad.CatchIO
 
-type HostName = String
-type GroupName = String
-type UserName = String
+import Propellor.Types.Attr
 
--- | The core data type of Propellor, this reprecents a property
--- that the system should have, and an action to ensure it has the
--- property.
-data Property = Property
-	{ propertyDesc :: Desc
-	-- | must be idempotent; may run repeatedly
-	, propertySatisfy :: Propellor Result
-	}
+data Host = Host [Property] (Attr -> Attr)
 
--- | A property that can be reverted.
-data RevertableProperty = RevertableProperty Property Property
+type UserName = String
+type GroupName = String
 
 -- | Propellor's monad provides read-only access to attributes of the
 -- system.
-newtype Propellor p = Propellor { runWithHostAttr :: ReaderT HostAttr IO p }
+newtype Propellor p = Propellor { runWithAttr :: ReaderT Attr IO p }
 	deriving
 		( Monad
 		, Functor
 		, Applicative
-		, MonadReader HostAttr 
+		, MonadReader Attr 
 		, MonadIO
 		, MonadCatchIO
 		)
 
--- | The attributes of a system. For example, its hostname.
-newtype HostAttr = HostAttr
-	{ _hostname :: HostName
+-- | The core data type of Propellor, this represents a property
+-- that the system should have, and an action to ensure it has the
+-- property.
+data Property = Property
+	{ propertyDesc :: Desc
+	-- | must be idempotent; may run repeatedly
+	, propertySatisfy :: Propellor Result
 	}
 
-mkHostAttr :: HostName -> HostAttr
-mkHostAttr = HostAttr 
+-- | A property that can be reverted.
+data RevertableProperty = RevertableProperty Property Property
 
-getHostName :: Propellor HostName
-getHostName = asks _hostname
+-- | A property that affects the Attr.
+data AttrProperty = forall p. IsProp p => AttrProperty p (Attr -> Attr)
 
 class IsProp p where
 	-- | Sets description.
@@ -55,6 +76,7 @@ class IsProp p where
 	-- | Indicates that the first property can only be satisfied
 	-- once the second one is.
 	requires :: p -> Property -> p
+	getAttr :: p -> (Attr -> Attr)
 
 instance IsProp Property where
 	describe p d = p { propertyDesc = d }
@@ -64,6 +86,7 @@ instance IsProp Property where
 		case r of
 			FailedChange -> return FailedChange
 			_ -> propertySatisfy x
+	getAttr _ = id
 
 instance IsProp RevertableProperty where
 	-- | Sets the description of both sides.
@@ -72,6 +95,13 @@ instance IsProp RevertableProperty where
 	toProp (RevertableProperty p1 _) = p1
 	(RevertableProperty p1 p2) `requires` y =
 		RevertableProperty (p1 `requires` y) p2
+	getAttr _ = id
+
+instance IsProp AttrProperty where
+	describe (AttrProperty p a) d = AttrProperty (describe p d) a
+	toProp (AttrProperty p _) = toProp p
+	(AttrProperty p a) `requires` y = AttrProperty (p `requires` y) a
+	getAttr (AttrProperty _ a) = a
 
 type Desc = String
 
diff --git a/Propellor/Types/Attr.hs b/Propellor/Types/Attr.hs
new file mode 100644
index 00000000..20e5e631
--- /dev/null
+++ b/Propellor/Types/Attr.hs
@@ -0,0 +1,16 @@
+module Propellor.Types.Attr where
+
+import qualified Data.Set as S
+
+-- | The attributes of a host. For example, its hostname.
+data Attr = Attr
+	{ _hostname :: HostName
+	, _cnames :: S.Set Domain
+	}
+	deriving (Eq, Show)
+
+newAttr :: HostName -> Attr
+newAttr hn = Attr hn S.empty
+
+type HostName = String
+type Domain = String