Merge branch 'joeyconfig'

debian/changelog

@@ -30,6 +30,7 @@ propellor (1.1.0) UNRELEASED; urgency=medium
   * Run apt-cache policy with LANG=C so it works on other locales.
   * endAction can be used to register an action to run once propellor
     has successfully run on a host.
+  * Fixed privdata introspection for User.hasPassword and User.hasSomePassword
 
  -- Joey Hess <joeyh@debian.org>  Sat, 22 Nov 2014 00:12:35 -0400
 

src/Propellor.hs

@@ -36,6 +36,7 @@ module Propellor (
 	, module Propellor.Host
 	, module Propellor.Info
 	, module Propellor.PrivData
+	, module Propellor.Types.PrivData
 	, module Propellor.Engine
 	, module Propellor.Exception
 	, module Propellor.Message
@@ -49,6 +50,7 @@ import Propellor.Property
 import Propellor.Engine
 import Propellor.Property.Cmd
 import Propellor.PrivData
+import Propellor.Types.PrivData
 import Propellor.Message
 import Propellor.Exception
 import Propellor.Info

src/Propellor/PrivData.hs

@@ -15,6 +15,7 @@ import qualified Data.Map as M
 import qualified Data.Set as S
 
 import Propellor.Types
+import Propellor.Types.PrivData
 import Propellor.Message
 import Propellor.Info
 import Propellor.Gpg
@@ -30,7 +31,7 @@ import Utility.Env
 import Utility.Table
 
 -- | Allows a Property to access the value of a specific PrivDataField,
--- for use in a specific Context.
+-- for use in a specific Context or HostContext.
 --
 -- Example use:
 --
@@ -47,20 +48,26 @@ import Utility.Table
 -- being used, which is necessary to ensure that the privdata is sent to
 -- the remote host by propellor.
 withPrivData
-	:: PrivDataField
-	-> Context
+	:: IsContext c
+	=> PrivDataField
+	-> c
 	-> (((PrivData -> Propellor Result) -> Propellor Result) -> Property)
 	-> Property
-withPrivData field context@(Context cname) mkprop = addinfo $ mkprop $ \a ->
-	maybe missing a =<< liftIO (getLocalPrivData field context)
+withPrivData field c mkprop = addinfo $ mkprop $ \a ->
+	maybe missing a =<< get
   where
-	missing = liftIO $ do
+  	get = do
+		context <- mkHostContext hc <$> asks hostName
+		liftIO $ getLocalPrivData field context
+	missing = do
+		Context cname <- mkHostContext hc <$> asks hostName
 		warningMessage $ "Missing privdata " ++ show field ++ " (for " ++ cname ++ ")"
-		putStrLn $ "Fix this by running: propellor --set '" ++ show field ++ "' '" ++ cname ++ "'"
+		liftIO $ putStrLn $ "Fix this by running: propellor --set '" ++ show field ++ "' '" ++ cname ++ "'"
 		return FailedChange
-	addinfo p = p { propertyInfo = propertyInfo p <> mempty { _privDataFields = S.singleton (field, context) } }
+	addinfo p = p { propertyInfo = propertyInfo p <> mempty { _privDataFields = S.singleton (field, hc) } }
+	hc = asHostContext c
 
-addPrivDataField :: (PrivDataField, Context) -> Property
+addPrivDataField :: (PrivDataField, HostContext) -> Property
 addPrivDataField v = pureInfoProperty (show v) $
 	mempty { _privDataFields = S.singleton v }
 
@@ -78,7 +85,8 @@ type PrivMap = M.Map (PrivDataField, Context) PrivData
 filterPrivData :: Host -> PrivMap -> PrivMap
 filterPrivData host = M.filterWithKey (\k _v -> S.member k used)
   where
-	used = _privDataFields $ hostInfo host
+	used = S.map (\(f, c) -> (f, mkHostContext c (hostName host))) $
+		_privDataFields $ hostInfo host
 
 getPrivData :: PrivDataField -> Context -> PrivMap -> Maybe PrivData
 getPrivData field context = M.lookup (field, context)
@@ -119,7 +127,7 @@ listPrivDataFields hosts = do
 		, shellEscape context
 		, intercalate ", " $ sort $ fromMaybe [] $ M.lookup k usedby
 		]
-	mkhostmap host = M.fromList $ map (\k -> (k, [hostName host])) $
+	mkhostmap host = M.fromList $ map (\(f, c) -> ((f, mkHostContext c (hostName host)), [hostName host])) $
 		S.toList $ _privDataFields $ hostInfo host
 	usedby = M.unionsWith (++) $ map mkhostmap hosts
 	wantedmap = M.fromList $ zip (M.keys usedby) (repeat "")

