summaryrefslogtreecommitdiff
path: root/Propellor/Property
diff options
context:
space:
mode:
Diffstat (limited to 'Propellor/Property')
-rw-r--r--Propellor/Property/Cmd.hs5
-rw-r--r--Propellor/Property/Docker.hs37
-rw-r--r--Propellor/Property/File.hs4
-rw-r--r--Propellor/Property/Scheduled.hs10
-rw-r--r--Propellor/Property/SiteSpecific/GitAnnexBuilder.hs5
-rw-r--r--Propellor/Property/SiteSpecific/GitHome.hs2
-rw-r--r--Propellor/Property/Ssh.hs2
-rw-r--r--Propellor/Property/Sudo.hs2
8 files changed, 36 insertions, 31 deletions
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))