From 4e4fb9ab7ca13f5148c6d4b08f53f518429530a8 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Fri, 18 Apr 2014 03:59:06 -0400 Subject: get rid of AttrProperty Now both Property and RevertableProperty can influence Attr on their own. --- Propellor/Attr.hs | 17 ++++---- Propellor/Engine.hs | 2 +- Propellor/Property.hs | 26 ++++++------ Propellor/Property/Apt.hs | 6 +-- Propellor/Property/Cmd.hs | 2 +- Propellor/Property/Docker.hs | 49 ++++++++++------------ Propellor/Property/File.hs | 12 +++--- Propellor/Property/Git.hs | 2 +- Propellor/Property/Gpg.hs | 2 +- Propellor/Property/Hostname.hs | 2 +- Propellor/Property/Obnam.hs | 2 +- Propellor/Property/Postfix.hs | 2 +- Propellor/Property/Scheduled.hs | 4 +- Propellor/Property/Service.hs | 6 +-- Propellor/Property/SiteSpecific/GitAnnexBuilder.hs | 2 +- Propellor/Property/SiteSpecific/GitHome.hs | 6 +-- Propellor/Property/SiteSpecific/JoeySites.hs | 2 +- Propellor/Property/Ssh.hs | 16 +++---- Propellor/Property/Sudo.hs | 2 +- Propellor/Property/User.hs | 2 +- Propellor/Types.hs | 37 ++++++++-------- 21 files changed, 99 insertions(+), 102 deletions(-) (limited to 'Propellor') diff --git a/Propellor/Attr.hs b/Propellor/Attr.hs index 94376b0d..d4fb25d2 100644 --- a/Propellor/Attr.hs +++ b/Propellor/Attr.hs @@ -10,36 +10,35 @@ import qualified Data.Set as S import qualified Data.Map as M import Control.Applicative -pureAttrProperty :: Desc -> (Attr -> Attr) -> AttrProperty -pureAttrProperty desc = AttrProperty $ Property ("has " ++ desc) - (return NoChange) +pureAttrProperty :: Desc -> (Attr -> Attr) -> Property +pureAttrProperty desc = Property ("has " ++ desc) (return NoChange) -hostname :: HostName -> AttrProperty +hostname :: HostName -> Property hostname name = pureAttrProperty ("hostname " ++ name) $ \d -> d { _hostname = name } getHostName :: Propellor HostName getHostName = asks _hostname -os :: System -> AttrProperty +os :: System -> Property os system = pureAttrProperty ("Operating " ++ show system) $ \d -> d { _os = Just system } getOS :: Propellor (Maybe System) getOS = asks _os -cname :: Domain -> AttrProperty +cname :: Domain -> Property cname domain = pureAttrProperty ("cname " ++ domain) (addCName domain) -cnameFor :: IsProp p => Domain -> (Domain -> p) -> AttrProperty +cnameFor :: Domain -> (Domain -> Property) -> Property cnameFor domain mkp = let p = mkp domain - in AttrProperty p (addCName domain) + in p { propertyAttr = propertyAttr p . addCName domain } addCName :: HostName -> Attr -> Attr addCName domain d = d { _cnames = S.insert domain (_cnames d) } -sshPubKey :: String -> AttrProperty +sshPubKey :: String -> Property sshPubKey k = pureAttrProperty ("ssh pubkey known") $ \d -> d { _sshPubKey = Just k } diff --git a/Propellor/Engine.hs b/Propellor/Engine.hs index 81d979ac..c697d853 100644 --- a/Propellor/Engine.hs +++ b/Propellor/Engine.hs @@ -18,7 +18,7 @@ runPropellor attr a = runReaderT (runWithAttr a) attr mainProperties :: Attr -> [Property] -> IO () mainProperties attr ps = do r <- runPropellor attr $ - ensureProperties [Property "overall" $ ensureProperties ps] + ensureProperties [property "overall" $ ensureProperties ps] setTitle "propellor: done" hFlush stdout case r of diff --git a/Propellor/Property.hs b/Propellor/Property.hs index 5b1800ef..aa419069 100644 --- a/Propellor/Property.hs +++ b/Propellor/Property.hs @@ -26,12 +26,12 @@ 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. combineProperties :: Desc -> [Property] -> Property -combineProperties desc ps = Property desc $ go ps NoChange +combineProperties desc ps = property desc $ go ps NoChange where go [] rs = return rs go (l:ls) rs = do @@ -44,7 +44,7 @@ combineProperties desc ps = Property desc $ go ps NoChange -- that ensures the first, and if the first succeeds, ensures the second. -- The property uses the description of the first property. before :: Property -> Property -> Property -p1 `before` p2 = Property (propertyDesc p1) $ do +p1 `before` p2 = property (propertyDesc p1) $ do r <- ensureProperty p1 case r of FailedChange -> return FailedChange @@ -54,16 +54,16 @@ p1 `before` p2 = Property (propertyDesc p1) $ do -- file to indicate whether it has run before. -- Use with caution. flagFile :: Property -> FilePath -> Property -flagFile property = flagFile' property . return +flagFile p = flagFile' p . return flagFile' :: Property -> IO FilePath -> Property -flagFile' property getflagfile = Property (propertyDesc property) $ do +flagFile' p getflagfile = property (propertyDesc p) $ do flagfile <- liftIO getflagfile go flagfile =<< liftIO (doesFileExist flagfile) where go _ True = return NoChange go flagfile False = do - r <- ensureProperty property + r <- ensureProperty p when (r == MadeChange) $ liftIO $ unlessM (doesFileExist flagfile) $ do createDirectoryIfMissing True (takeDirectory flagfile) @@ -73,8 +73,8 @@ flagFile' property getflagfile = Property (propertyDesc property) $ do --- | Whenever a change has to be made for a Property, causes a hook -- Property to also be run, but not otherwise. onChange :: Property -> Property -> Property -property `onChange` hook = Property (propertyDesc property) $ do - r <- ensureProperty property +p `onChange` hook = property (propertyDesc p) $ do + r <- ensureProperty p case r of MadeChange -> do r' <- ensureProperty hook @@ -87,8 +87,8 @@ infixl 1 ==> -- | Makes a Property only be performed when a test succeeds. check :: IO Bool -> Property -> Property -check c property = Property (propertyDesc property) $ ifM (liftIO c) - ( ensureProperty property +check c p = property (propertyDesc p) $ ifM (liftIO c) + ( ensureProperty p , return NoChange ) @@ -99,7 +99,7 @@ check c property = Property (propertyDesc property) $ ifM (liftIO c) -- to be made as it is to just idempotently assure the property is -- satisfied. For example, chmodding a file. trivial :: Property -> Property -trivial p = Property (propertyDesc p) $ do +trivial p = property (propertyDesc p) $ do r <- ensureProperty p if r == MadeChange then return NoChange @@ -110,10 +110,10 @@ trivial p = Property (propertyDesc p) $ do -- -- Note that the operating system may not be declared for some hosts. withOS :: Desc -> (Maybe System -> Propellor Result) -> Property -withOS desc a = Property desc $ a =<< getOS +withOS desc a = property desc $ a =<< getOS boolProperty :: Desc -> IO Bool -> Property -boolProperty desc a = Property desc $ ifM (liftIO a) +boolProperty desc a = property desc $ ifM (liftIO a) ( return MadeChange , return FailedChange ) diff --git a/Propellor/Property/Apt.hs b/Propellor/Property/Apt.hs index d31e8b46..2115dc50 100644 --- a/Propellor/Property/Apt.hs +++ b/Propellor/Property/Apt.hs @@ -157,7 +157,7 @@ buildDepIn dir = go `requires` installedMin ["devscripts", "equivs"] -- | Package installation may fail becuse the archive has changed. -- Run an update in that case and retry. robustly :: Property -> Property -robustly p = Property (propertyDesc p) $ do +robustly p = property (propertyDesc p) $ do r <- ensureProperty p if r == FailedChange then ensureProperty $ p `requires` update @@ -210,7 +210,7 @@ reConfigure :: Package -> [(String, String, String)] -> Property reConfigure package vals = reconfigure `requires` setselections `describe` ("reconfigure " ++ package) where - setselections = Property "preseed" $ makeChange $ + setselections = property "preseed" $ makeChange $ withHandle StdinHandle createProcessSuccess (proc "debconf-set-selections" []) $ \h -> do forM_ vals $ \(tmpl, tmpltype, value) -> @@ -236,7 +236,7 @@ trustsKey k = RevertableProperty trust untrust desc = "apt trusts key " ++ keyname k f = "/etc/apt/trusted.gpg.d" keyname k ++ ".gpg" untrust = File.notPresent f - trust = check (not <$> doesFileExist f) $ Property desc $ makeChange $ do + trust = check (not <$> doesFileExist f) $ property desc $ makeChange $ do withHandle StdinHandle createProcessSuccess (proc "gpg" ["--no-default-keyring", "--keyring", f, "--import", "-"]) $ \h -> do hPutStr h (pubkey k) diff --git a/Propellor/Property/Cmd.hs b/Propellor/Property/Cmd.hs index 875c1f9a..5b7494ee 100644 --- a/Propellor/Property/Cmd.hs +++ b/Propellor/Property/Cmd.hs @@ -25,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 $ liftIO $ do +cmdProperty' cmd params env = property desc $ liftIO $ do env' <- addEntries env <$> getEnvironment ifM (boolSystemEnv cmd (map Param params) (Just env')) ( return MadeChange diff --git a/Propellor/Property/Docker.hs b/Propellor/Property/Docker.hs index d2555ea5..e05a8dd3 100644 --- a/Propellor/Property/Docker.hs +++ b/Propellor/Property/Docker.hs @@ -25,7 +25,7 @@ import Data.List.Utils -- | Configures docker with an authentication file, so that images can be -- pushed to index.docker.io. configured :: Property -configured = Property "docker configured" go `requires` installed +configured = property "docker configured" go `requires` installed where go = withPrivData DockerAuthentication $ \cfg -> ensureProperty $ "/root/.dockercfg" `File.hasContent` (lines cfg) @@ -64,7 +64,7 @@ docked -> RevertableProperty docked hosts cn = RevertableProperty (go "docked" setup) (go "undocked" teardown) where - go desc a = Property (desc ++ " " ++ cn) $ do + go desc a = property (desc ++ " " ++ cn) $ do hn <- getHostName let cid = ContainerId hn cn ensureProperties [findContainer hosts cid cn $ a cid] @@ -79,7 +79,7 @@ docked hosts cn = RevertableProperty (go "docked" setup) (go "undocked" teardown teardown cid (Container image _runparams) = combineProperties ("undocked " ++ fromContainerId cid) [ stoppedContainer cid - , Property ("cleaned up " ++ fromContainerId cid) $ + , property ("cleaned up " ++ fromContainerId cid) $ liftIO $ report <$> mapM id [ removeContainer cid , removeImage image @@ -96,7 +96,7 @@ findContainer hosts cid cn mk = case findHost hosts (cn2hn cn) of Nothing -> cantfind Just h -> maybe cantfind mk (mkContainer cid h) where - cantfind = containerDesc cid $ Property "" $ do + cantfind = containerDesc cid $ property "" $ do liftIO $ warningMessage $ "missing definition for docker container \"" ++ cn2hn cn return FailedChange @@ -126,9 +126,9 @@ garbageCollected = propertyList "docker garbage collected" , gcimages ] where - gccontainers = Property "docker containers garbage collected" $ + gccontainers = property "docker containers garbage collected" $ liftIO $ report <$> (mapM removeContainer =<< listContainers AllContainers) - gcimages = Property "docker images garbage collected" $ do + gcimages = property "docker images garbage collected" $ do liftIO $ report <$> (mapM removeImage =<< listImages) data Container = Container Image [RunParam] @@ -140,49 +140,49 @@ type RunParam = String type Image = String -- | Set custom dns server for container. -dns :: String -> AttrProperty +dns :: String -> Property dns = runProp "dns" -- | Set container host name. -hostname :: String -> AttrProperty +hostname :: String -> Property hostname = runProp "hostname" -- | Set name for container. (Normally done automatically.) -name :: String -> AttrProperty +name :: String -> Property name = runProp "name" -- | Publish a container's port to the host -- (format: ip:hostPort:containerPort | ip::containerPort | hostPort:containerPort) -publish :: String -> AttrProperty +publish :: String -> Property publish = runProp "publish" -- | Username or UID for container. -user :: String -> AttrProperty +user :: String -> Property user = runProp "user" -- | Mount a volume -- Create a bind mount with: [host-dir]:[container-dir]:[rw|ro] -- With just a directory, creates a volume in the container. -volume :: String -> AttrProperty +volume :: String -> Property volume = runProp "volume" -- | Mount a volume from the specified container into the current -- container. -volumes_from :: ContainerName -> AttrProperty +volumes_from :: ContainerName -> Property volumes_from cn = genProp "volumes-from" $ \hn -> fromContainerId (ContainerId hn cn) -- | Work dir inside the container. -workdir :: String -> AttrProperty +workdir :: String -> Property workdir = runProp "workdir" -- | Memory limit for container. --Format: , where unit = b, k, m or g -memory :: String -> AttrProperty +memory :: String -> Property memory = runProp "memory" -- | Link with another container on the same host. -link :: ContainerName -> ContainerAlias -> AttrProperty +link :: ContainerName -> ContainerAlias -> Property link linkwith alias = genProp "link" $ \hn -> fromContainerId (ContainerId hn linkwith) ++ ":" ++ alias @@ -230,7 +230,7 @@ containerDesc cid p = p `describe` desc desc = "[" ++ fromContainerId cid ++ "] " ++ propertyDesc p runningContainer :: ContainerId -> Image -> [RunParam] -> Property -runningContainer cid@(ContainerId hn cn) image runps = containerDesc cid $ Property "running" $ do +runningContainer cid@(ContainerId hn cn) image runps = containerDesc cid $ property "running" $ do l <- liftIO $ listContainers RunningContainers if cid `elem` l then do @@ -324,7 +324,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" $ liftIO $ 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) $ @@ -356,7 +356,7 @@ stopContainer :: ContainerId -> IO Bool stopContainer cid = boolSystem dockercmd [Param "stop", Param $ fromContainerId cid ] stoppedContainer :: ContainerId -> Property -stoppedContainer cid = containerDesc cid $ Property desc $ +stoppedContainer cid = containerDesc cid $ property desc $ ifM (liftIO $ elem cid <$> listContainers RunningContainers) ( liftIO cleanup `after` ensureProperty (boolProperty desc $ stopContainer cid) @@ -405,18 +405,15 @@ listContainers status = listImages :: IO [Image] listImages = lines <$> readProcess dockercmd ["images", "--all", "--quiet"] -runProp :: String -> RunParam -> AttrProperty -runProp field val = AttrProperty prop $ \attr -> +runProp :: String -> RunParam -> Property +runProp field val = pureAttrProperty (param) $ \attr -> attr { _dockerRunParams = _dockerRunParams attr ++ [\_ -> "--"++param] } where param = field++"="++val - prop = Property (param) (return NoChange) -genProp :: String -> (HostName -> RunParam) -> AttrProperty -genProp field mkval = AttrProperty prop $ \attr -> +genProp :: String -> (HostName -> RunParam) -> Property +genProp field mkval = pureAttrProperty field $ \attr -> attr { _dockerRunParams = _dockerRunParams attr ++ [\hn -> "--"++field++"=" ++ mkval hn] } - where - prop = Property field (return NoChange) -- | The ContainerIdent of a container is written to -- /.propellor-ident inside it. This can be checked to see if diff --git a/Propellor/Property/File.hs b/Propellor/Property/File.hs index 8f23dab7..0b060177 100644 --- a/Propellor/Property/File.hs +++ b/Propellor/Property/File.hs @@ -18,7 +18,7 @@ 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 -> Property -hasPrivContent f = Property desc $ withPrivData (PrivFile f) $ \privcontent -> +hasPrivContent f = property desc $ withPrivData (PrivFile f) $ \privcontent -> ensureProperty $ fileProperty' writeFileProtected desc (\_oldcontent -> lines privcontent) f where @@ -48,13 +48,13 @@ f `lacksLine` l = fileProperty (f ++ " remove: " ++ l) (filter (/= l)) f -- | Removes a file. Does not remove symlinks or non-plain-files. notPresent :: FilePath -> Property -notPresent f = check (doesFileExist f) $ Property (f ++ " not present") $ +notPresent f = check (doesFileExist f) $ property (f ++ " not present") $ makeChange $ nukeFile f fileProperty :: Desc -> ([Line] -> [Line]) -> FilePath -> Property fileProperty = fileProperty' writeFile fileProperty' :: (FilePath -> String -> IO ()) -> Desc -> ([Line] -> [Line]) -> FilePath -> Property -fileProperty' writer desc a f = Property desc $ go =<< liftIO (doesFileExist f) +fileProperty' writer desc a f = property desc $ go =<< liftIO (doesFileExist f) where go True = do ls <- liftIO $ lines <$> readFile f @@ -74,12 +74,12 @@ fileProperty' writer desc a f = Property desc $ go =<< liftIO (doesFileExist f) -- | Ensures a directory exists. dirExists :: FilePath -> Property -dirExists d = check (not <$> doesDirectoryExist d) $ Property (d ++ " exists") $ +dirExists d = check (not <$> doesDirectoryExist d) $ property (d ++ " exists") $ makeChange $ createDirectoryIfMissing True d -- | Ensures that a file/dir has the specified owner and group. ownerGroup :: FilePath -> UserName -> GroupName -> Property -ownerGroup f owner group = Property (f ++ " owner " ++ og) $ do +ownerGroup f owner group = property (f ++ " owner " ++ og) $ do r <- ensureProperty $ cmdProperty "chown" [og, f] if r == FailedChange then return r @@ -89,6 +89,6 @@ ownerGroup f owner group = Property (f ++ " owner " ++ og) $ do -- | Ensures that a file/dir has the specfied mode. mode :: FilePath -> FileMode -> Property -mode f v = Property (f ++ " mode " ++ show v) $ do +mode f v = property (f ++ " mode " ++ show v) $ do liftIO $ modifyFileMode f (\_old -> v) noChange diff --git a/Propellor/Property/Git.hs b/Propellor/Property/Git.hs index 1dae94bf..ba370e51 100644 --- a/Propellor/Property/Git.hs +++ b/Propellor/Property/Git.hs @@ -62,7 +62,7 @@ type Branch = String -- -- A branch can be specified, to check out. cloned :: UserName -> RepoUrl -> FilePath -> Maybe Branch -> Property -cloned owner url dir mbranch = check originurl (Property desc checkout) +cloned owner url dir mbranch = check originurl (property desc checkout) `requires` installed where desc = "git cloned " ++ url ++ " to " ++ dir diff --git a/Propellor/Property/Gpg.hs b/Propellor/Property/Gpg.hs index e23111bb..64ea9fea 100644 --- a/Propellor/Property/Gpg.hs +++ b/Propellor/Property/Gpg.hs @@ -21,7 +21,7 @@ installed = Apt.installed ["gnupg"] -- The GpgKeyId does not have to be a numeric id; it can just as easily -- be a description of the key. keyImported :: GpgKeyId -> UserName -> Property -keyImported keyid user = flagFile' (Property desc go) genflag +keyImported keyid user = flagFile' (property desc go) genflag `requires` installed where desc = user ++ " has gpg key " ++ show keyid diff --git a/Propellor/Property/Hostname.hs b/Propellor/Property/Hostname.hs index 30e0992d..031abb9d 100644 --- a/Propellor/Property/Hostname.hs +++ b/Propellor/Property/Hostname.hs @@ -9,7 +9,7 @@ import qualified Propellor.Property.File as File -- A FQDN also configures /etc/hosts, with an entry for 127.0.1.1, which is -- standard at least on Debian to set the FDQN (127.0.0.1 is localhost). sane :: Property -sane = Property ("sane hostname") (ensureProperty . setTo =<< getHostName) +sane = property ("sane hostname") (ensureProperty . setTo =<< getHostName) setTo :: HostName -> Property setTo hn = combineProperties desc go diff --git a/Propellor/Property/Obnam.hs b/Propellor/Property/Obnam.hs index 6fda218a..32374b57 100644 --- a/Propellor/Property/Obnam.hs +++ b/Propellor/Property/Obnam.hs @@ -65,7 +65,7 @@ backup dir crontimes params numclients = cronjob `describe` desc -- The restore is performed atomically; restoring to a temp directory -- and then moving it to the directory. restored :: FilePath -> [ObnamParam] -> Property -restored dir params = Property (dir ++ " restored by obnam") go +restored dir params = property (dir ++ " restored by obnam") go `requires` installed where go = ifM (liftIO needsRestore) diff --git a/Propellor/Property/Postfix.hs b/Propellor/Property/Postfix.hs index f4be27cf..9fa4a2c3 100644 --- a/Propellor/Property/Postfix.hs +++ b/Propellor/Property/Postfix.hs @@ -15,7 +15,7 @@ installed = Apt.serviceInstalledRunning "postfix" satellite :: Property satellite = setup `requires` installed where - setup = trivial $ Property "postfix satellite system" $ do + setup = trivial $ property "postfix satellite system" $ do hn <- getHostName ensureProperty $ Apt.reConfigure "postfix" [ ("postfix/main_mailer_type", "select", "Satellite system") diff --git a/Propellor/Property/Scheduled.hs b/Propellor/Property/Scheduled.hs index 769a3931..0e639129 100644 --- a/Propellor/Property/Scheduled.hs +++ b/Propellor/Property/Scheduled.hs @@ -19,7 +19,7 @@ import qualified Data.Map as M -- This uses the description of the Property to keep track of when it was -- last run. period :: Property -> Recurrance -> Property -period prop recurrance = Property desc $ do +period prop recurrance = property desc $ do lasttime <- liftIO $ getLastChecked (propertyDesc prop) nexttime <- liftIO $ fmap startTime <$> nextTime schedule lasttime t <- liftIO localNow @@ -37,7 +37,7 @@ period prop recurrance = Property desc $ do periodParse :: Property -> String -> Property periodParse prop s = case toRecurrance s of Just recurrance -> period prop recurrance - Nothing -> Property "periodParse" $ do + Nothing -> property "periodParse" $ do liftIO $ warningMessage $ "failed periodParse: " ++ s noChange diff --git a/Propellor/Property/Service.hs b/Propellor/Property/Service.hs index c6498e57..14e769d0 100644 --- a/Propellor/Property/Service.hs +++ b/Propellor/Property/Service.hs @@ -13,19 +13,19 @@ type ServiceName = String -- we can do is try to start the service, and if it fails, assume -- this means it's already running. running :: ServiceName -> Property -running svc = Property ("running " ++ svc) $ do +running svc = property ("running " ++ svc) $ do void $ ensureProperty $ scriptProperty ["service " ++ shellEscape svc ++ " start >/dev/null 2>&1 || true"] return NoChange restarted :: ServiceName -> Property -restarted svc = Property ("restarted " ++ svc) $ do +restarted svc = property ("restarted " ++ svc) $ do void $ ensureProperty $ scriptProperty ["service " ++ shellEscape svc ++ " restart >/dev/null 2>&1 || true"] return NoChange reloaded :: ServiceName -> Property -reloaded svc = Property ("reloaded " ++ svc) $ do +reloaded svc = property ("reloaded " ++ svc) $ do void $ ensureProperty $ scriptProperty ["service " ++ shellEscape svc ++ " reload >/dev/null 2>&1 || true"] return NoChange diff --git a/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs b/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs index 204a9ca7..677aa760 100644 --- a/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs +++ b/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs @@ -40,7 +40,7 @@ builder arch crontimes rsyncupload = combineProperties "gitannexbuilder" -- The builduser account does not have a password set, -- instead use the password privdata to hold the rsync server -- password used to upload the built image. - , Property "rsync password" $ do + , property "rsync password" $ do let f = homedir "rsyncpassword" if rsyncupload then withPrivData (Password builduser) $ \p -> do diff --git a/Propellor/Property/SiteSpecific/GitHome.hs b/Propellor/Property/SiteSpecific/GitHome.hs index ee46a9e4..6ed02146 100644 --- a/Propellor/Property/SiteSpecific/GitHome.hs +++ b/Propellor/Property/SiteSpecific/GitHome.hs @@ -8,16 +8,16 @@ 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 =<< liftIO (homedir user)) + property ("githome " ++ user) (go =<< liftIO (homedir user)) `requires` Apt.installed ["git"] where go home = do let tmpdir = home "githome" ensureProperty $ combineProperties "githome setup" [ userScriptProperty user ["git clone " ++ url ++ " " ++ tmpdir] - , Property "moveout" $ makeChange $ void $ + , property "moveout" $ makeChange $ void $ moveout tmpdir home - , Property "rmdir" $ makeChange $ void $ + , property "rmdir" $ makeChange $ void $ catchMaybeIO $ removeDirectory tmpdir , userScriptProperty user ["rm -rf .aptitude/ .bashrc .profile; bin/mr checkout; bin/fixups"] ] diff --git a/Propellor/Property/SiteSpecific/JoeySites.hs b/Propellor/Property/SiteSpecific/JoeySites.hs index 9b4587ba..c939ddce 100644 --- a/Propellor/Property/SiteSpecific/JoeySites.hs +++ b/Propellor/Property/SiteSpecific/JoeySites.hs @@ -30,7 +30,7 @@ oldUseNetServer hosts = propertyList ("olduse.net server") `requires` Ssh.keyImported SshRsa "root" `requires` Ssh.knownHost hosts "usw-s002.rsync.net" "root" , check (not . isSymbolicLink <$> getSymbolicLinkStatus newsspool) $ - Property "olduse.net spool in place" $ makeChange $ do + property "olduse.net spool in place" $ makeChange $ do removeDirectoryRecursive newsspool createSymbolicLink (datadir "news") newsspool , Apt.installed ["leafnode"] diff --git a/Propellor/Property/Ssh.hs b/Propellor/Property/Ssh.hs index a39792cf..a4f87678 100644 --- a/Propellor/Property/Ssh.hs +++ b/Propellor/Property/Ssh.hs @@ -67,7 +67,7 @@ randomHostKeys :: Property randomHostKeys = flagFile prop "/etc/ssh/.unique_host_keys" `onChange` restartSshd where - prop = Property "ssh random host keys" $ do + prop = property "ssh random host keys" $ do void $ liftIO $ boolSystem "sh" [ Param "-c" , Param "rm -f /etc/ssh/ssh_host_*" @@ -81,8 +81,8 @@ randomHostKeys = flagFile prop "/etc/ssh/.unique_host_keys" -- (Uses a null username for host keys.) hostKey :: SshKeyType -> Property hostKey keytype = combineProperties desc - [ Property desc (install writeFile (SshPubKey keytype "") ".pub") - , Property desc (install writeFileProtected (SshPrivKey keytype "") "") + [ property desc (install writeFile (SshPubKey keytype "") ".pub") + , property desc (install writeFileProtected (SshPrivKey keytype "") "") ] `onChange` restartSshd where @@ -98,8 +98,8 @@ hostKey keytype = combineProperties desc -- from the site's PrivData. keyImported :: SshKeyType -> UserName -> Property keyImported keytype user = combineProperties desc - [ Property desc (install writeFile (SshPubKey keytype user) ".pub") - , Property desc (install writeFileProtected (SshPrivKey keytype user) "") + [ property desc (install writeFile (SshPubKey keytype user) ".pub") + , property desc (install writeFileProtected (SshPrivKey keytype user) "") ] where desc = user ++ " has ssh key (" ++ fromKeyType keytype ++ ")" @@ -108,7 +108,7 @@ keyImported keytype user = combineProperties desc ifM (liftIO $ doesFileExist f) ( noChange , ensureProperty $ combineProperties desc - [ Property desc $ + [ property desc $ withPrivData p $ \key -> makeChange $ writer f key , File.ownerGroup f user user @@ -126,7 +126,7 @@ fromKeyType SshEd25519 = "ed25519" -- | Puts some host's ssh public key into the known_hosts file for a user. knownHost :: [Host] -> HostName -> UserName -> Property -knownHost hosts hn user = Property desc $ +knownHost hosts hn user = property desc $ go =<< fromHost hosts hn getSshPubKey where desc = user ++ " knows ssh key for " ++ hn @@ -143,7 +143,7 @@ knownHost hosts hn user = Property desc $ -- | Makes a user have authorized_keys from the PrivData authorizedKeys :: UserName -> Property -authorizedKeys user = Property (user ++ " has authorized_keys") $ +authorizedKeys user = property (user ++ " has authorized_keys") $ withPrivData (SshAuthorizedKeys user) $ \v -> do f <- liftIO $ dotFile "authorized_keys" user liftIO $ do diff --git a/Propellor/Property/Sudo.hs b/Propellor/Property/Sudo.hs index 66ceb580..68b56608 100644 --- a/Propellor/Property/Sudo.hs +++ b/Propellor/Property/Sudo.hs @@ -10,7 +10,7 @@ import Propellor.Property.User -- | Allows a user to sudo. If the user has a password, sudo is configured -- to require it. If not, NOPASSWORD is enabled for the user. enabledFor :: UserName -> Property -enabledFor user = Property desc go `requires` Apt.installed ["sudo"] +enabledFor user = property desc go `requires` Apt.installed ["sudo"] where go = do locked <- liftIO $ isLockedPassword user diff --git a/Propellor/Property/User.hs b/Propellor/Property/User.hs index 8e7afd81..eef2a57e 100644 --- a/Propellor/Property/User.hs +++ b/Propellor/Property/User.hs @@ -29,7 +29,7 @@ hasSomePassword user = check ((/= HasPassword) <$> getPasswordStatus user) $ hasPassword user hasPassword :: UserName -> Property -hasPassword user = Property (user ++ " has password") $ +hasPassword user = property (user ++ " has password") $ withPrivData (Password user) $ \password -> makeChange $ withHandle StdinHandle createProcessSuccess (proc "chpasswd" []) $ \h -> do diff --git a/Propellor/Types.hs b/Propellor/Types.hs index fc767cd2..01be9a5a 100644 --- a/Propellor/Types.hs +++ b/Propellor/Types.hs @@ -8,8 +8,8 @@ module Propellor.Types , HostName , Propellor(..) , Property(..) + , property , RevertableProperty(..) - , AttrProperty(..) , IsProp , describe , toProp @@ -53,16 +53,18 @@ newtype Propellor p = Propellor { runWithAttr :: ReaderT Attr IO p } -- property. data Property = Property { propertyDesc :: Desc - -- | must be idempotent; may run repeatedly , propertySatisfy :: Propellor Result + -- ^ must be idempotent; may run repeatedly + , propertyAttr :: Attr -> Attr + -- ^ a property can affect the overall Attr } +property :: Desc -> Propellor Result -> Property +property d s = Property d s id + -- | A property that can be reverted. data RevertableProperty = RevertableProperty Property Property --- | A property that affects the Attr. -data AttrProperty = forall p. IsProp p => AttrProperty p (Attr -> Attr) - class IsProp p where -- | Sets description. describe :: p -> Desc -> p @@ -75,12 +77,16 @@ class IsProp p where instance IsProp Property where describe p d = p { propertyDesc = d } toProp p = p - x `requires` y = Property (propertyDesc x) $ do - r <- propertySatisfy y - case r of - FailedChange -> return FailedChange - _ -> propertySatisfy x - getAttr _ = id + getAttr = propertyAttr + x `requires` y = Property (propertyDesc x) satisfy attr + where + attr = propertyAttr x . propertyAttr y + satisfy = do + r <- propertySatisfy y + case r of + FailedChange -> return FailedChange + _ -> propertySatisfy x + instance IsProp RevertableProperty where -- | Sets the description of both sides. @@ -89,13 +95,8 @@ 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 + -- | Gets the Attr of the currently active side. + getAttr (RevertableProperty p1 _p2) = getAttr p1 type Desc = String -- cgit v1.2.3