type-safe reversions

This commit is contained in:
Joey Hess 2014-04-02 12:13:39 -04:00
parent 7705f65ae2
commit 526bcbf093
10 changed files with 121 additions and 93 deletions

View File

@ -245,14 +245,14 @@ fromMarked marker s
matches = filter (marker `isPrefixOf`) $ lines s matches = filter (marker `isPrefixOf`) $ lines s
boot :: [Property] -> IO () boot :: [Property] -> IO ()
boot props = do boot ps = do
sendMarked stdout statusMarker $ show Ready sendMarked stdout statusMarker $ show Ready
reply <- hGetContentsStrict stdin reply <- hGetContentsStrict stdin
makePrivDataDir makePrivDataDir
maybe noop (writeFileProtected privDataLocal) $ maybe noop (writeFileProtected privDataLocal) $
fromMarked privDataMarker reply fromMarked privDataMarker reply
ensureProperties props ensureProperties ps
addKey :: String -> IO () addKey :: String -> IO ()
addKey keyid = exitBool =<< allM id [ gpg, gitadd, gitcommit ] addKey keyid = exitBool =<< allM id [ gpg, gitadd, gitcommit ]

View File

@ -58,14 +58,6 @@ property `onChange` hook = Property (propertyDesc property) $ do
return $ r <> r' return $ r <> r'
_ -> return 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 (==>) :: Desc -> Property -> Property
(==>) = flip describe (==>) = flip describe
infixl 1 ==> infixl 1 ==>
@ -76,3 +68,17 @@ check c property = Property (propertyDesc property) $ ifM c
( ensureProperty property ( ensureProperty property
, return NoChange , 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 &

View File

@ -129,9 +129,11 @@ autoRemove :: Property
autoRemove = runApt ["-y", "autoremove"] autoRemove = runApt ["-y", "autoremove"]
`describe` "apt autoremove" `describe` "apt autoremove"
unattendedUpgrades :: Bool -> Property -- | Enables unattended upgrades. Revert to disable.
unattendedUpgrades enabled = unattendedUpgrades :: RevertableProperty
(if enabled then installed else removed) ["unattended-upgrades"] unattendedUpgrades = RevertableProperty (go True) (go False)
where
go enabled = (if enabled then installed else removed) ["unattended-upgrades"]
`onChange` reConfigure "unattended-upgrades" `onChange` reConfigure "unattended-upgrades"
[("unattended-upgrades/enable_auto_updates" , "boolean", v)] [("unattended-upgrades/enable_auto_updates" , "boolean", v)]
`describe` ("unattended upgrades " ++ v) `describe` ("unattended upgrades " ++ v)

View File

@ -39,33 +39,27 @@ installed = Apt.installed ["docker.io"]
-- | Ensures that a docker container is set up and running. The container -- | Ensures that a docker container is set up and running. The container
-- has its own Properties which are handled by running propellor -- has its own Properties which are handled by running propellor
-- inside the container. -- inside the container.
--
-- Reverting this property ensures that the container is stopped and
-- removed.
docked docked
:: (HostName -> ContainerName -> Maybe (Container)) :: (HostName -> ContainerName -> Maybe (Container))
-> HostName -> HostName
-> ContainerName -> ContainerName
-> Property -> RevertableProperty
docked findc hn cn = findContainer findc hn cn $ docked findc hn cn = findContainer findc hn cn $
\(Container image containerprops) -> \(Container image containerprops) ->
provisionContainer cid let setup = provisionContainer cid
`requires` `requires`
runningContainer cid image containerprops runningContainer cid image containerprops
where teardown =
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) $ Property ("undocked " ++ fromContainerId cid) $
report <$> mapM id report <$> mapM id
[ stopContainer cid [ stopContainer cid
, removeContainer cid , removeContainer cid
, removeImage image , removeImage image
] ]
in RevertableProperty setup teardown
where where
cid = ContainerId hn cn cid = ContainerId hn cn
@ -73,15 +67,16 @@ findContainer
:: (HostName -> ContainerName -> Maybe (Container)) :: (HostName -> ContainerName -> Maybe (Container))
-> HostName -> HostName
-> ContainerName -> ContainerName
-> (Container -> Property) -> (Container -> RevertableProperty)
-> Property -> RevertableProperty
findContainer findc hn cn mk = case findc hn cn of findContainer findc hn cn mk = case findc hn cn of
Nothing -> containerDesc (ContainerId hn cn) $ Property "" $ do Nothing -> RevertableProperty cantfind cantfind
warningMessage $ "missing definition for docker container \"" ++ fromContainerId cid
return FailedChange
Just container -> mk container Just container -> mk container
where where
cid = ContainerId hn cn 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 -- | Causes *any* docker images that are not in use by running containers to
-- be deleted. And deletes any containers that propellor has set up -- be deleted. And deletes any containers that propellor has set up

View File

@ -12,6 +12,33 @@ data Property = Property
, propertySatisfy :: IO Result , 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 type Desc = String
data Result = NoChange | MadeChange | FailedChange data Result = NoChange | MadeChange | FailedChange
@ -74,3 +101,5 @@ data PrivDataField
| SshPrivKey UserName | SshPrivKey UserName
| Password UserName | Password UserName
deriving (Read, Show, Ord, Eq) deriving (Read, Show, Ord, Eq)

3
TODO
View File

@ -6,9 +6,6 @@
* --spin needs 4 ssh connections when bootstrapping a new host * --spin needs 4 ssh connections when bootstrapping a new host
that does not have the git repo yet. Should be possible to get that that does not have the git repo yet. Should be possible to get that
down to 1. 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. * Currently only Debian and derivatives are supported by most Properties.
One way to improve that would be to parameterize Properties with a One way to improve that would be to parameterize Properties with a
Distribution witness. Distribution witness.

View File

@ -2,7 +2,7 @@
-- the propellor program. -- the propellor program.
-- --
-- This is the live config file used by propellor's author. -- 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
import Propellor.CmdLine import Propellor.CmdLine
@ -31,33 +31,31 @@ main = defaultMain [host, Docker.containerProperties container]
-- --
-- Edit this to configure propellor! -- Edit this to configure propellor!
host :: HostName -> Maybe [Property] host :: HostName -> Maybe [Property]
host hostname@"clam.kitenet.net" = Just host hostname@"clam.kitenet.net" = Just $ props
[ cleanCloudAtCost hostname & cleanCloudAtCost hostname
, standardSystem Unstable & standardSystem Unstable
, Apt.unattendedUpgrades True & Apt.unattendedUpgrades
, Network.ipv6to4 & Network.ipv6to4
& Apt.installed ["git-annex", "mtr"]
-- Clam is a tor bridge, and an olduse.net shellbox and other -- Clam is a tor bridge, and an olduse.net shellbox and other
-- fun stuff. -- fun stuff.
, Tor.isBridge & Tor.isBridge
, JoeySites.oldUseNetshellBox & JoeySites.oldUseNetshellBox
, Docker.configured & Docker.configured
, File.dirExists "/var/www" & File.dirExists "/var/www"
--, Docker.docked container hostname "webserver" & revert (Docker.docked container hostname "webserver")
, Docker.garbageCollected & revert (Docker.docked container hostname "amd64-git-annex-builder")
, Docker.unDocked container hostname "amd64-git-annex-builder" & Docker.garbageCollected
, Apt.installed ["git-annex", "mtr"]
-- Should come last as it reboots. -- Should come last as it reboots.
, Apt.installed ["systemd-sysv"] `onChange` Reboot.now & Apt.installed ["systemd-sysv"] `onChange` Reboot.now
] host hostname@"orca.kitenet.net" = Just $ props
host hostname@"orca.kitenet.net" = Just & Hostname.set hostname
[ Hostname.set hostname & standardSystem Unstable
, standardSystem Unstable & Apt.unattendedUpgrades
, Apt.unattendedUpgrades True & Docker.configured
, Docker.configured & revert (Docker.docked container hostname "amd64-git-annex-builder")
, Docker.unDocked container hostname "amd64-git-annex-builder" & revert (Docker.docked container hostname "i386-git-annex-builder")
, Docker.unDocked container hostname "i386-git-annex-builder" & Docker.garbageCollected
, Docker.garbageCollected
]
-- add more hosts here... -- add more hosts here...
--host "foo.example.com" = --host "foo.example.com" =
host _ = Nothing host _ = Nothing
@ -70,16 +68,15 @@ container _host name
(image $ System (Debian Unstable) "amd64") (image $ System (Debian Unstable) "amd64")
[ Docker.publish "8080:80" [ Docker.publish "8080:80"
, Docker.volume "/var/www:/var/www" , Docker.volume "/var/www:/var/www"
, Docker.inside , Docker.inside $ props
[ serviceRunning "apache2" & serviceRunning "apache2"
`requires` Apt.installed ["apache2"] `requires` Apt.installed ["apache2"]
] ]
]
| "-git-annex-builder" `isSuffixOf` name = | "-git-annex-builder" `isSuffixOf` name =
let arch = takeWhile (/= '-') name let arch = takeWhile (/= '-') name
in Just $ Docker.containerFrom in Just $ Docker.containerFrom
(image $ System (Debian Unstable) arch) (image $ System (Debian Unstable) arch)
[ Docker.inside [ GitAnnexBuilder.builder arch "15 * * * *" ] ] [ Docker.inside $ props & GitAnnexBuilder.builder arch "15 * * * *" ]
| otherwise = Nothing | otherwise = Nothing
-- | Docker images I prefer to use. -- | Docker images I prefer to use.

5
debian/changelog vendored
View File

@ -7,5 +7,10 @@ propellor (0.2) UNRELEASED; urgency=low
to pull commits from git repositories not signed with that key. to pull commits from git repositories not signed with that key.
This allows propellor to be securely used with public, non-encrypted This allows propellor to be securely used with public, non-encrypted
git repositories without the possibility of MITM. 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 -- Joey Hess <joeyh@debian.org> Tue, 01 Apr 2014 15:05:00 -0400

View File

@ -17,7 +17,7 @@ Extra-Source-Files:
Makefile Makefile
debian/changelog debian/changelog
debian/README debian/README
config.hs.simple simple-config.hs
Synopsis: property-based host configuration management in haskell Synopsis: property-based host configuration management in haskell
Description: Description:
Propellor enures that the system it's run in satisfies a list of Propellor enures that the system it's run in satisfies a list of

View File

@ -23,19 +23,18 @@ main = defaultMain [host, Docker.containerProperties container]
-- --
-- Edit this to configure propellor! -- Edit this to configure propellor!
host :: HostName -> Maybe [Property] host :: HostName -> Maybe [Property]
host hostname@"mybox.example.com" = Just host hostname@"mybox.example.com" = Just $ props
[ Apt.stdSourcesList Unstable & Apt.stdSourcesList Unstable
`onChange` Apt.upgrade `onChange` Apt.upgrade
, Apt.unattendedUpgrades True & Apt.unattendedUpgrades
, Apt.installed ["etckeeper"] & Apt.installed ["etckeeper"]
, Apt.installed ["ssh"] & Apt.installed ["ssh"]
, User.hasSomePassword "root" & User.hasSomePassword "root"
, Network.ipv6to4 & Network.ipv6to4
, Docker.docked container hostname "webserver" & Docker.docked container hostname "webserver"
`requires` File.dirExists "/var/www" `requires` File.dirExists "/var/www"
, Docker.garbageCollected & Docker.garbageCollected
, Cron.runPropellor "30 * * * *" & Cron.runPropellor "30 * * * *"
]
-- add more hosts here... -- add more hosts here...
--host "foo.example.com" = --host "foo.example.com" =
host _ = Nothing host _ = Nothing
@ -44,12 +43,10 @@ host _ = Nothing
-- can vary by hostname where it's used, or be the same everywhere. -- can vary by hostname where it's used, or be the same everywhere.
container :: HostName -> Docker.ContainerName -> Maybe (Docker.Container) container :: HostName -> Docker.ContainerName -> Maybe (Docker.Container)
container _ "webserver" = Just $ Docker.containerFrom "joeyh/debian-unstable" container _ "webserver" = Just $ Docker.containerFrom "joeyh/debian-unstable"
(image $ System (Debian Unstable) "amd64")
[ Docker.publish "80:80" [ Docker.publish "80:80"
, Docker.volume "/var/www:/var/www" , Docker.volume "/var/www:/var/www"
, Docker.inside , Docker.inside $ props
[ serviceRunning "apache2" & serviceRunning "apache2"
`requires` Apt.installed ["apache2"] `requires` Apt.installed ["apache2"]
] ]
]
container _ _ = Nothing container _ _ = Nothing