From 4694a4c36cca1c7b52421297a62548d8bbb2ec0b Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Fri, 25 Mar 2016 16:04:31 -0400 Subject: continued porting --- src/Propellor/Property/Cron.hs | 27 +++++++++--------- src/Propellor/Property/Debootstrap.hs | 31 +++++++++++--------- src/Propellor/Property/Docker.hs | 52 +++++++++++++++------------------- src/Propellor/Property/Mount.hs | 17 +++++------ src/Propellor/Property/Systemd/Core.hs | 2 +- src/Propellor/Types.hs | 3 +- src/Propellor/Types/MetaTypes.hs | 9 ++++-- 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 -- 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 ] -- cgit v1.2.3