Propellor monad is a Reader for HostAttr

So far, the hostname is only used to improve a message in withPrivData,
but I anticipate using HostAttr for a lot more.

Propellor.hs

@@ -1,3 +1,5 @@
+{-# LANGUAGE PackageImports #-}
+
 -- | Pulls in lots of useful modules for building and using Properties.
 -- 
 -- Propellor enures that the system it's run in satisfies a list of
@@ -31,6 +33,7 @@ module Propellor (
 	, module Propellor.Property.Cmd
 	, module Propellor.PrivData
 	, module Propellor.Engine
+	, module Propellor.Exception
 	, module Propellor.Message
 	, localdir
 
@@ -43,6 +46,7 @@ import Propellor.Engine
 import Propellor.Property.Cmd
 import Propellor.PrivData
 import Propellor.Message
+import Propellor.Exception
 
 import Utility.PartialPrelude as X
 import Utility.Process as X
@@ -62,6 +66,7 @@ import Control.Applicative as X
 import Control.Monad as X
 import Data.Monoid as X
 import Control.Monad.IfElse as X
+import "mtl" Control.Monad.Reader as X
 
 -- | This is where propellor installs itself when deploying a host.
 localdir :: FilePath

Propellor/CmdLine.hs

@@ -66,21 +66,23 @@ defaultMain getprops = do
 	go _ (Continue cmdline) = go False cmdline
 	go _ (Set host field) = setPrivData host field
 	go _ (AddKey keyid) = addKey keyid
-	go _ (Chain host) = withprops host $ \ps -> do
-		r <- ensureProperties' ps
+	go _ (Chain host) = withprops host $ \hostattr ps -> do
+		r <- runPropellor hostattr $ ensureProperties ps
 		putStrLn $ "\n" ++ show r
 	go _ (Docker host) = Docker.chain host
 	go True cmdline@(Spin _) = buildFirst cmdline $ go False cmdline
 	go True cmdline = updateFirst cmdline $ go False cmdline
-	go False (Spin host) = withprops host $ const $ spin host
+	go False (Spin host) = withprops host $ const . const $ spin host
 	go False (Run host) = ifM ((==) 0 <$> getRealUserID)
-		( onlyProcess $ withprops host ensureProperties
+		( onlyProcess $ withprops host mainProperties
 		, go True (Spin host)
 		)
 	go False (Boot host) = onlyProcess $ withprops host $ boot
 
-	withprops host a = maybe (unknownhost host) a $
+	withprops host a = maybe (unknownhost host) (a hostattr) $
 		headMaybe $ catMaybes $ map (\get -> get host) getprops
+	  where
+		hostattr = mkHostAttr host
 
 onlyProcess :: IO a -> IO a
 onlyProcess a = bracket lock unlock (const a)
@@ -275,15 +277,15 @@ fromMarked marker s
 	len = length marker
 	matches = filter (marker `isPrefixOf`) $ lines s
 
-boot :: [Property] -> IO ()
-boot ps = do
+boot :: HostAttr -> [Property] -> IO ()
+boot hostattr ps = do
 	sendMarked stdout statusMarker $ show Ready
 	reply <- hGetContentsStrict stdin
 
 	makePrivDataDir
 	maybe noop (writeFileProtected privDataLocal) $
 		fromMarked privDataMarker reply
-	ensureProperties ps
+	mainProperties hostattr ps
 
 addKey :: String -> IO ()
 addKey keyid = exitBool =<< allM id [ gpg, gitadd, gitcommit ]

Propellor/Engine.hs

@@ -1,30 +1,37 @@
+{-# LANGUAGE PackageImports #-}
+
 module Propellor.Engine where
 
 import System.Exit
 import System.IO
 import Data.Monoid
 import System.Console.ANSI
+import "mtl" Control.Monad.Reader
 
 import Propellor.Types
 import Propellor.Message
-import Utility.Exception
+import Propellor.Exception
 
-ensureProperty :: Property -> IO Result
-ensureProperty = catchDefaultIO FailedChange . propertySatisfy
+runPropellor :: HostAttr -> Propellor a -> IO a
+runPropellor hostattr a = runReaderT (runWithHostAttr a) hostattr
 
-ensureProperties :: [Property] -> IO ()
-ensureProperties ps = do
-	r <- ensureProperties' [Property "overall" $ ensureProperties' ps]
+mainProperties :: HostAttr -> [Property] -> IO ()
+mainProperties hostattr ps = do
+	r <- runPropellor hostattr $
+		ensureProperties [Property "overall" $ ensureProperties ps]
 	setTitle "propellor: done"
 	hFlush stdout
 	case r of
 		FailedChange -> exitWith (ExitFailure 1)
 		_ -> exitWith ExitSuccess
 
-ensureProperties' :: [Property] -> IO Result
-ensureProperties' ps = ensure ps NoChange
+ensureProperties :: [Property] -> Propellor Result
+ensureProperties ps = ensure ps NoChange
   where
 	ensure [] rs = return rs
 	ensure (l:ls) rs = do
 		r <- actionMessage (propertyDesc l) (ensureProperty l)
 		ensure ls (r <> rs)
+
+ensureProperty :: Property -> Propellor Result
+ensureProperty = catchPropellor . propertySatisfy

Propellor/Exception.hs

@@ -0,0 +1,16 @@
+{-# LANGUAGE PackageImports #-}
+
+module Propellor.Exception where
+
+import qualified "MonadCatchIO-transformers" Control.Monad.CatchIO as M
+import Control.Exception
+import Control.Applicative
+
+import Propellor.Types
+
+-- | Catches IO exceptions and returns FailedChange.
+catchPropellor :: Propellor Result -> Propellor Result
+catchPropellor a = either (\_ -> FailedChange) id <$> tryPropellor a
+
+tryPropellor :: Propellor a -> Propellor (Either IOException a)
+tryPropellor = M.try

Propellor/Message.hs

@@ -1,30 +1,35 @@
+{-# LANGUAGE PackageImports #-}
+
 module Propellor.Message where
 
 import System.Console.ANSI
 import System.IO
 import System.Log.Logger
+import "mtl" Control.Monad.Reader
 
 import Propellor.Types
 
 -- | Shows a message while performing an action, with a colored status
 -- display.
-actionMessage :: ActionResult r => Desc -> IO r -> IO r
+actionMessage :: (MonadIO m, ActionResult r) => Desc -> m r -> m r
 actionMessage desc a = do
-	setTitle $ "propellor: " ++ desc
-	hFlush stdout
+	liftIO $ do
+		setTitle $ "propellor: " ++ desc
+		hFlush stdout
 
 	r <- a
 
-	setTitle "propellor: running"
-	let (msg, intensity, color) = getActionResult r
-	putStr $ desc ++ " ... "
-	colorLine intensity color msg
-	hFlush stdout
+	liftIO $ do
+		setTitle "propellor: running"
+		let (msg, intensity, color) = getActionResult r
+		putStr $ desc ++ " ... "
+		colorLine intensity color msg
+		hFlush stdout
 
 	return r
 
-warningMessage :: String -> IO ()
-warningMessage s = colorLine Vivid Red $ "** warning: " ++ s
+warningMessage :: MonadIO m => String -> m ()
+warningMessage s = liftIO $ colorLine Vivid Red $ "** warning: " ++ s
 
 colorLine :: ColorIntensity -> Color -> String -> IO ()
 colorLine intensity color msg = do

Propellor/PrivData.hs

@@ -1,3 +1,5 @@
+{-# LANGUAGE PackageImports #-}
+
 module Propellor.PrivData where
 
 import qualified Data.Map as M
@@ -7,6 +9,7 @@ import System.IO
 import System.Directory
 import Data.Maybe
 import Control.Monad
+import "mtl" Control.Monad.Reader
 
 import Propellor.Types
 import Propellor.Message
@@ -18,13 +21,15 @@ import Utility.Tmp
 import Utility.SafeCommand
 import Utility.Misc
 
-withPrivData :: PrivDataField -> (String -> IO Result) -> IO Result
-withPrivData field a = maybe missing a =<< getPrivData field
+withPrivData :: PrivDataField -> (String -> Propellor Result) -> Propellor Result
+withPrivData field a = maybe missing a =<< liftIO (getPrivData field)
   where
 	missing = do
-		warningMessage $ "Missing privdata " ++ show field
-		putStrLn $ "Fix this by running: propellor --set $hostname '" ++ show field ++ "'"
-		return FailedChange
+		host <- getHostName
+		liftIO $ do
+			warningMessage $ "Missing privdata " ++ show field
+			putStrLn $ "Fix this by running: propellor --set "++host++" '" ++ show field ++ "'"
+			return FailedChange
 
 getPrivData :: PrivDataField -> IO (Maybe String)
 getPrivData field = do

Propellor/Property.hs

@@ -1,18 +1,21 @@
+{-# LANGUAGE PackageImports #-}
+
 module Propellor.Property where
 
 import System.Directory
 import Control.Monad
 import Data.Monoid
 import Control.Monad.IfElse
+import "mtl" Control.Monad.Reader
 
 import Propellor.Types
 import Propellor.Engine
 import Utility.Monad
 
-makeChange :: IO () -> IO Result
-makeChange a = a >> return MadeChange
+makeChange :: IO () -> Propellor Result
+makeChange a = liftIO a >> return MadeChange
 
-noChange :: IO Result
+noChange :: Propellor Result
 noChange = return NoChange
 
 -- | Combines a list of properties, resulting in a single property
@@ -20,7 +23,7 @@ noChange = return NoChange
 -- and print out the description of each as it's run. Does not stop
 -- on failure; does propigate overall success/failure.
 propertyList :: Desc -> [Property] -> Property
-propertyList desc ps = Property desc $ ensureProperties' ps
+propertyList desc ps = Property desc $ ensureProperties ps
 
 -- | Combines a list of properties, resulting in one property that
 -- ensures each in turn, stopping on failure.
@@ -49,12 +52,12 @@ p1 `before` p2 = Property (propertyDesc p1) $ do
 -- Use with caution.
 flagFile :: Property -> FilePath -> Property
 flagFile property flagfile = Property (propertyDesc property) $
-	go =<< doesFileExist flagfile
+	go =<< liftIO (doesFileExist flagfile)
   where
 	go True = return NoChange
 	go False = do
 		r <- ensureProperty property
-		when (r == MadeChange) $
+		when (r == MadeChange) $ liftIO $ 
 			unlessM (doesFileExist flagfile) $
 				writeFile flagfile ""
 		return r
@@ -76,13 +79,13 @@ infixl 1 ==>
 
 -- | Makes a Property only be performed when a test succeeds.
 check :: IO Bool -> Property -> Property
-check c property = Property (propertyDesc property) $ ifM c
+check c property = Property (propertyDesc property) $ ifM (liftIO c)
 	( ensureProperty property
 	, return NoChange
 	)
 
 boolProperty :: Desc -> IO Bool -> Property
-boolProperty desc a = Property desc $ ifM a
+boolProperty desc a = Property desc $ ifM (liftIO a)
 	( return MadeChange
 	, return FailedChange
 	)

Propellor/Property/Cmd.hs

@@ -1,3 +1,5 @@
+{-# LANGUAGE PackageImports #-}
+
 module Propellor.Property.Cmd (
 	cmdProperty,
 	cmdProperty',
@@ -7,6 +9,7 @@ module Propellor.Property.Cmd (
 
 import Control.Applicative
 import Data.List
+import "mtl" Control.Monad.Reader
 
 import Propellor.Types
 import Utility.Monad
@@ -22,7 +25,7 @@ cmdProperty cmd params = cmdProperty' cmd params []
 -- | A property that can be satisfied by running a command,
 -- with added environment.
 cmdProperty' :: String -> [String] -> [(String, String)] -> Property
-cmdProperty' cmd params env = Property desc $ do
+cmdProperty' cmd params env = Property desc $ liftIO $ do
 	env' <- addEntries env <$> getEnvironment
 	ifM (boolSystemEnv cmd (map Param params) (Just env'))
 		( return MadeChange

Propellor/Property/Docker.hs

@@ -53,7 +53,7 @@ docked findc hn cn = findContainer findc hn cn $
 		    teardown = combineProperties ("undocked " ++ fromContainerId cid)
 		    	[ stoppedContainer cid
 			, Property ("cleaned up " ++ fromContainerId cid) $
-				report <$> mapM id
+				liftIO $ report <$> mapM id
 					[ removeContainer cid
 					, removeImage image
 					]
@@ -74,7 +74,7 @@ findContainer findc hn cn mk = case findc hn cn of
   where
   	cid = ContainerId hn cn
 	cantfind = containerDesc (ContainerId hn cn) $ Property "" $ do
-		warningMessage $ "missing definition for docker container \"" ++ fromContainerId cid
+		liftIO $ warningMessage $ "missing definition for docker container \"" ++ fromContainerId cid
 		return FailedChange
 
 -- | Causes *any* docker images that are not in use by running containers to
@@ -90,9 +90,9 @@ garbageCollected = propertyList "docker garbage collected"
 	]
   where
 	gccontainers = Property "docker containers garbage collected" $
-		report <$> (mapM removeContainer =<< listContainers AllContainers)
+		liftIO $ report <$> (mapM removeContainer =<< listContainers AllContainers)
 	gcimages = Property "docker images garbage collected" $ do
-		report <$> (mapM removeImage =<< listImages)
+		liftIO $ report <$> (mapM removeImage =<< listImages)
 
 -- | Pass to defaultMain to add docker containers.
 -- You need to provide the function mapping from
@@ -239,19 +239,19 @@ containerDesc cid p = p `describe` desc
 
 runningContainer :: ContainerId -> Image -> [Containerized Property] -> Property
 runningContainer cid@(ContainerId hn cn) image containerprops = containerDesc cid $ Property "running" $ do
-	l <- listContainers RunningContainers
+	l <- liftIO $ listContainers RunningContainers
 	if cid `elem` l
 		then do
 			-- Check if the ident has changed; if so the
 			-- parameters of the container differ and it must
 			-- be restarted.
-			runningident <- getrunningident
+			runningident <- liftIO $ getrunningident
 			if runningident == Just ident
-				then return NoChange
+				then noChange
 				else do
-					void $ stopContainer cid
+					void $ liftIO $ stopContainer cid
 					restartcontainer
-		else ifM (elem cid <$> listContainers AllContainers)
+		else ifM (liftIO $ elem cid <$> listContainers AllContainers)
 			( restartcontainer
 			, go image
 			)
@@ -259,8 +259,8 @@ runningContainer cid@(ContainerId hn cn) image containerprops = containerDesc ci
 	ident = ContainerIdent image hn cn runps
 
 	restartcontainer = do
-		oldimage <- fromMaybe image <$> commitContainer cid
-		void $ removeContainer cid
+		oldimage <- liftIO $ fromMaybe image <$> commitContainer cid
+		void $ liftIO $ removeContainer cid
 		go oldimage
 
 	getrunningident :: IO (Maybe ContainerIdent)
@@ -280,10 +280,11 @@ runningContainer cid@(ContainerId hn cn) image containerprops = containerDesc ci
 		]
 	
 	go img = do
-		clearProvisionedFlag cid
-		createDirectoryIfMissing True (takeDirectory $ identFile cid)
-		shim <- Shim.setup (localdir </> "propellor") (localdir </> shimdir cid)
-		writeFile (identFile cid) (show ident)
+		liftIO $ do
+			clearProvisionedFlag cid
+			createDirectoryIfMissing True (takeDirectory $ identFile cid)
+		shim <- liftIO $ Shim.setup (localdir </> "propellor") (localdir </> shimdir cid)
+		liftIO $ writeFile (identFile cid) (show ident)
 		ensureProperty $ boolProperty "run" $ runContainer img
 			(runps ++ ["-i", "-d", "-t"])
 			[shim, "--docker", fromContainerId cid]
@@ -339,7 +340,7 @@ chain s = case toContainerId s of
 -- being run. So, retry connections to the client for up to
 -- 1 minute.
 provisionContainer :: ContainerId -> Property
-provisionContainer cid = containerDesc cid $ Property "provision" $ do
+provisionContainer cid = containerDesc cid $ Property "provision" $ liftIO $ do
 	let shim = Shim.file (localdir </> "propellor") (localdir </> shimdir cid)
 	r <- simpleShClientRetry 60 (namedPipe cid) shim params (go Nothing)
 	when (r /= FailedChange) $
@@ -372,8 +373,8 @@ stopContainer cid = boolSystem dockercmd [Param "stop", Param $ fromContainerId
 
 stoppedContainer :: ContainerId -> Property
 stoppedContainer cid = containerDesc cid $ Property desc $ 
-	ifM (elem cid <$> listContainers RunningContainers)
-		( cleanup `after` ensureProperty 
+	ifM (liftIO $ elem cid <$> listContainers RunningContainers)
+		( liftIO cleanup `after` ensureProperty 
 			(boolProperty desc $ stopContainer cid)
 		, return NoChange
 		)

Propellor/Property/File.hs

@@ -38,10 +38,10 @@ notPresent f = check (doesFileExist f) $ Property (f ++ " not present") $
 	makeChange $ nukeFile f
 
 fileProperty :: Desc -> ([Line] -> [Line]) -> FilePath -> Property
-fileProperty desc a f = Property desc $ go =<< doesFileExist f
+fileProperty desc a f = Property desc $ go =<< liftIO (doesFileExist f)
   where
 	go True = do
-		ls <- lines <$> readFile f
+		ls <- liftIO $ lines <$> readFile f
 		let ls' = a ls
 		if ls' == ls
 			then noChange

Propellor/Property/Scheduled.hs

@@ -20,13 +20,13 @@ import qualified Data.Map as M
 -- last run.
 period :: Property -> Recurrance -> Property
 period prop recurrance = Property desc $ do
-	lasttime <- getLastChecked (propertyDesc prop)
-	nexttime <- fmap startTime <$> nextTime schedule lasttime
-	t <- localNow
+	lasttime <- liftIO $ getLastChecked (propertyDesc prop)
+	nexttime <- liftIO $ fmap startTime <$> nextTime schedule lasttime
+	t <- liftIO localNow
 	if Just t >= nexttime
 		then do
 			r <- ensureProperty prop
-			setLastChecked t (propertyDesc prop)
+			liftIO $ setLastChecked t (propertyDesc prop)
 			return r
 		else noChange
   where
@@ -38,7 +38,7 @@ periodParse :: Property -> String -> Property
 periodParse prop s = case toRecurrance s of
 	Just recurrance -> period prop recurrance
 	Nothing -> Property "periodParse" $ do
-		warningMessage $ "failed periodParse: " ++ s
+		liftIO $ warningMessage $ "failed periodParse: " ++ s
 		noChange
 
 lastCheckedFile :: FilePath

Propellor/Property/SiteSpecific/GitAnnexBuilder.hs

@@ -44,12 +44,13 @@ builder arch crontimes rsyncupload = combineProperties "gitannexbuilder"
 		let f = homedir </> "rsyncpassword"
 		if rsyncupload 
 			then withPrivData (Password builduser) $ \p -> do
-				oldp <- catchDefaultIO "" $ readFileStrict f
+				oldp <- liftIO $ catchDefaultIO "" $
+					readFileStrict f
 				if p /= oldp
 					then makeChange $ writeFile f p
 					else noChange
 			else do
-				ifM (doesFileExist f)
+				ifM (liftIO $ doesFileExist f)
 					( noChange
 					, makeChange $ writeFile f "no password configured"
 					)

Propellor/Property/SiteSpecific/GitHome.hs

@@ -8,7 +8,7 @@ import Utility.SafeCommand
 -- | Clones Joey Hess's git home directory, and runs its fixups script.
 installedFor :: UserName -> Property
 installedFor user = check (not <$> hasGitDir user) $ 
-	Property ("githome " ++ user) (go =<< homedir user)
+	Property ("githome " ++ user) (go =<< liftIO (homedir user))
 		`requires` Apt.installed ["git"]
   where
  	go Nothing = noChange

Propellor/Property/Ssh.hs

@@ -53,7 +53,7 @@ uniqueHostKeys = flagFile prop "/etc/ssh/.unique_host_keys"
 	`onChange` restartSshd
   where
 	prop = Property "ssh unique host keys" $ do
-		void $ boolSystem "sh"
+		void $ liftIO $ boolSystem "sh"
 			[ Param "-c"
 			, Param "rm -f /etc/ssh/ssh_host_*"
 			]

Propellor/Property/Sudo.hs

@@ -13,7 +13,7 @@ enabledFor :: UserName -> Property
 enabledFor user = Property desc go `requires` Apt.installed ["sudo"]
   where
 	go = do
-		locked <- isLockedPassword user
+		locked <- liftIO $ isLockedPassword user
 		ensureProperty $
 			fileProperty desc
 				(modify locked . filter (wanted locked))

Propellor/Types.hs

@@ -1,20 +1,53 @@
+{-# LANGUAGE PackageImports #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+
 module Propellor.Types where
 
 import Data.Monoid
+import Control.Applicative
 import System.Console.ANSI
+import "mtl" Control.Monad.Reader
+import "MonadCatchIO-transformers" Control.Monad.CatchIO
 
 type HostName = String
 type GroupName = String
 type UserName = String
 
+-- | 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 :: IO Result
+	, propertySatisfy :: Propellor Result
 	}
 
+-- | A property that can be reverted.
 data RevertableProperty = RevertableProperty Property Property
 
+-- | Propellor's monad provides read-only access to attributes of the
+-- system.
+newtype Propellor a = Propellor { runWithHostAttr :: ReaderT HostAttr IO a }
+	deriving
+		( Monad
+		, Functor
+		, Applicative
+		, MonadReader HostAttr 
+		, MonadIO
+		, MonadCatchIO
+		)
+
+-- | The attributes of a system. For example, its hostname.
+newtype HostAttr = HostAttr
+	{ _hostname :: HostName
+	}
+
+mkHostAttr :: HostName -> HostAttr
+mkHostAttr = HostAttr 
+
+getHostName :: Propellor HostName
+getHostName = asks _hostname
+
 class IsProp p where
 	-- | Sets description.
 	describe :: p -> Desc -> p

debian/changelog

@@ -1,4 +1,4 @@
-propellor (0.2.4) UNRELEASED; urgency=medium
+propellor (0.3.0) UNRELEASED; urgency=medium
 
   * ipv6to4: Ensure interface is brought up automatically on boot.
   * Enabling unattended upgrades now ensures that cron is installed and
@@ -8,6 +8,8 @@ propellor (0.2.4) UNRELEASED; urgency=medium
   * Fix compilation on Debian stable.
   * Include security updates in sources.list for stable and testing.
   * Use ssh connection caching, especially when bootstrapping.
+  * Properties now run in a Propellor monad, which provides access to
+    attributes of the host.
 
  -- Joey Hess <joeyh@debian.org>  Tue, 08 Apr 2014 18:07:12 -0400
 

propellor.cabal

@@ -1,5 +1,5 @@
 Name: propellor
-Version: 0.2.3
+Version: 0.3.0
 Cabal-Version: >= 1.6
 License: GPL
 Maintainer: Joey Hess <joey@kitenet.net>
@@ -38,7 +38,8 @@ Executable propellor
   GHC-Options: -Wall
   Build-Depends: MissingH, directory, filepath, base >= 4.5, base < 5, 
    IfElse, process, bytestring, hslogger, unix-compat, ansi-terminal,
-   containers, network, async, time, QuickCheck
+   containers, network, async, time, QuickCheck, mtl,
+   MonadCatchIO-transformers
   
   if (! os(windows))
     Build-Depends: unix
@@ -48,7 +49,8 @@ Executable config
   GHC-Options: -Wall -threaded
   Build-Depends: MissingH, directory, filepath, base >= 4.5, base < 5, 
    IfElse, process, bytestring, hslogger, unix-compat, ansi-terminal,
-   containers, network, async, time, QuickCheck
+   containers, network, async, time, QuickCheck, mtl,
+   MonadCatchIO-transformers
 
   if (! os(windows))
     Build-Depends: unix
@@ -57,7 +59,8 @@ Library
   GHC-Options: -Wall
   Build-Depends: MissingH, directory, filepath, base >= 4.5, base < 5, 
    IfElse, process, bytestring, hslogger, unix-compat, ansi-terminal,
-   containers, network, async, time, QuickCheck
+   containers, network, async, time, QuickCheck, mtl,
+   MonadCatchIO-transformers
 
   if (! os(windows))
     Build-Depends: unix
@@ -88,6 +91,7 @@ Library
     Propellor.Message
     Propellor.PrivData
     Propellor.Engine
+    Propellor.Exception
     Propellor.Types
   Other-Modules:
     Propellor.CmdLine