summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorJoey Hess2014-04-02 12:13:39 -0400
committerJoey Hess2014-04-02 13:18:08 -0400
commit526bcbf093af665f316a0ba4d1a836786ab66dcf (patch)
treed4ceb9ec125587cfac37cb50c178fcc4624dcedf
parent7705f65ae22f38989f404c77de4d661b652e692e (diff)
type-safe reversions
-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
-rw-r--r--TODO3
-rw-r--r--config.hs55
-rw-r--r--debian/changelog5
-rw-r--r--propellor.cabal2
-rw-r--r--simple-config.hs (renamed from config.hs.simple)27
10 files changed, 121 insertions, 93 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)
+
+
diff --git a/TODO b/TODO
index 60162a6c..018ec037 100644
--- a/TODO
+++ b/TODO
@@ -6,9 +6,6 @@
* --spin needs 4 ssh connections when bootstrapping a new host
that does not have the git repo yet. Should be possible to get that
down to 1.
-* Make a way to express that a Property can be reverted (ie, installing a
- packages reverses to removing it). Then `reverted property` can be
- used to disable old properties.
* Currently only Debian and derivatives are supported by most Properties.
One way to improve that would be to parameterize Properties with a
Distribution witness.
diff --git a/config.hs b/config.hs
index b212fda3..3ed28c26 100644
--- a/config.hs
+++ b/config.hs
@@ -2,7 +2,7 @@
-- the propellor program.
--
-- This is the live config file used by propellor's author.
--- For a simpler starting point, see config.hs.simple.
+-- For a simpler starting point, see simple-config.hs
import Propellor
import Propellor.CmdLine
@@ -31,33 +31,31 @@ main = defaultMain [host, Docker.containerProperties container]
--
-- Edit this to configure propellor!
host :: HostName -> Maybe [Property]
-host hostname@"clam.kitenet.net" = Just
- [ cleanCloudAtCost hostname
- , standardSystem Unstable
- , Apt.unattendedUpgrades True
- , Network.ipv6to4
+host hostname@"clam.kitenet.net" = Just $ props
+ & cleanCloudAtCost hostname
+ & standardSystem Unstable
+ & Apt.unattendedUpgrades
+ & Network.ipv6to4
+ & Apt.installed ["git-annex", "mtr"]
-- Clam is a tor bridge, and an olduse.net shellbox and other
-- fun stuff.
- , Tor.isBridge
- , JoeySites.oldUseNetshellBox
- , Docker.configured
- , File.dirExists "/var/www"
- --, Docker.docked container hostname "webserver"
- , Docker.garbageCollected
- , Docker.unDocked container hostname "amd64-git-annex-builder"
- , Apt.installed ["git-annex", "mtr"]
+ & Tor.isBridge
+ & JoeySites.oldUseNetshellBox
+ & Docker.configured
+ & File.dirExists "/var/www"
+ & revert (Docker.docked container hostname "webserver")
+ & revert (Docker.docked container hostname "amd64-git-annex-builder")
+ & Docker.garbageCollected
-- Should come last as it reboots.
- , Apt.installed ["systemd-sysv"] `onChange` Reboot.now
- ]
-host hostname@"orca.kitenet.net" = Just
- [ Hostname.set hostname
- , standardSystem Unstable
- , Apt.unattendedUpgrades True
- , Docker.configured
- , Docker.unDocked container hostname "amd64-git-annex-builder"
- , Docker.unDocked container hostname "i386-git-annex-builder"
- , Docker.garbageCollected
- ]
+ & Apt.installed ["systemd-sysv"] `onChange` Reboot.now
+host hostname@"orca.kitenet.net" = Just $ props
+ & Hostname.set hostname
+ & standardSystem Unstable
+ & Apt.unattendedUpgrades
+ & Docker.configured
+ & revert (Docker.docked container hostname "amd64-git-annex-builder")
+ & revert (Docker.docked container hostname "i386-git-annex-builder")
+ & Docker.garbageCollected
-- add more hosts here...
--host "foo.example.com" =
host _ = Nothing
@@ -70,16 +68,15 @@ container _host name
(image $ System (Debian Unstable) "amd64")
[ Docker.publish "8080:80"
, Docker.volume "/var/www:/var/www"
- , Docker.inside
- [ serviceRunning "apache2"
+ , Docker.inside $ props
+ & serviceRunning "apache2"
`requires` Apt.installed ["apache2"]
- ]
]
| "-git-annex-builder" `isSuffixOf` name =
let arch = takeWhile (/= '-') name
in Just $ Docker.containerFrom
(image $ System (Debian Unstable) arch)
- [ Docker.inside [ GitAnnexBuilder.builder arch "15 * * * *" ] ]
+ [ Docker.inside $ props & GitAnnexBuilder.builder arch "15 * * * *" ]
| otherwise = Nothing
-- | Docker images I prefer to use.
diff --git a/debian/changelog b/debian/changelog
index bbb7591e..d6bfdbbd 100644
--- a/debian/changelog
+++ b/debian/changelog
@@ -7,5 +7,10 @@ propellor (0.2) UNRELEASED; urgency=low
to pull commits from git repositories not signed with that key.
This allows propellor to be securely used with public, non-encrypted
git repositories without the possibility of MITM.
+ * Added support for type-safe reversions. Only some properties can be
+ reverted; the type checker will tell you if you try something that won't
+ work.
+ * New syntactic sugar for building a list of properties, including
+ revertable properties.
-- Joey Hess <joeyh@debian.org> Tue, 01 Apr 2014 15:05:00 -0400
diff --git a/propellor.cabal b/propellor.cabal
index c1997604..78207cc3 100644
--- a/propellor.cabal
+++ b/propellor.cabal
@@ -17,7 +17,7 @@ Extra-Source-Files:
Makefile
debian/changelog
debian/README
- config.hs.simple
+ simple-config.hs
Synopsis: property-based host configuration management in haskell
Description:
Propellor enures that the system it's run in satisfies a list of
diff --git a/config.hs.simple b/simple-config.hs
index 5e9f8c3c..5afbfca4 100644
--- a/config.hs.simple
+++ b/simple-config.hs
@@ -23,19 +23,18 @@ main = defaultMain [host, Docker.containerProperties container]
--
-- Edit this to configure propellor!
host :: HostName -> Maybe [Property]
-host hostname@"mybox.example.com" = Just
- [ Apt.stdSourcesList Unstable
+host hostname@"mybox.example.com" = Just $ props
+ & Apt.stdSourcesList Unstable
`onChange` Apt.upgrade
- , Apt.unattendedUpgrades True
- , Apt.installed ["etckeeper"]
- , Apt.installed ["ssh"]
- , User.hasSomePassword "root"
- , Network.ipv6to4
- , Docker.docked container hostname "webserver"
+ & Apt.unattendedUpgrades
+ & Apt.installed ["etckeeper"]
+ & Apt.installed ["ssh"]
+ & User.hasSomePassword "root"
+ & Network.ipv6to4
+ & Docker.docked container hostname "webserver"
`requires` File.dirExists "/var/www"
- , Docker.garbageCollected
- , Cron.runPropellor "30 * * * *"
- ]
+ & Docker.garbageCollected
+ & Cron.runPropellor "30 * * * *"
-- add more hosts here...
--host "foo.example.com" =
host _ = Nothing
@@ -44,12 +43,10 @@ host _ = Nothing
-- can vary by hostname where it's used, or be the same everywhere.
container :: HostName -> Docker.ContainerName -> Maybe (Docker.Container)
container _ "webserver" = Just $ Docker.containerFrom "joeyh/debian-unstable"
- (image $ System (Debian Unstable) "amd64")
[ Docker.publish "80:80"
, Docker.volume "/var/www:/var/www"
- , Docker.inside
- [ serviceRunning "apache2"
+ , Docker.inside $ props
+ & serviceRunning "apache2"
`requires` Apt.installed ["apache2"]
- ]
]
container _ _ = Nothing