summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorJoey Hess2016-03-26 21:38:39 -0400
committerJoey Hess2016-03-26 21:38:39 -0400
commit46fc5467e633a9c1f149cb0cd7ee03af1e9e0aa1 (patch)
tree85d0136a1bc612a998259ab8690d20916d5ba704
parent530b0dde35e143df1ba8cb8f4828e0a3bc0b4ffb (diff)
ported docker
Also, implemented modifyHostProps to add properties to an existing host. Using it bypasses some type safety. Its use in docker is safe though. But, in Conductor, the use of it was not really safe, because it was used with a DebianLike property. Fixed that by making Ssh.installed target all unix's, although it will fail on non-DebianLike ones.
-rw-r--r--config-simple.hs7
-rw-r--r--src/Propellor/Container.hs6
-rw-r--r--src/Propellor/PropAccum.hs18
-rw-r--r--src/Propellor/Property/Chroot.hs2
-rw-r--r--src/Propellor/Property/Conductor.hs21
-rw-r--r--src/Propellor/Property/DiskImage.hs16
-rw-r--r--src/Propellor/Property/Docker.hs111
-rw-r--r--src/Propellor/Property/HostingProvider/CloudAtCost.hs33
-rw-r--r--src/Propellor/Property/Hostname.hs21
-rw-r--r--src/Propellor/Property/Ssh.hs9
10 files changed, 137 insertions, 107 deletions
diff --git a/config-simple.hs b/config-simple.hs
index 277e2edd..42b3d838 100644
--- a/config-simple.hs
+++ b/config-simple.hs
@@ -4,14 +4,8 @@
import Propellor
import qualified Propellor.Property.File as File
import qualified Propellor.Property.Apt as Apt
-import qualified Propellor.Property.Network as Network
---import qualified Propellor.Property.Ssh as Ssh
import qualified Propellor.Property.Cron as Cron
-import Propellor.Property.Scheduled
---import qualified Propellor.Property.Sudo as Sudo
import qualified Propellor.Property.User as User
---import qualified Propellor.Property.Hostname as Hostname
---import qualified Propellor.Property.Tor as Tor
main :: IO ()
main = defaultMain hosts
@@ -31,6 +25,5 @@ mybox = host "mybox.example.com" $ props
& Apt.installed ["etckeeper"]
& Apt.installed ["ssh"]
& User.hasSomePassword (User "root")
- & Network.ipv6to4
& File.dirExists "/var/www"
& Cron.runPropellor (Cron.Times "30 * * * *")
diff --git a/src/Propellor/Container.hs b/src/Propellor/Container.hs
index 6e974efd..832faf9c 100644
--- a/src/Propellor/Container.hs
+++ b/src/Propellor/Container.hs
@@ -7,11 +7,11 @@ import Propellor.Types.MetaTypes
import Propellor.Types.Info
import Propellor.PrivData
-class Container c where
+class IsContainer c where
containerProperties :: c -> [ChildProperty]
containerInfo :: c -> Info
-instance Container Host where
+instance IsContainer Host where
containerProperties = hostProperties
containerInfo = hostInfo
@@ -28,7 +28,7 @@ propagateContainer
-- Since the children being added probably have info,
-- require the Property's metatypes to have info.
( IncludesInfo metatypes ~ 'True
- , Container c
+ , IsContainer c
)
=> String
-> c
diff --git a/src/Propellor/PropAccum.hs b/src/Propellor/PropAccum.hs
index af362ca7..1212ef7a 100644
--- a/src/Propellor/PropAccum.hs
+++ b/src/Propellor/PropAccum.hs
@@ -12,6 +12,8 @@ module Propellor.PropAccum
, (&)
, (&^)
, (!)
+ , hostProps
+ , modifyHostProps
) where
import Propellor.Types
@@ -30,6 +32,16 @@ import Prelude
host :: HostName -> Props metatypes -> Host
host hn (Props ps) = Host hn ps (mconcat (map getInfoRecursive ps))
+-- | Note that the metatype of a Host's properties is not retained,
+-- so this defaults to UnixLike. So, using this with modifyHostProps can
+-- add properties to a Host that conflict with properties already in it.
+-- Use caution when using this.
+hostProps :: Host -> Props UnixLike
+hostProps = Props . hostProperties
+
+modifyHostProps :: Host -> Props metatypes -> Host
+modifyHostProps h ps = host (hostName h) ps
+
-- | Props is a combination of a list of properties, with their combined
-- metatypes.
data Props metatypes = Props [ChildProperty]
@@ -81,3 +93,9 @@ Props c &^ p = Props (toChildProperty p : c)
-> RevertableProperty (MetaTypes y) (MetaTypes z)
-> Props (MetaTypes (Combine x z))
Props c ! p = Props (c ++ [toChildProperty (revert p)])
+
+-- addPropsHost :: Host -> [Prop] -> Host
+-- addPropsHost (Host hn ps i) p = Host hn ps' i'
+-- where
+-- ps' = ps ++ [toChildProperty p]
+-- i' = i <> getInfoRecursive p
diff --git a/src/Propellor/Property/Chroot.hs b/src/Propellor/Property/Chroot.hs
index a0f3aca8..ddadc763 100644
--- a/src/Propellor/Property/Chroot.hs
+++ b/src/Propellor/Property/Chroot.hs
@@ -41,7 +41,7 @@ import System.Console.Concurrent
data Chroot where
Chroot :: ChrootBootstrapper b => FilePath -> b -> Host -> Chroot
-instance Container Chroot where
+instance IsContainer Chroot where
containerProperties (Chroot _ _ h) = containerProperties h
containerInfo (Chroot _ _ h) = containerInfo h
diff --git a/src/Propellor/Property/Conductor.hs b/src/Propellor/Property/Conductor.hs
index 8fe607bc..005fc804 100644
--- a/src/Propellor/Property/Conductor.hs
+++ b/src/Propellor/Property/Conductor.hs
@@ -83,7 +83,7 @@ import qualified Data.Set as S
-- | Class of things that can be conducted.
class Conductable c where
- conducts :: c -> RevertableProperty (HasInfo + DebianLike) (HasInfo + UnixLike)
+ conducts :: c -> RevertableProperty (HasInfo + UnixLike) (HasInfo + UnixLike)
instance Conductable Host where
-- | Conduct the specified host.
@@ -219,8 +219,8 @@ orchestrate hs = map go hs
os = extractOrchestras hs
removeold h = foldl removeold' h (oldconductorsof h)
- removeold' h oldconductor = addPropHost h $
- undoRevertableProperty $ conductedBy oldconductor
+ removeold' h oldconductor = modifyHostProps h $ hostProps h
+ ! conductedBy oldconductor
oldconductors = zip hs (map (fromInfo . hostInfo) hs)
oldconductorsof h = flip mapMaybe oldconductors $
@@ -233,22 +233,17 @@ orchestrate' :: Host -> Orchestra -> Host
orchestrate' h (Conducted _) = h
orchestrate' h (Conductor c l)
| sameHost h c = cont $ addConductorPrivData h (concatMap allHosts l)
- | any (sameHost h) (map topHost l) = cont $ addPropHost h $
- setupRevertableProperty $ conductedBy c
+ | any (sameHost h) (map topHost l) = cont $
+ modifyHostProps h $ hostProps h
+ & conductedBy c
| otherwise = cont h
where
cont h' = foldl orchestrate' h' l
-addPropHost :: Host -> Property i -> Host
-addPropHost (Host hn ps i) p = Host hn ps' i'
- where
- ps' = ps ++ [toChildProperty p]
- i' = i <> getInfoRecursive p
-
-- The host this property is added to becomes the conductor for the
-- specified Host. Note that `orchestrate` must be used for this property
-- to have any effect.
-conductorFor :: Host -> Property (HasInfo + DebianLike)
+conductorFor :: Host -> Property (HasInfo + UnixLike)
conductorFor h = go
`addInfoProperty` (toInfo (ConductorFor [h]))
`requires` setupRevertableProperty (conductorKnownHost h)
@@ -302,7 +297,7 @@ addConductorPrivData h hs = h { hostInfo = hostInfo h <> i }
privinfo h' = forceHostContext (hostName h') $ fromInfo (hostInfo h')
-- Use this property to let the specified conductor ssh in and run propellor.
-conductedBy :: Host -> RevertableProperty DebianLike UnixLike
+conductedBy :: Host -> RevertableProperty UnixLike UnixLike
conductedBy h = (setup <!> teardown)
`describe` ("conducted by " ++ hostName h)
where
diff --git a/src/Propellor/Property/DiskImage.hs b/src/Propellor/Property/DiskImage.hs
index 6200f856..48df7fab 100644
--- a/src/Propellor/Property/DiskImage.hs
+++ b/src/Propellor/Property/DiskImage.hs
@@ -76,16 +76,16 @@ type DiskImage = FilePath
-- chroot while the disk image is being built, which should prevent any
-- daemons that are included from being started on the system that is
-- building the disk image.
-imageBuilt :: DiskImage -> (FilePath -> Chroot) -> TableType -> Finalization -> [PartSpec] -> RevertableProperty HasInfo
+imageBuilt :: DiskImage -> (FilePath -> Chroot) -> TableType -> Finalization -> [PartSpec] -> RevertableProperty (HasInfo + Linux) Linux
imageBuilt = imageBuilt' False
-- | Like 'built', but the chroot is deleted and rebuilt from scratch each
-- time. This is more expensive, but useful to ensure reproducible results
-- when the properties of the chroot have been changed.
-imageRebuilt :: DiskImage -> (FilePath -> Chroot) -> TableType -> Finalization -> [PartSpec] -> RevertableProperty HasInfo
+imageRebuilt :: DiskImage -> (FilePath -> Chroot) -> TableType -> Finalization -> [PartSpec] -> RevertableProperty (HasInfo + Linux) Linux
imageRebuilt = imageBuilt' True
-imageBuilt' :: Bool -> DiskImage -> (FilePath -> Chroot) -> TableType -> Finalization -> [PartSpec] -> RevertableProperty HasInfo
+imageBuilt' :: Bool -> DiskImage -> (FilePath -> Chroot) -> TableType -> Finalization -> [PartSpec] -> RevertableProperty (HasInfo + Linux) Linux
imageBuilt' rebuild img mkchroot tabletype final partspec =
imageBuiltFrom img chrootdir tabletype final partspec
`requires` Chroot.provisioned chroot
@@ -109,7 +109,7 @@ imageBuilt' rebuild img mkchroot tabletype final partspec =
& Apt.cacheCleaned
-- | Builds a disk image from the contents of a chroot.
-imageBuiltFrom :: DiskImage -> FilePath -> TableType -> Finalization -> [PartSpec] -> RevertableProperty NoInfo
+imageBuiltFrom :: DiskImage -> FilePath -> TableType -> Finalization -> [PartSpec] -> RevertableProperty Linux Linux
imageBuiltFrom img chrootdir tabletype final partspec = mkimg <!> rmimg
where
desc = img ++ " built from " ++ chrootdir
@@ -135,7 +135,7 @@ imageBuiltFrom img chrootdir tabletype final partspec = mkimg <!> rmimg
imageFinalized final mnts mntopts devs parttable
rmimg = File.notPresent img
-partitionsPopulated :: FilePath -> [Maybe MountPoint] -> [MountOpts] -> [LoopDev] -> Property NoInfo
+partitionsPopulated :: FilePath -> [Maybe MountPoint] -> [MountOpts] -> [LoopDev] -> Property Linux
partitionsPopulated chrootdir mnts mntopts devs = property desc $ mconcat $ zipWith3 go mnts mntopts devs
where
desc = "partitions populated from " ++ chrootdir
@@ -203,7 +203,7 @@ getMountSz szm l (Just mntpt) =
-- If the file doesn't exist, or is too small, creates a new one, full of 0's.
--
-- If the file is too large, truncates it down to the specified size.
-imageExists :: FilePath -> ByteSize -> Property NoInfo
+imageExists :: FilePath -> ByteSize -> Property Linux
imageExists img sz = property ("disk image exists" ++ img) $ liftIO $ do
ms <- catchMaybeIO $ getFileStatus img
case ms of
@@ -226,9 +226,9 @@ imageExists img sz = property ("disk image exists" ++ img) $ liftIO $ do
--
-- It's ok if the second property leaves additional things mounted
-- in the partition tree.
-type Finalization = (Property NoInfo, (FilePath -> [LoopDev] -> Property NoInfo))
+type Finalization = (Property Linux, (FilePath -> [LoopDev] -> Property Linux))
-imageFinalized :: Finalization -> [Maybe MountPoint] -> [MountOpts] -> [LoopDev] -> PartTable -> Property NoInfo
+imageFinalized :: Finalization -> [Maybe MountPoint] -> [MountOpts] -> [LoopDev] -> PartTable -> Property Linux
imageFinalized (_, final) mnts mntopts devs (PartTable _ parts) =
property "disk image finalized" $
withTmpDir "mnt" $ \top ->
diff --git a/src/Propellor/Property/Docker.hs b/src/Propellor/Property/Docker.hs
index fe1e3b18..041e1987 100644
--- a/src/Propellor/Property/Docker.hs
+++ b/src/Propellor/Property/Docker.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE FlexibleContexts, TypeSynonymInstances, FlexibleInstances #-}
+{-# LANGUAGE FlexibleContexts, TypeSynonymInstances, FlexibleInstances, TypeFamilies #-}
-- | Docker support for propellor
--
@@ -50,6 +50,7 @@ import Propellor.Types.Docker
import Propellor.Types.Container
import Propellor.Types.CmdLine
import Propellor.Types.Info
+import Propellor.Container
import qualified Propellor.Property.File as File
import qualified Propellor.Property.Apt as Apt
import qualified Propellor.Property.Cmd as Cmd
@@ -71,11 +72,12 @@ installed = Apt.installed ["docker.io"]
-- | Configures docker with an authentication file, so that images can be
-- pushed to index.docker.io. Optional.
-configured :: Property DebianLike
+configured :: Property (HasInfo + DebianLike)
configured = prop `requires` installed
where
+ prop :: Property (HasInfo + DebianLike)
prop = withPrivData src anyContext $ \getcfg ->
- property "docker configured" $ getcfg $ \cfg -> ensureProperty $
+ property' "docker configured" $ \w -> getcfg $ \cfg -> ensureProperty w $
"/root/.dockercfg" `File.hasContent` privDataLines cfg
src = PrivDataSourceFileFromCommand DockerAuthentication
"/root/.dockercfg" "docker login"
@@ -88,6 +90,10 @@ type ContainerName = String
-- | A docker container.
data Container = Container Image Host
+instance IsContainer Container where
+ containerProperties (Container _ h) = containerProperties h
+ containerInfo (Container _ h) = containerInfo h
+
class HasImage a where
getImageName :: a -> Image
@@ -104,7 +110,7 @@ instance HasImage Container where
-- > & publish "80:80"
-- > & Apt.installed {"apache2"]
-- > & ...
-container :: ContainerName -> Image -> Props -> Container
+container :: ContainerName -> Image -> Props metatypes -> Container
container cn image (Props ps) = Container image (Host cn ps info)
where
info = dockerInfo mempty <> mconcat (map getInfoRecursive ps)
@@ -119,7 +125,7 @@ container cn image (Props ps) = Container image (Host cn ps info)
--
-- Reverting this property ensures that the container is stopped and
-- removed.
-docked :: Container -> RevertableProperty HasInfo
+docked :: Container -> RevertableProperty (HasInfo + Linux) (HasInfo + Linux)
docked ctr@(Container _ h) =
(propagateContainerInfo ctr (go "docked" setup))
<!>
@@ -127,11 +133,12 @@ docked ctr@(Container _ h) =
where
cn = hostName h
- go desc a = property (desc ++ " " ++ cn) $ do
+ go desc a = property' (desc ++ " " ++ cn) $ \w -> do
hn <- asks hostName
let cid = ContainerId hn cn
- ensureChildProperties [a cid (mkContainerInfo cid ctr)]
+ ensureProperty w $ a cid (mkContainerInfo cid ctr)
+ setup :: ContainerId -> ContainerInfo -> Property Linux
setup cid (ContainerInfo image runparams) =
provisionContainer cid
`requires`
@@ -139,8 +146,9 @@ docked ctr@(Container _ h) =
`requires`
installed
+ teardown :: ContainerId -> ContainerInfo -> Property Linux
teardown cid (ContainerInfo image _runparams) =
- combineProperties ("undocked " ++ fromContainerId cid)
+ combineProperties ("undocked " ++ fromContainerId cid) $ toProps
[ stoppedContainer cid
, property ("cleaned up " ++ fromContainerId cid) $
liftIO $ report <$> mapM id
@@ -151,31 +159,31 @@ docked ctr@(Container _ h) =
-- | Build the image from a directory containing a Dockerfile.
imageBuilt :: HasImage c => FilePath -> c -> Property Linux
-imageBuilt directory ctr = describe built msg
+imageBuilt directory ctr = built `describe` msg
where
msg = "docker image " ++ (imageIdentifier image) ++ " built from " ++ directory
- built = Cmd.cmdProperty' dockercmd ["build", "--tag", imageIdentifier image, "./"] workDir
- `assume` MadeChange
+ built :: Property Linux
+ built = tightenTargets $
+ Cmd.cmdProperty' dockercmd ["build", "--tag", imageIdentifier image, "./"] workDir
+ `assume` MadeChange
workDir p = p { cwd = Just directory }
image = getImageName ctr
-- | Pull the image from the standard Docker Hub registry.
imagePulled :: HasImage c => c -> Property Linux
-imagePulled ctr = describe pulled msg
+imagePulled ctr = pulled `describe` msg
where
msg = "docker image " ++ (imageIdentifier image) ++ " pulled"
- pulled = Cmd.cmdProperty dockercmd ["pull", imageIdentifier image]
- `assume` MadeChange
+ pulled :: Property Linux
+ pulled = tightenTargets $
+ Cmd.cmdProperty dockercmd ["pull", imageIdentifier image]
+ `assume` MadeChange
image = getImageName ctr
-propagateContainerInfo :: (IsProp (Property i)) => Container -> Property i -> Property (HasInfo + Linux)
-propagateContainerInfo ctr@(Container _ h) p = propagateContainer cn ctr p'
+propagateContainerInfo :: Container -> Property (HasInfo + Linux) -> Property (HasInfo + Linux)
+propagateContainerInfo ctr@(Container _ h) p = propagateContainer cn ctr $
+ p `addInfoProperty'` dockerinfo
where
- p' = infoProperty
- (getDesc p)
- (getSatisfy p)
- (getInfo p <> dockerinfo)
- (propertyChildren p)
dockerinfo = dockerInfo $
mempty { _dockerContainers = M.singleton cn h }
cn = hostName h
@@ -187,7 +195,7 @@ mkContainerInfo cid@(ContainerId hn _cn) (Container img h) =
runparams = map (\(DockerRunParam mkparam) -> mkparam hn)
(_dockerRunParams info)
info = fromInfo $ hostInfo h'
- h' = h
+ h' = modifyHostProps h $ hostProps h
-- Restart by default so container comes up on
-- boot or when docker is upgraded.
&^ restartAlways
@@ -209,8 +217,10 @@ garbageCollected = propertyList "docker garbage collected" $ props
& gccontainers
& gcimages
where
+ gccontainers :: Property Linux
gccontainers = property "docker containers garbage collected" $
liftIO $ report <$> (mapM removeContainer =<< listContainers AllContainers)
+ gcimages :: Property Linux
gcimages = property "docker images garbage collected" $
liftIO $ report <$> (mapM removeImage =<< listImages)
@@ -220,7 +230,7 @@ garbageCollected = propertyList "docker garbage collected" $ props
-- the pam config, to work around <https://github.com/docker/docker/issues/5663>
-- which affects docker 1.2.0.
tweaked :: Property Linux
-tweaked = cmdProperty "sh"
+tweaked = tightenTargets $ cmdProperty "sh"
[ "-c"
, "sed -ri 's/^session\\s+required\\s+pam_loginuid.so$/session optional pam_loginuid.so/' /etc/pam.d/*"
]
@@ -234,9 +244,10 @@ tweaked = cmdProperty "sh"
--
-- Only takes effect after reboot. (Not automated.)
memoryLimited :: Property DebianLike
-memoryLimited = "/etc/default/grub" `File.containsLine` cfg
- `describe` "docker memory limited"
- `onChange` (cmdProperty "update-grub" [] `assume` MadeChange)
+memoryLimited = tightenTargets $
+ "/etc/default/grub" `File.containsLine` cfg
+ `describe` "docker memory limited"
+ `onChange` (cmdProperty "update-grub" [] `assume` MadeChange)
where
cmdline = "cgroup_enable=memory swapaccount=1"
cfg = "GRUB_CMDLINE_LINUX_DEFAULT=\""++cmdline++"\""
@@ -294,15 +305,15 @@ instance ImageIdentifier ImageUID where
imageIdentifier (ImageUID uid) = uid
-- | Set custom dns server for container.
-dns :: String -> Property HasInfo
+dns :: String -> Property (HasInfo + Linux)
dns = runProp "dns"
-- | Set container host name.
-hostname :: String -> Property HasInfo
+hostname :: String -> Property (HasInfo + Linux)
hostname = runProp "hostname"
-- | Set name of container.
-name :: String -> Property HasInfo
+name :: String -> Property (HasInfo + Linux)
name = runProp "name"
class Publishable p where
@@ -316,15 +327,15 @@ instance Publishable String where
toPublish = id
-- | Publish a container's port to the host
-publish :: Publishable p => p -> Property HasInfo
+publish :: Publishable p => p -> Property (HasInfo + Linux)
publish = runProp "publish" . toPublish
-- | Expose a container's port without publishing it.
-expose :: String -> Property HasInfo
+expose :: String -> Property (HasInfo + Linux)
expose = runProp "expose"
-- | Username or UID for container.
-user :: String -> Property HasInfo
+user :: String -> Property (HasInfo + Linux)
user = runProp "user"
class Mountable p where
@@ -340,17 +351,17 @@ instance Mountable String where
toMount = id
-- | Mount a volume
-volume :: Mountable v => v -> Property HasInfo
+volume :: Mountable v => v -> Property (HasInfo + Linux)
volume = runProp "volume" . toMount
-- | Mount a volume from the specified container into the current
-- container.
-volumes_from :: ContainerName -> Property HasInfo
+volumes_from :: ContainerName -> Property (HasInfo + Linux)
volumes_from cn = genProp "volumes-from" $ \hn ->
fromContainerId (ContainerId hn cn)
-- | Work dir inside the container.
-workdir :: String -> Property HasInfo
+workdir :: String -> Property (HasInfo + Linux)
workdir = runProp "workdir"
-- | Memory limit for container.
@@ -358,18 +369,18 @@ workdir = runProp "workdir"
--
-- Note: Only takes effect when the host has the memoryLimited property
-- enabled.
-memory :: String -> Property HasInfo
+memory :: String -> Property (HasInfo + Linux)
memory = runProp "memory"
-- | CPU shares (relative weight).
--
-- By default, all containers run at the same priority, but you can tell
-- the kernel to give more CPU time to a container using this property.
-cpuShares :: Int -> Property HasInfo
+cpuShares :: Int -> Property (HasInfo + Linux)
cpuShares = runProp "cpu-shares" . show
-- | Link with another container on the same host.
-link :: ContainerName -> ContainerAlias -> Property HasInfo
+link :: ContainerName -> ContainerAlias -> Property (HasInfo + Linux)
link linkwith calias = genProp "link" $ \hn ->
fromContainerId (ContainerId hn linkwith) ++ ":" ++ calias
@@ -381,24 +392,24 @@ type ContainerAlias = String
-- propellor; as well as keeping badly behaved containers running,
-- it ensures that containers get started back up after reboot or
-- after docker is upgraded.
-restartAlways :: Property HasInfo
+restartAlways :: Property (HasInfo + Linux)
restartAlways = runProp "restart" "always"
-- | Docker will restart the container if it exits nonzero.
-- If a number is provided, it will be restarted only up to that many
-- times.
-restartOnFailure :: Maybe Int -> Property HasInfo
+restartOnFailure :: Maybe Int -> Property (HasInfo + Linux)
restartOnFailure Nothing = runProp "restart" "on-failure"
restartOnFailure (Just n) = runProp "restart" ("on-failure:" ++ show n)
-- | Makes docker not restart a container when it exits
-- Note that this includes not restarting it on boot!
-restartNever :: Property HasInfo
+restartNever :: Property (HasInfo + Linux)
restartNever = runProp "restart" "no"
-- | Set environment variable with a tuple composed by the environment
-- variable name and its value.
-environment :: (String, String) -> Property HasInfo
+environment :: (String, String) -> Property (HasInfo + Linux)
environment (k, v) = runProp "env" $ k ++ "=" ++ v
-- | A container is identified by its name, and the host
@@ -501,6 +512,7 @@ runningContainer cid@(ContainerId hn cn) image runps = containerDesc cid $ prope
retry (n-1) a
_ -> return v
+ go :: ImageIdentifier i => i -> Propellor Result
go img = liftIO $ do
clearProvisionedFlag cid
createDirectoryIfMissing True (takeDirectory $ identFile cid)
@@ -592,14 +604,15 @@ startContainer :: ContainerId -> IO Bool
startContainer cid = boolSystem dockercmd [Param "start", Param $ fromContainerId cid ]
stoppedContainer :: ContainerId -> Property Linux
-stoppedContainer cid = containerDesc cid $ property' desc $ \o ->
+stoppedContainer cid = containerDesc cid $ property' desc $ \w ->
ifM (liftIO $ elem cid <$> listContainers RunningContainers)
- ( liftIO cleanup `after` ensureProperty o
- (property desc $ liftIO $ toResult <$> stopContainer cid)
+ ( liftIO cleanup `after` ensureProperty w stop
, return NoChange
)
where
desc = "stopped"
+ stop :: Property Linux
+ stop = property desc $ liftIO $ toResult <$> stopContainer cid
cleanup = do
nukeFile $ identFile cid
removeDirectoryRecursive $ shimdir cid
@@ -643,14 +656,14 @@ listContainers status =
listImages :: IO [ImageUID]
listImages = map ImageUID . lines <$> readProcess dockercmd ["images", "--all", "--quiet"]
-runProp :: String -> RunParam -> Property HasInfo
-runProp field val = pureInfoProperty (param) $
+runProp :: String -> RunParam -> Property (HasInfo + Linux)
+runProp field val = tightenTargets $ pureInfoProperty (param) $
mempty { _dockerRunParams = [DockerRunParam (\_ -> "--"++param)] }
where
param = field++"="++val
-genProp :: String -> (HostName -> RunParam) -> Property HasInfo
-genProp field mkval = pureInfoProperty field $
+genProp :: String -> (HostName -> RunParam) -> Property (HasInfo + Linux)
+genProp field mkval = tightenTargets $ pureInfoProperty field $
mempty { _dockerRunParams = [DockerRunParam (\hn -> "--"++field++"=" ++ mkval hn)] }
dockerInfo :: DockerInfo -> Info
diff --git a/src/Propellor/Property/HostingProvider/CloudAtCost.hs b/src/Propellor/Property/HostingProvider/CloudAtCost.hs
index bfe3ae17..5c4788e2 100644
--- a/src/Propellor/Property/HostingProvider/CloudAtCost.hs
+++ b/src/Propellor/Property/HostingProvider/CloudAtCost.hs
@@ -6,19 +6,24 @@ import qualified Propellor.Property.File as File
import qualified Propellor.Property.User as User
-- Clean up a system as installed by cloudatcost.com
-decruft :: Property NoInfo
-decruft = propertyList "cloudatcost cleanup"
- [ Hostname.sane
- , "worked around grub/lvm boot bug #743126" ==>
+decruft :: Property DebianLike
+decruft = propertyList "cloudatcost cleanup" $ props
+ & Hostname.sane
+ & grubbugfix
+ & nukecruft
+ where
+ grubbugfix :: Property DebianLike
+ grubbugfix = tightenTargets $
"/etc/default/grub" `File.containsLine` "GRUB_DISABLE_LINUX_UUID=true"
- `onChange` (cmdProperty "update-grub" [] `assume` MadeChange)
- `onChange` (cmdProperty "update-initramfs" ["-u"] `assume` MadeChange)
- , combineProperties "nuked cloudatcost cruft"
- [ File.notPresent "/etc/rc.local"
- , File.notPresent "/etc/init.d/S97-setup.sh"
- , File.notPresent "/zang-debian.sh"
- , File.notPresent "/bin/npasswd"
- , User.nuked (User "user") User.YesReallyDeleteHome
- ]
- ]
+ `describe` "worked around grub/lvm boot bug #743126"
+ `onChange` (cmdProperty "update-grub" [] `assume` MadeChange)
+ `onChange` (cmdProperty "update-initramfs" ["-u"] `assume` MadeChange)
+ nukecruft :: Property Linux
+ nukecruft = tightenTargets $
+ combineProperties "nuked cloudatcost cruft" $ props
+ & File.notPresent "/etc/rc.local"
+ & File.notPresent "/etc/init.d/S97-setup.sh"
+ & File.notPresent "/zang-debian.sh"
+ & File.notPresent "/bin/npasswd"
+ & User.nuked (User "user") User.YesReallyDeleteHome
diff --git a/src/Propellor/Property/Hostname.hs b/src/Propellor/Property/Hostname.hs
index 7ab350ae..e1342d91 100644
--- a/src/Propellor/Property/Hostname.hs
+++ b/src/Propellor/Property/Hostname.hs
@@ -22,20 +22,20 @@ import Data.List.Utils
-- Also, the </etc/hosts> 127.0.0.1 line is set to localhost. Putting any
-- other hostnames there is not best practices and can lead to annoying
-- messages from eg, apache.
-sane :: Property NoInfo
+sane :: Property UnixLike
sane = sane' extractDomain
-sane' :: ExtractDomain -> Property NoInfo
-sane' extractdomain = property ("sane hostname") $
- ensureProperty . setTo' extractdomain =<< asks hostName
+sane' :: ExtractDomain -> Property UnixLike
+sane' extractdomain = property' ("sane hostname") $ \w ->
+ ensureProperty w . setTo' extractdomain =<< asks hostName
-- Like `sane`, but you can specify the hostname to use, instead
-- of the default hostname of the `Host`.
-setTo :: HostName -> Property NoInfo
+setTo :: HostName -> Property UnixLike
setTo = setTo' extractDomain
-setTo' :: ExtractDomain -> HostName -> Property NoInfo
-setTo' extractdomain hn = combineProperties desc
+setTo' :: ExtractDomain -> HostName -> Property UnixLike
+setTo' extractdomain hn = combineProperties desc $ toProps
[ "/etc/hostname" `File.hasContent` [basehost]
, hostslines $ catMaybes
[ if null domain
@@ -65,11 +65,12 @@ setTo' extractdomain hn = combineProperties desc
-- | Makes </etc/resolv.conf> contain search and domain lines for
-- the domain that the hostname is in.
-searchDomain :: Property NoInfo
+searchDomain :: Property UnixLike
searchDomain = searchDomain' extractDomain
-searchDomain' :: ExtractDomain -> Property NoInfo
-searchDomain' extractdomain = property desc (ensureProperty . go =<< asks hostName)
+searchDomain' :: ExtractDomain -> Property UnixLike
+searchDomain' extractdomain = property' desc $ \w ->
+ (ensureProperty w . go =<< asks hostName)
where
desc = "resolv.conf search and domain configured"
go hn =
diff --git a/src/Propellor/Property/Ssh.hs b/src/Propellor/Property/Ssh.hs
index dc4b7a75..05409593 100644
--- a/src/Propellor/Property/Ssh.hs
+++ b/src/Propellor/Property/Ssh.hs
@@ -47,8 +47,13 @@ import qualified Data.Map as M
import qualified Data.Set as S
import Data.List
-installed :: Property DebianLike
-installed = Apt.installed ["ssh"]
+installed :: Property UnixLike
+installed = withOS "ssh installed" $ \w o ->
+ let aptinstall = ensureProperty w $ Apt.installed ["ssh"]
+ in case o of
+ (Just (System (Debian _) _)) -> aptinstall
+ (Just (System (Buntish _) _)) -> aptinstall
+ _ -> unsupportedOS
restarted :: Property DebianLike
restarted = Service.restarted "ssh"