From 25942fb0cca0ca90933026bf959506e099ff95a4 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Thu, 10 Apr 2014 17:22:32 -0400 Subject: 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/Property/Cmd.hs | 5 ++- Propellor/Property/Docker.hs | 37 +++++++++++----------- Propellor/Property/File.hs | 4 +-- Propellor/Property/Scheduled.hs | 10 +++--- Propellor/Property/SiteSpecific/GitAnnexBuilder.hs | 5 +-- Propellor/Property/SiteSpecific/GitHome.hs | 2 +- Propellor/Property/Ssh.hs | 2 +- Propellor/Property/Sudo.hs | 2 +- 8 files changed, 36 insertions(+), 31 deletions(-) (limited to 'Propellor/Property') diff --git a/Propellor/Property/Cmd.hs b/Propellor/Property/Cmd.hs index c715fd2a..875c1f9a 100644 --- a/Propellor/Property/Cmd.hs +++ b/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 diff --git a/Propellor/Property/Docker.hs b/Propellor/Property/Docker.hs index b573e641..1df34251 100644 --- a/Propellor/Property/Docker.hs +++ b/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 ) diff --git a/Propellor/Property/File.hs b/Propellor/Property/File.hs index 64dce66f..10dee75e 100644 --- a/Propellor/Property/File.hs +++ b/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 diff --git a/Propellor/Property/Scheduled.hs b/Propellor/Property/Scheduled.hs index 827c648c..8341765e 100644 --- a/Propellor/Property/Scheduled.hs +++ b/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 diff --git a/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs b/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs index 580a52dc..204a9ca7 100644 --- a/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs +++ b/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" ) diff --git a/Propellor/Property/SiteSpecific/GitHome.hs b/Propellor/Property/SiteSpecific/GitHome.hs index 482100ca..1ba56b94 100644 --- a/Propellor/Property/SiteSpecific/GitHome.hs +++ b/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 diff --git a/Propellor/Property/Ssh.hs b/Propellor/Property/Ssh.hs index 36766f56..59845f8f 100644 --- a/Propellor/Property/Ssh.hs +++ b/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_*" ] diff --git a/Propellor/Property/Sudo.hs b/Propellor/Property/Sudo.hs index 68b8d056..66ceb580 100644 --- a/Propellor/Property/Sudo.hs +++ b/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)) -- cgit v1.2.3