summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
authorJoey Hess2016-03-25 16:04:31 -0400
committerJoey Hess2016-03-25 16:04:31 -0400
commit4694a4c36cca1c7b52421297a62548d8bbb2ec0b (patch)
tree1e01ac4a71ce151c017f5f7d9e8feeb76059f3a9 /src
parente28f49b7d1ae361e42809977bf12d3f126c3d90d (diff)
continued porting
Diffstat (limited to 'src')
-rw-r--r--src/Propellor/Property/Cron.hs27
-rw-r--r--src/Propellor/Property/Debootstrap.hs31
-rw-r--r--src/Propellor/Property/Docker.hs52
-rw-r--r--src/Propellor/Property/Mount.hs17
-rw-r--r--src/Propellor/Property/Systemd/Core.hs2
-rw-r--r--src/Propellor/Types.hs3
-rw-r--r--src/Propellor/Types/MetaTypes.hs9
7 files changed, 71 insertions, 70 deletions
diff --git a/src/Propellor/Property/Cron.hs b/src/Propellor/Property/Cron.hs
index 365e2903..267c6cbc 100644
--- a/src/Propellor/Property/Cron.hs
+++ b/src/Propellor/Property/Cron.hs
@@ -27,9 +27,11 @@ data Times
-- job file.
--
-- The cron job's output will only be emailed if it exits nonzero.
-job :: Desc -> Times -> User -> FilePath -> String -> Property NoInfo
-job desc times (User u) cddir command = combineProperties ("cronned " ++ desc)
- [ cronjobfile `File.hasContent`
+job :: Desc -> Times -> User -> FilePath -> String -> Property DebianLike
+job desc times (User u) cddir command = combineProperties ("cronned " ++ desc) $ props
+ & Apt.serviceInstalledRunning "cron"
+ & Apt.installed ["util-linux", "moreutils"]
+ & cronjobfile `File.hasContent`
[ case times of
Times _ -> ""
_ -> "#!/bin/sh\nset -e"
@@ -44,22 +46,19 @@ job desc times (User u) cddir command = combineProperties ("cronned " ++ desc)
"root" -> "chronic " ++ shellEscape scriptfile
_ -> "chronic su " ++ u ++ " -c " ++ shellEscape scriptfile
]
- , case times of
+ & case times of
Times _ -> doNothing
_ -> cronjobfile `File.mode` combineModes (readModes ++ executeModes)
-- Use a separate script because it makes the cron job name
-- prettier in emails, and also allows running the job manually.
- , scriptfile `File.hasContent`
+ & scriptfile `File.hasContent`
[ "#!/bin/sh"
, "# Generated by propellor"
, "set -e"
, "flock -n " ++ shellEscape cronjobfile
++ " sh -c " ++ shellEscape cmdline
]
- , scriptfile `File.mode` combineModes (readModes ++ executeModes)
- ]
- `requires` Apt.serviceInstalledRunning "cron"
- `requires` Apt.installed ["util-linux", "moreutils"]
+ & scriptfile `File.mode` combineModes (readModes ++ executeModes)
where
cmdline = "cd " ++ cddir ++ " && ( " ++ command ++ " )"
cronjobfile = "/etc" </> cronjobdir </> name
@@ -75,13 +74,13 @@ job desc times (User u) cddir command = combineProperties ("cronned " ++ desc)
| otherwise = '_'
-- | Installs a cron job, and runs it niced and ioniced.
-niceJob :: Desc -> Times -> User -> FilePath -> String -> Property NoInfo
+niceJob :: Desc -> Times -> User -> FilePath -> String -> Property DebianLike
niceJob desc times user cddir command = job desc times user cddir
("nice ionice -c 3 sh -c " ++ shellEscape command)
-- | Installs a cron job to run propellor.
-runPropellor :: Times -> Property NoInfo
-runPropellor times = withOS "propellor cron job" $ \o ->
- ensureProperty $
+runPropellor :: Times -> Property UnixLike
+runPropellor times = withOS "propellor cron job" $ \o os ->
+ ensureProperty o $
niceJob "propellor" times (User "root") localdir
- (bootstrapPropellorCommand o ++ "; ./propellor")
+ (bootstrapPropellorCommand os ++ "; ./propellor")
diff --git a/src/Propellor/Property/Debootstrap.hs b/src/Propellor/Property/Debootstrap.hs
index 5716be38..7cbf3d98 100644
--- a/src/Propellor/Property/Debootstrap.hs
+++ b/src/Propellor/Property/Debootstrap.hs
@@ -1,5 +1,3 @@
-{-# LANGUAGE FlexibleContexts #-}
-
module Propellor.Property.Debootstrap (
Url,
DebootstrapConfig(..),
@@ -48,14 +46,15 @@ toParams (c1 :+ c2) = toParams c1 <> toParams c2
--
-- The System can be any OS and architecture that debootstrap
-- and the kernel support.
-built :: FilePath -> System -> DebootstrapConfig -> Property HasInfo
-built target system config = built' (toProp installed) target system config
+built :: FilePath -> System -> DebootstrapConfig -> Property Linux
+built target system config = built' (setupRevertableProperty installed) target system config
-built' :: (Combines (Property NoInfo) (Property i)) => Property i -> FilePath -> System -> DebootstrapConfig -> Property (CInfo NoInfo i)
+built' :: Property Linux -> FilePath -> System -> DebootstrapConfig -> Property Linux
built' installprop target system@(System _ arch) config =
check (unpopulated target <||> ispartial) setupprop
`requires` installprop
where
+ setupprop :: Property Linux
setupprop = property ("debootstrapped " ++ target) $ liftIO $ do
createDirectoryIfMissing True target
-- Don't allow non-root users to see inside the chroot,
@@ -99,20 +98,21 @@ extractSuite (System (FreeBSD _) _) = Nothing
-- When necessary, falls back to installing debootstrap from source.
-- Note that installation from source is done by downloading the tarball
-- from a Debian mirror, with no cryptographic verification.
-installed :: RevertableProperty NoInfo
+installed :: RevertableProperty Linux Linux
installed = install <!> remove
where
- install = withOS "debootstrap installed" $ \o ->
+ install = withOS "debootstrap installed" $ \o os ->
ifM (liftIO $ isJust <$> programPath)
( return NoChange
- , ensureProperty (installon o)
+ , ensureProperty o (installon os)
)
installon (Just (System (Debian _) _)) = aptinstall
installon (Just (System (Buntish _) _)) = aptinstall
installon _ = sourceInstall
- remove = withOS "debootstrap removed" $ ensureProperty . removefrom
+ remove = withOS "debootstrap removed" $ \o os ->
+ ensureProperty o (removefrom os)
removefrom (Just (System (Debian _) _)) = aptremove
removefrom (Just (System (Buntish _) _)) = aptremove
removefrom _ = sourceRemove
@@ -120,18 +120,21 @@ installed = install <!> remove
aptinstall = Apt.installed ["debootstrap"]
aptremove = Apt.removed ["debootstrap"]
-sourceInstall :: Property NoInfo
-sourceInstall = property "debootstrap installed from source" (liftIO sourceInstall')
+sourceInstall :: Property Linux
+sourceInstall = go
`requires` perlInstalled
`requires` arInstalled
+ where
+ go :: Property Linux
+ go = property "debootstrap installed from source" (liftIO sourceInstall')
-perlInstalled :: Property NoInfo
+perlInstalled :: Property Linux
perlInstalled = check (not <$> inPath "perl") $ property "perl installed" $
liftIO $ toResult . isJust <$> firstM id
[ yumInstall "perl"
]
-arInstalled :: Property NoInfo
+arInstalled :: Property Linux
arInstalled = check (not <$> inPath "ar") $ property "ar installed" $
liftIO $ toResult . isJust <$> firstM id
[ yumInstall "binutils"
@@ -175,7 +178,7 @@ sourceInstall' = withTmpDir "debootstrap" $ \tmpd -> do
return MadeChange
_ -> errorMessage "debootstrap tar file did not contain exactly one dirctory"
-sourceRemove :: Property NoInfo
+sourceRemove :: Property Linux
sourceRemove = property "debootstrap not installed from source" $ liftIO $
ifM (doesDirectoryExist sourceInstallDir)
( do
diff --git a/src/Propellor/Property/Docker.hs b/src/Propellor/Property/Docker.hs
index c2c131c7..4bbfeef3 100644
--- a/src/Propellor/Property/Docker.hs
+++ b/src/Propellor/Property/Docker.hs
@@ -66,12 +66,12 @@ import Data.List.Utils
import qualified Data.Map as M
import System.Console.Concurrent
-installed :: Property NoInfo
+installed :: Property DebianLike
installed = Apt.installed ["docker.io"]
-- | Configures docker with an authentication file, so that images can be
-- pushed to index.docker.io. Optional.
-configured :: Property HasInfo
+configured :: Property DebianLike
configured = prop `requires` installed
where
prop = withPrivData src anyContext $ \getcfg ->
@@ -97,22 +97,17 @@ instance HasImage Image where
instance HasImage Container where
getImageName (Container i _) = i
-instance PropAccum Container where
- (Container i h) `addProp` p = Container i (h `addProp` p)
- (Container i h) `addPropFront` p = Container i (h `addPropFront` p)
- getProperties (Container _ h) = hostProperties h
-
-- | Defines a Container with a given name, image, and properties.
--- Properties can be added to configure the Container.
+-- Add properties to configure the Container.
--
--- > container "web-server" "debian"
+-- > container "web-server" (latestImage "debian") $ props
-- > & publish "80:80"
-- > & Apt.installed {"apache2"]
-- > & ...
-container :: ContainerName -> Image -> Container
-container cn image = Container image (Host cn [] info)
+container :: ContainerName -> Image -> Props -> Container
+container cn image (Props ps) = Container image (Host cn ps info)
where
- info = dockerInfo mempty
+ info = dockerInfo mempty <> mconcat (map getInfoRecursive ps)
-- | Ensures that a docker container is set up and running.
--
@@ -135,7 +130,7 @@ docked ctr@(Container _ h) =
go desc a = property (desc ++ " " ++ cn) $ do
hn <- asks hostName
let cid = ContainerId hn cn
- ensureProperties [a cid (mkContainerInfo cid ctr)]
+ ensureChildProperties [a cid (mkContainerInfo cid ctr)]
setup cid (ContainerInfo image runparams) =
provisionContainer cid
@@ -155,7 +150,7 @@ docked ctr@(Container _ h) =
]
-- | Build the image from a directory containing a Dockerfile.
-imageBuilt :: HasImage c => FilePath -> c -> Property NoInfo
+imageBuilt :: HasImage c => FilePath -> c -> Property Linux
imageBuilt directory ctr = describe built msg
where
msg = "docker image " ++ (imageIdentifier image) ++ " built from " ++ directory
@@ -165,7 +160,7 @@ imageBuilt directory ctr = describe built msg
image = getImageName ctr
-- | Pull the image from the standard Docker Hub registry.
-imagePulled :: HasImage c => c -> Property NoInfo
+imagePulled :: HasImage c => c -> Property Linux
imagePulled ctr = describe pulled msg
where
msg = "docker image " ++ (imageIdentifier image) ++ " pulled"
@@ -173,7 +168,7 @@ imagePulled ctr = describe pulled msg
`assume` MadeChange
image = getImageName ctr
-propagateContainerInfo :: (IsProp (Property i)) => Container -> Property i -> Property HasInfo
+propagateContainerInfo :: (IsProp (Property i)) => Container -> Property i -> Property (HasInfo + Linux)
propagateContainerInfo ctr@(Container _ h) p = propagateContainer cn ctr p'
where
p' = infoProperty
@@ -209,11 +204,10 @@ mkContainerInfo cid@(ContainerId hn _cn) (Container img h) =
-- that were not set up using propellor.
--
-- Generally, should come after the properties for the desired containers.
-garbageCollected :: Property NoInfo
-garbageCollected = propertyList "docker garbage collected"
- [ gccontainers
- , gcimages
- ]
+garbageCollected :: Property Linux
+garbageCollected = propertyList "docker garbage collected" $ props
+ & gccontainers
+ & gcimages
where
gccontainers = property "docker containers garbage collected" $
liftIO $ report <$> (mapM removeContainer =<< listContainers AllContainers)
@@ -225,7 +219,7 @@ garbageCollected = propertyList "docker garbage collected"
-- Currently, this consists of making pam_loginuid lines optional in
-- the pam config, to work around <https://github.com/docker/docker/issues/5663>
-- which affects docker 1.2.0.
-tweaked :: Property NoInfo
+tweaked :: Property Linux
tweaked = cmdProperty "sh"
[ "-c"
, "sed -ri 's/^session\\s+required\\s+pam_loginuid.so$/session optional pam_loginuid.so/' /etc/pam.d/*"
@@ -239,7 +233,7 @@ tweaked = cmdProperty "sh"
-- other GRUB_CMDLINE_LINUX_DEFAULT settings.
--
-- Only takes effect after reboot. (Not automated.)
-memoryLimited :: Property NoInfo
+memoryLimited :: Property DebianLike
memoryLimited = "/etc/default/grub" `File.containsLine` cfg
`describe` "docker memory limited"
`onChange` (cmdProperty "update-grub" [] `assume` MadeChange)
@@ -443,7 +437,7 @@ containerDesc cid p = p `describe` desc
where
desc = "container " ++ fromContainerId cid ++ " " ++ propertyDesc p
-runningContainer :: ContainerId -> Image -> [RunParam] -> Property NoInfo
+runningContainer :: ContainerId -> Image -> [RunParam] -> Property Linux
runningContainer cid@(ContainerId hn cn) image runps = containerDesc cid $ property "running" $ do
l <- liftIO $ listContainers RunningContainers
if cid `elem` l
@@ -558,7 +552,7 @@ init s = case toContainerId s of
-- | Once a container is running, propellor can be run inside
-- it to provision it.
-provisionContainer :: ContainerId -> Property NoInfo
+provisionContainer :: ContainerId -> Property Linux
provisionContainer cid = containerDesc cid $ property "provisioned" $ liftIO $ do
let shim = Shim.file (localdir </> "propellor") (localdir </> shimdir cid)
let params = ["--continue", show $ toChain cid]
@@ -587,7 +581,7 @@ chain hostlist hn s = case toContainerId s of
go cid h = do
changeWorkingDirectory localdir
onlyProcess (provisioningLock cid) $ do
- r <- runPropellor h $ ensureProperties $
+ r <- runPropellor h $ ensureChildProperties $
map ignoreInfo $
hostProperties h
flushConcurrentOutput
@@ -599,10 +593,10 @@ stopContainer cid = boolSystem dockercmd [Param "stop", Param $ fromContainerId
startContainer :: ContainerId -> IO Bool
startContainer cid = boolSystem dockercmd [Param "start", Param $ fromContainerId cid ]
-stoppedContainer :: ContainerId -> Property NoInfo
-stoppedContainer cid = containerDesc cid $ property desc $
+stoppedContainer :: ContainerId -> Property Linux
+stoppedContainer cid = containerDesc cid $ property' desc $ \o ->
ifM (liftIO $ elem cid <$> listContainers RunningContainers)
- ( liftIO cleanup `after` ensureProperty
+ ( liftIO cleanup `after` ensureProperty o
(property desc $ liftIO $ toResult <$> stopContainer cid)
, return NoChange
)
diff --git a/src/Propellor/Property/Mount.hs b/src/Propellor/Property/Mount.hs
index 590cede9..5921755c 100644
--- a/src/Propellor/Property/Mount.hs
+++ b/src/Propellor/Property/Mount.hs
@@ -37,16 +37,17 @@ formatMountOpts (MountOpts []) = "defaults"
formatMountOpts (MountOpts l) = intercalate "," l
-- | Mounts a device.
-mounted :: FsType -> Source -> MountPoint -> MountOpts -> Property NoInfo
+mounted :: FsType -> Source -> MountPoint -> MountOpts -> Property UnixLike
mounted fs src mnt opts = property (mnt ++ " mounted") $
toResult <$> liftIO (mount fs src mnt opts)
-- | Bind mounts the first directory so its contents also appear
-- in the second directory.
-bindMount :: FilePath -> FilePath -> Property NoInfo
-bindMount src dest = cmdProperty "mount" ["--bind", src, dest]
- `assume` MadeChange
- `describe` ("bind mounted " ++ src ++ " to " ++ dest)
+bindMount :: FilePath -> FilePath -> Property Linux
+bindMount src dest = tightenTargets $
+ cmdProperty "mount" ["--bind", src, dest]
+ `assume` MadeChange
+ `describe` ("bind mounted " ++ src ++ " to " ++ dest)
mount :: FsType -> Source -> MountPoint -> MountOpts -> IO Bool
mount fs src mnt opts = boolSystem "mount" $
@@ -66,10 +67,10 @@ newtype SwapPartition = SwapPartition FilePath
-- and its mount options are all automatically probed.
--
-- The SwapPartitions are also included in the generated fstab.
-fstabbed :: [MountPoint] -> [SwapPartition] -> Property NoInfo
-fstabbed mnts swaps = property "fstabbed" $ do
+fstabbed :: [MountPoint] -> [SwapPartition] -> Property Linux
+fstabbed mnts swaps = property' "fstabbed" $ \o -> do
fstab <- liftIO $ genFstab mnts swaps id
- ensureProperty $
+ ensureProperty o $
"/etc/fstab" `File.hasContent` fstab
genFstab :: [MountPoint] -> [SwapPartition] -> (MountPoint -> MountPoint) -> IO [String]
diff --git a/src/Propellor/Property/Systemd/Core.hs b/src/Propellor/Property/Systemd/Core.hs
index 7842f177..0290bce5 100644
--- a/src/Propellor/Property/Systemd/Core.hs
+++ b/src/Propellor/Property/Systemd/Core.hs
@@ -6,5 +6,5 @@ import qualified Propellor.Property.Apt as Apt
-- dbus is only a Recommends of systemd, but is needed for communication
-- from the systemd inside a container to the one outside, so make sure it
-- gets installed.
-installed :: Property NoInfo
+installed :: Property DebianLike
installed = Apt.installed ["systemd", "dbus"]
diff --git a/src/Propellor/Types.hs b/src/Propellor/Types.hs
index 7098c83f..dd8721ac 100644
--- a/src/Propellor/Types.hs
+++ b/src/Propellor/Types.hs
@@ -17,8 +17,9 @@ module Propellor.Types
, MetaTypes
, OS(..)
, UnixLike
- , Debian
+ , Linux
, DebianLike
+ , Debian
, Buntish
, FreeBSD
, HasInfo
diff --git a/src/Propellor/Types/MetaTypes.hs b/src/Propellor/Types/MetaTypes.hs
index 80fa454e..6545c924 100644
--- a/src/Propellor/Types/MetaTypes.hs
+++ b/src/Propellor/Types/MetaTypes.hs
@@ -4,8 +4,9 @@ module Propellor.Types.MetaTypes (
MetaType(..),
OS(..),
UnixLike,
- Debian,
+ Linux,
DebianLike,
+ Debian,
Buntish,
FreeBSD,
HasInfo,
@@ -37,11 +38,13 @@ data OS
-- | Any unix-like system
type UnixLike = MetaTypes '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish, 'Targeting 'OSFreeBSD ]
+-- | Any linux system
+type Linux = MetaTypes '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish ]
+-- | Debian and derivatives.
+type DebianLike = Debian + Buntish
type Debian = MetaTypes '[ 'Targeting 'OSDebian ]
type Buntish = MetaTypes '[ 'Targeting 'OSBuntish ]
type FreeBSD = MetaTypes '[ 'Targeting 'OSFreeBSD ]
--- | Debian and derivatives.
-type DebianLike = Debian + Buntish
-- | Used to indicate that a Property adds Info to the Host where it's used.
type HasInfo = MetaTypes '[ 'WithInfo ]