summaryrefslogtreecommitdiff
path: root/Propellor
diff options
context:
space:
mode:
authorJoey Hess2014-04-02 12:13:39 -0400
committerJoey Hess2014-04-02 13:18:08 -0400
commit526bcbf093af665f316a0ba4d1a836786ab66dcf (patch)
treed4ceb9ec125587cfac37cb50c178fcc4624dcedf /Propellor
parent7705f65ae22f38989f404c77de4d661b652e692e (diff)
type-safe reversions
Diffstat (limited to 'Propellor')
-rw-r--r--Propellor/CmdLine.hs4
-rw-r--r--Propellor/Property.hs22
-rw-r--r--Propellor/Property/Apt.hs20
-rw-r--r--Propellor/Property/Docker.hs47
-rw-r--r--Propellor/Types.hs29
5 files changed, 77 insertions, 45 deletions
diff --git a/Propellor/CmdLine.hs b/Propellor/CmdLine.hs
index c267e7d4..d1a758ab 100644
--- a/Propellor/CmdLine.hs
+++ b/Propellor/CmdLine.hs
@@ -245,14 +245,14 @@ fromMarked marker s
matches = filter (marker `isPrefixOf`) $ lines s
boot :: [Property] -> IO ()
-boot props = do
+boot ps = do
sendMarked stdout statusMarker $ show Ready
reply <- hGetContentsStrict stdin
makePrivDataDir
maybe noop (writeFileProtected privDataLocal) $
fromMarked privDataMarker reply
- ensureProperties props
+ ensureProperties ps
addKey :: String -> IO ()
addKey keyid = exitBool =<< allM id [ gpg, gitadd, gitcommit ]
diff --git a/Propellor/Property.hs b/Propellor/Property.hs
index 2764d614..10a51530 100644
--- a/Propellor/Property.hs
+++ b/Propellor/Property.hs
@@ -58,14 +58,6 @@ property `onChange` hook = Property (propertyDesc property) $ do
return $ r <> r'
_ -> return r
--- | Indicates that the first property can only be satisfied once
--- the second is.
-requires :: Property -> Property -> Property
-x `requires` y = combineProperties (propertyDesc x) [y, x]
-
-describe :: Property -> Desc -> Property
-describe p d = p { propertyDesc = d }
-
(==>) :: Desc -> Property -> Property
(==>) = flip describe
infixl 1 ==>
@@ -76,3 +68,17 @@ check c property = Property (propertyDesc property) $ ifM c
( ensureProperty property
, return NoChange
)
+
+-- | Undoes the effect of a property.
+revert :: RevertableProperty -> RevertableProperty
+revert (RevertableProperty p1 p2) = RevertableProperty p2 p1
+
+-- | Starts a list of Properties
+props :: [Property]
+props = []
+
+-- | Adds a property to the list.
+-- Can add both Properties and RevertableProperties.
+(&) :: IsProp p => [Property] -> p -> [Property]
+ps & p = toProp p : ps
+infixl 1 &
diff --git a/Propellor/Property/Apt.hs b/Propellor/Property/Apt.hs
index 92e23b7e..0b8b8ab9 100644
--- a/Propellor/Property/Apt.hs
+++ b/Propellor/Property/Apt.hs
@@ -129,16 +129,18 @@ autoRemove :: Property
autoRemove = runApt ["-y", "autoremove"]
`describe` "apt autoremove"
-unattendedUpgrades :: Bool -> Property
-unattendedUpgrades enabled =
- (if enabled then installed else removed) ["unattended-upgrades"]
- `onChange` reConfigure "unattended-upgrades"
- [("unattended-upgrades/enable_auto_updates" , "boolean", v)]
- `describe` ("unattended upgrades " ++ v)
+-- | Enables unattended upgrades. Revert to disable.
+unattendedUpgrades :: RevertableProperty
+unattendedUpgrades = RevertableProperty (go True) (go False)
where
- v
- | enabled = "true"
- | otherwise = "false"
+ go enabled = (if enabled then installed else removed) ["unattended-upgrades"]
+ `onChange` reConfigure "unattended-upgrades"
+ [("unattended-upgrades/enable_auto_updates" , "boolean", v)]
+ `describe` ("unattended upgrades " ++ v)
+ where
+ v
+ | enabled = "true"
+ | otherwise = "false"
-- | Preseeds debconf values and reconfigures the package so it takes
-- effect.
diff --git a/Propellor/Property/Docker.hs b/Propellor/Property/Docker.hs
index d8b1027c..3f90d157 100644
--- a/Propellor/Property/Docker.hs
+++ b/Propellor/Property/Docker.hs
@@ -39,33 +39,27 @@ installed = Apt.installed ["docker.io"]
-- | Ensures that a docker container is set up and running. The container
-- has its own Properties which are handled by running propellor
-- inside the container.
+--
+-- Reverting this property ensures that the container is stopped and
+-- removed.
docked
:: (HostName -> ContainerName -> Maybe (Container))
-> HostName
-> ContainerName
- -> Property
+ -> RevertableProperty
docked findc hn cn = findContainer findc hn cn $
\(Container image containerprops) ->
- provisionContainer cid
- `requires`
- runningContainer cid image containerprops
- where
- cid = ContainerId hn cn
-
--- | Ensures that a docker container is no longer running.
-unDocked
- :: (HostName -> ContainerName -> Maybe (Container))
- -> HostName
- -> ContainerName
- -> Property
-unDocked findc hn cn = findContainer findc hn cn $
- \(Container image _containerprops) ->
- Property ("undocked " ++ fromContainerId cid) $
- report <$> mapM id
- [ stopContainer cid
- , removeContainer cid
- , removeImage image
- ]
+ let setup = provisionContainer cid
+ `requires`
+ runningContainer cid image containerprops
+ teardown =
+ Property ("undocked " ++ fromContainerId cid) $
+ report <$> mapM id
+ [ stopContainer cid
+ , removeContainer cid
+ , removeImage image
+ ]
+ in RevertableProperty setup teardown
where
cid = ContainerId hn cn
@@ -73,15 +67,16 @@ findContainer
:: (HostName -> ContainerName -> Maybe (Container))
-> HostName
-> ContainerName
- -> (Container -> Property)
- -> Property
+ -> (Container -> RevertableProperty)
+ -> RevertableProperty
findContainer findc hn cn mk = case findc hn cn of
- Nothing -> containerDesc (ContainerId hn cn) $ Property "" $ do
- warningMessage $ "missing definition for docker container \"" ++ fromContainerId cid
- return FailedChange
+ Nothing -> RevertableProperty cantfind cantfind
Just container -> mk container
where
cid = ContainerId hn cn
+ cantfind = containerDesc (ContainerId hn cn) $ Property "" $ do
+ warningMessage $ "missing definition for docker container \"" ++ fromContainerId cid
+ return FailedChange
-- | Causes *any* docker images that are not in use by running containers to
-- be deleted. And deletes any containers that propellor has set up
diff --git a/Propellor/Types.hs b/Propellor/Types.hs
index 1be56748..52c0c999 100644
--- a/Propellor/Types.hs
+++ b/Propellor/Types.hs
@@ -12,6 +12,33 @@ data Property = Property
, propertySatisfy :: IO Result
}
+data RevertableProperty = RevertableProperty Property Property
+
+class IsProp p where
+ -- | Sets description.
+ describe :: p -> Desc -> p
+ toProp :: p -> Property
+ -- | Indicates that the first property can only be satisfied
+ -- once the second one is.
+ requires :: p -> Property -> p
+
+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
+
+instance IsProp RevertableProperty where
+ -- | Sets the description of both sides.
+ describe (RevertableProperty p1 p2) d =
+ RevertableProperty (describe p1 d) (describe p2 ("not " ++ d))
+ toProp (RevertableProperty p1 _) = p1
+ (RevertableProperty p1 p2) `requires` y =
+ RevertableProperty (p1 `requires` y) p2
+
type Desc = String
data Result = NoChange | MadeChange | FailedChange
@@ -74,3 +101,5 @@ data PrivDataField
| SshPrivKey UserName
| Password UserName
deriving (Read, Show, Ord, Eq)
+
+