src/Propellor/Property/Debootstrap.hs

@@ -93,9 +93,8 @@ built' installprop target system@(System _ arch) config =
 			, return FailedChange
 			)
 
-	teardownprop = property ("removed debootstrapped " ++ target) $ liftIO $ do
-		removetarget
-		return MadeChange
+	teardownprop = property ("removed debootstrapped " ++ target) $
+		makeChange removetarget
 
 	removetarget = do
 		submnts <- filter (\p -> simplifyPath p /= simplifyPath target)

src/Propellor/Property/File.hs

@@ -17,17 +17,17 @@ f `hasContent` newcontent = fileProperty ("replace " ++ f)
 --
 -- The file's permissions are preserved if the file already existed.
 -- Otherwise, they're set to 600.
-hasPrivContent :: FilePath -> Context -> Property
+hasPrivContent :: IsContext c => FilePath -> c -> Property
 hasPrivContent = hasPrivContent' writeFileProtected
 
 -- | Leaves the file at its default or current mode,
 -- allowing "private" data to be read.
 --
 -- Use with caution!
-hasPrivContentExposed :: FilePath -> Context -> Property
+hasPrivContentExposed :: IsContext c => FilePath -> c -> Property
 hasPrivContentExposed = hasPrivContent' writeFile
 
-hasPrivContent' :: (String -> FilePath -> IO ()) -> FilePath -> Context -> Property
+hasPrivContent' :: IsContext c => (String -> FilePath -> IO ()) -> FilePath -> c -> Property
 hasPrivContent' writer f context = 
 	withPrivData (PrivFile f) context $ \getcontent -> 
 		property desc $ getcontent $ \privcontent -> 

src/Propellor/Property/OpenId.hs

@@ -23,7 +23,7 @@ providerFor users baseurl = propertyList desc $
 			"define('SIMPLEID_BASE_URL', '"++url++"');"
 		| otherwise = l
 	
-	-- the identitites directory controls access, so open up
+	-- the identities directory controls access, so open up
 	-- file mode
 	identfile u = File.hasPrivContentExposed
 		(concat [ "/var/lib/simpleid/identities/", u, ".identity" ])

src/Propellor/Property/Ssh.hs

@@ -88,7 +88,7 @@ hostKeys ctx = propertyList "known ssh host keys"
 	]
 
 -- | Sets a single ssh host key from the privdata.
