From 526bcbf093af665f316a0ba4d1a836786ab66dcf Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 2 Apr 2014 12:13:39 -0400 Subject: [PATCH] type-safe reversions --- Propellor/CmdLine.hs | 4 +- Propellor/Property.hs | 22 +++++++---- Propellor/Property/Apt.hs | 20 +++++----- Propellor/Property/Docker.hs | 47 +++++++++++------------- Propellor/Types.hs | 29 +++++++++++++++ TODO | 3 -- config.hs | 55 +++++++++++++--------------- debian/changelog | 5 +++ propellor.cabal | 2 +- config.hs.simple => simple-config.hs | 27 ++++++-------- 10 files changed, 121 insertions(+), 93 deletions(-) rename config.hs.simple => simple-config.hs (78%) diff --git a/Propellor/CmdLine.hs b/Propellor/CmdLine.hs index c267e7d..d1a758a 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 2764d61..10a5153 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 92e23b7..0b8b8ab 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 d8b1027..3f90d15 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 1be5674..52c0c99 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 60162a6..018ec03 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 b212fda..3ed28c2 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 bbb7591..d6bfdbb 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 Tue, 01 Apr 2014 15:05:00 -0400 diff --git a/propellor.cabal b/propellor.cabal index c199760..78207cc 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 similarity index 78% rename from config.hs.simple rename to simple-config.hs index 5e9f8c3..5afbfca 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