-hostKey :: SshKeyType -> Context -> Property
+hostKey :: IsContext c => SshKeyType -> c -> Property
 hostKey keytype context = combineProperties desc
 	[ installkey (SshPubKey keytype "")  (install writeFile ".pub")
 	, installkey (SshPrivKey keytype "") (install writeFileProtected "")
@@ -107,7 +107,7 @@ hostKey keytype context = combineProperties desc
 
 -- | Sets up a user with a ssh private key and public key pair from the
 -- PrivData.
-keyImported :: SshKeyType -> UserName -> Context -> Property
+keyImported :: IsContext c => SshKeyType -> UserName -> c -> Property
 keyImported keytype user context = combineProperties desc
 	[ installkey (SshPubKey keytype user) (install writeFile ".pub")
 	, installkey (SshPrivKey keytype user) (install writeFileProtected "")
@@ -158,7 +158,7 @@ knownHost hosts hn user = property desc $
 -- | Makes a user have authorized_keys from the PrivData
 --
 -- This removes any other lines from the file.
-authorizedKeys :: UserName -> Context -> Property
+authorizedKeys :: IsContext c => UserName -> c -> Property
 authorizedKeys user context = withPrivData (SshAuthorizedKeys user) context $ \get ->
 	property (user ++ " has authorized_keys") $ get $ \v -> do
 		f <- liftIO $ dotFile "authorized_keys" user

src/Propellor/Property/Systemd.hs

@@ -151,9 +151,8 @@ nspawnService (Container name _ _) cfg = RevertableProperty setup teardown
 		<$> servicefilecontent
 		<*> catchDefaultIO "" (readFile servicefile)
 
-	writeservicefile = property servicefile $ liftIO $ do
+	writeservicefile = property servicefile $ makeChange $
 		viaTmp writeFile servicefile =<< servicefilecontent
-		return MadeChange
 
 	setupservicefile = check (not <$> goodservicefile) $
 		-- if it's running, it has the wrong configuration,

src/Propellor/Property/Tor.hs

@@ -44,7 +44,7 @@ hiddenService hn port = mainConfig `File.containsLines`
 	`describe` unwords ["hidden service available:", hn, show port]
 	`onChange` restarted
 
-hiddenServiceData :: HiddenServiceName -> Context -> Property
+hiddenServiceData :: IsContext c => HiddenServiceName -> c -> Property
 hiddenServiceData hn context = combineProperties desc
 	[ installonion "hostname"
 	, installonion "private_key"

src/Propellor/Property/User.hs

@@ -25,30 +25,28 @@ nuked user _ = check (isJust <$> catchMaybeIO (homedir user)) $ cmdProperty "use
 -- | Only ensures that the user has some password set. It may or may
 -- not be the password from the PrivData.
 hasSomePassword :: UserName -> Property
-hasSomePassword user = property (user ++ "has password") $ do
-	hostname <- asks hostName
-	ensureProperty $ hasSomePassword' user (Context hostname)
+hasSomePassword user = hasSomePassword' user hostContext
 
 -- | While hasSomePassword uses the name of the host as context,
 -- this allows specifying a different context. This is useful when
 -- you want to use the same password on multiple hosts, for example.
-hasSomePassword' :: UserName -> Context -> Property
+hasSomePassword' :: IsContext c => UserName -> c -> Property
 hasSomePassword' user context = check ((/= HasPassword) <$> getPasswordStatus user) $
 	hasPassword' user context
 
 -- | Ensures that a user's password is set to the password from the PrivData.
 -- (Will change any existing password.)
 hasPassword :: UserName -> Property
-hasPassword user = property (user ++ "has password") $ do
-	hostname <- asks hostName
-	ensureProperty $ hasPassword' user (Context hostname)
+hasPassword user = hasPassword' user hostContext
 
-hasPassword' :: UserName -> Context -> Property
+hasPassword' :: IsContext c => UserName -> c -> Property
 hasPassword' user context = go `requires` shadowConfig True
   where
-	go = withPrivData (Password user) context $ \getpassword ->
-		property (user ++ " has password") $
-			getpassword $ \password -> makeChange $
+	go = withPrivData (Password user) context $
+		property (user ++ " has password") . setPassword user
+
+setPassword :: UserName -> ((PrivData -> Propellor Result) -> Propellor Result) -> Propellor Result
+setPassword user getpassword = getpassword $ \password -> makeChange $
 	withHandle StdinHandle createProcessSuccess
 		(proc "chpasswd" []) $ \h -> do
 			hPutStrLn h $ user ++ ":" ++ password

src/Propellor/Types.hs

@@ -165,7 +165,7 @@ data CmdLine
 -- | Information about a host.
 data Info = Info
 	{ _os :: Val System
-	, _privDataFields :: S.Set (PrivDataField, Context)
+	, _privDataFields :: S.Set (PrivDataField, HostContext)
 	, _sshPubKey :: Val String
 	, _aliases :: S.Set HostName
 	, _dns :: S.Set Dns.Record

src/Propellor/Types/PrivData.hs

@@ -15,7 +15,7 @@ data PrivDataField
 	| GpgKey
 	deriving (Read, Show, Ord, Eq)
 
--- | Context in which a PrivDataField is used.
+-- | A context in which a PrivDataField is used.
 --
 -- Often this will be a domain name. For example, 
 -- Context "www.example.com" could be used for the SSL cert
@@ -24,10 +24,39 @@ data PrivDataField
 newtype Context = Context String
 	deriving (Read, Show, Ord, Eq)
 
+-- | A context that varies depending on the HostName where it's used.
+newtype HostContext = HostContext { mkHostContext :: HostName -> Context }
+
+instance Show HostContext where
+	show hc = show $ mkHostContext hc "<hostname>"
+
+instance Ord HostContext where
+	a <= b = show a <= show b
+
+instance Eq HostContext where
+	a == b = show a == show b
+
+-- | Class of things that can be used as a Context.
+class IsContext c where
+	asContext :: HostName -> c -> Context
+	asHostContext :: c -> HostContext
+
+instance IsContext HostContext where
+	asContext = flip mkHostContext
+	asHostContext = id
+
+instance IsContext Context where
+	asContext _ c = c
+	asHostContext = HostContext . const
+
 -- | Use when a PrivDataField is not dependent on any paricular context.
 anyContext :: Context
 anyContext = Context "any"
 
+-- | Makes a HostContext that consists just of the hostname.
+hostContext :: HostContext
+hostContext = HostContext Context
+
 type PrivData = String
 
 data SshKeyType = SshRsa | SshDsa | SshEcdsa | SshEd25519