From 91d1833155a2e8be2c435d0a92a750cc9d2f30b5 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Fri, 25 Mar 2016 14:04:40 -0400 Subject: ported Property.List I wanted to keep propertyList [foo, bar] working, but had some difficulty making the type class approach work. Anyway, that's unlikely to be useful, since foo and bar probably have different types, or could easiy have their types updated breaking it. --- src/Propellor/Property/Docker.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'src/Propellor/Property/Docker.hs') diff --git a/src/Propellor/Property/Docker.hs b/src/Propellor/Property/Docker.hs index ebc0b301..c2c131c7 100644 --- a/src/Propellor/Property/Docker.hs +++ b/src/Propellor/Property/Docker.hs @@ -178,7 +178,7 @@ propagateContainerInfo ctr@(Container _ h) p = propagateContainer cn ctr p' where p' = infoProperty (propertyDesc p) - (propertySatisfy p) + (getSatisfy p) (propertyInfo p <> dockerinfo) (propertyChildren p) dockerinfo = dockerInfo $ -- cgit v1.2.3 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(-) (limited to 'src/Propellor/Property/Docker.hs') 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 From f01776d64b1b8fcf89903d0de1ffe27f10d620ee Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Fri, 25 Mar 2016 16:20:32 -0400 Subject: rename toProp to toChildProperties and note that it's not meant to be used by regular users --- config-simple.hs | 12 ------------ src/Propellor/Engine.hs | 2 +- src/Propellor/PropAccum.hs | 6 +++--- src/Propellor/Property/Chroot.hs | 7 +++---- src/Propellor/Property/Docker.hs | 4 +--- src/Propellor/Property/List.hs | 6 +++--- src/Propellor/Types.hs | 23 ++++++----------------- 7 files changed, 17 insertions(+), 43 deletions(-) (limited to 'src/Propellor/Property/Docker.hs') diff --git a/config-simple.hs b/config-simple.hs index 28b38409..da1580c6 100644 --- a/config-simple.hs +++ b/config-simple.hs @@ -12,7 +12,6 @@ import Propellor.Property.Scheduled import qualified Propellor.Property.User as User --import qualified Propellor.Property.Hostname as Hostname --import qualified Propellor.Property.Tor as Tor -import qualified Propellor.Property.Docker as Docker main :: IO () main = defaultMain hosts @@ -34,15 +33,4 @@ mybox = host "mybox.example.com" $ props & User.hasSomePassword (User "root") & Network.ipv6to4 & File.dirExists "/var/www" - & Docker.docked webserverContainer - & Docker.garbageCollected `period` Daily & Cron.runPropellor (Cron.Times "30 * * * *") - --- A generic webserver in a Docker container. -webserverContainer :: Docker.Container -webserverContainer = Docker.container "webserver" (Docker.latestImage "debian") $ props - & os (System (Debian (Stable "jessie")) "amd64") - & Apt.stdSourcesList - & Docker.publish "80:80" - & Docker.volume "/var/www:/var/www" - & Apt.serviceInstalledRunning "apache2" diff --git a/src/Propellor/Engine.hs b/src/Propellor/Engine.hs index bf49b95f..4c37e704 100644 --- a/src/Propellor/Engine.hs +++ b/src/Propellor/Engine.hs @@ -33,7 +33,7 @@ import Utility.Exception -- with nice display of what's being done. mainProperties :: Host -> IO () mainProperties host = do - ret <- runPropellor host $ ensureChildProperties [toProp overall] + ret <- runPropellor host $ ensureChildProperties [toChildProperty overall] messagesDone case ret of FailedChange -> exitWith (ExitFailure 1) diff --git a/src/Propellor/PropAccum.hs b/src/Propellor/PropAccum.hs index 06b8ad3f..7547a81d 100644 --- a/src/Propellor/PropAccum.hs +++ b/src/Propellor/PropAccum.hs @@ -62,7 +62,7 @@ type instance GetMetaTypes (RevertableProperty (MetaTypes t) undo) = MetaTypes t => Props (MetaTypes x) -> p -> Props (MetaTypes (Combine x y)) -Props c & p = Props (c ++ [toProp p]) +Props c & p = Props (c ++ [toChildProperty p]) -- | Adds a property before any other properties. (&^) @@ -74,7 +74,7 @@ Props c & p = Props (c ++ [toProp p]) => Props (MetaTypes x) -> p -> Props (MetaTypes (Combine x y)) -Props c &^ p = Props (toProp p : c) +Props c &^ p = Props (toChildProperty p : c) -- | Adds a property in reverted form. (!) @@ -82,7 +82,7 @@ Props c &^ p = Props (toProp p : c) => Props (MetaTypes x) -> RevertableProperty (MetaTypes y) (MetaTypes z) -> Props (MetaTypes (Combine x z)) -Props c ! p = Props (c ++ [toProp (revert p)]) +Props c ! p = Props (c ++ [toChildProperty (revert p)]) {- diff --git a/src/Propellor/Property/Chroot.hs b/src/Propellor/Property/Chroot.hs index fb05d659..bf6f2083 100644 --- a/src/Propellor/Property/Chroot.hs +++ b/src/Propellor/Property/Chroot.hs @@ -213,11 +213,10 @@ chain hostlist (ChrootChain hn loc systemdonly onconsole) = changeWorkingDirectory localdir when onconsole forceConsole onlyProcess (provisioningLock loc) $ do - r <- runPropellor (setInChroot h) $ ensureProperties $ + r <- runPropellor (setInChroot h) $ ensureChildProperties $ if systemdonly - then [Systemd.installed] - else map ignoreInfo $ - hostProperties h + then [toProp Systemd.installed] + else hostProperties h flushConcurrentOutput putStrLn $ "\n" ++ show r chain _ _ = errorMessage "bad chain command" diff --git a/src/Propellor/Property/Docker.hs b/src/Propellor/Property/Docker.hs index 4bbfeef3..d19d15aa 100644 --- a/src/Propellor/Property/Docker.hs +++ b/src/Propellor/Property/Docker.hs @@ -581,9 +581,7 @@ chain hostlist hn s = case toContainerId s of go cid h = do changeWorkingDirectory localdir onlyProcess (provisioningLock cid) $ do - r <- runPropellor h $ ensureChildProperties $ - map ignoreInfo $ - hostProperties h + r <- runPropellor h $ ensureChildProperties $ hostProperties h flushConcurrentOutput putStrLn $ "\n" ++ show r diff --git a/src/Propellor/Property/List.hs b/src/Propellor/Property/List.hs index 44916f23..d8c5cff4 100644 --- a/src/Propellor/Property/List.hs +++ b/src/Propellor/Property/List.hs @@ -21,7 +21,7 @@ import Propellor.Exception import Data.Monoid toProps :: [Property (MetaTypes metatypes)] -> Props (MetaTypes metatypes) -toProps ps = Props (map toProp ps) +toProps ps = Props (map toChildProperty ps) -- | Combines a list of properties, resulting in a single property -- that when run will run each property in the list in turn, @@ -38,7 +38,7 @@ propertyList desc (Props ps) = property desc (ensureChildProperties cs) `modifyChildren` (++ cs) where - cs = map toProp ps + cs = map toChildProperty ps -- | Combines a list of properties, resulting in one property that -- ensures each in turn. Stops if a property fails. @@ -47,7 +47,7 @@ combineProperties desc (Props ps) = property desc (combineSatisfy cs NoChange) `modifyChildren` (++ cs) where - cs = map toProp ps + cs = map toChildProperty ps combineSatisfy :: [ChildProperty] -> Result -> Propellor Result combineSatisfy [] rs = return rs diff --git a/src/Propellor/Types.hs b/src/Propellor/Types.hs index dd8721ac..f42f55d7 100644 --- a/src/Propellor/Types.hs +++ b/src/Propellor/Types.hs @@ -158,18 +158,6 @@ addInfoProperty addInfoProperty (Property _ d a oldi c) newi = Property sing d a (oldi <> newi) c -{- - --- | Makes a version of a Proprty without its Info. --- Use with caution! -ignoreInfo - :: (metatypes' ~ - => Property metatypes - -> Property (MetaTypes metatypes') -ignoreInfo = - --} - -- | Changes the action that is performed to satisfy a property. adjustPropertySatisfy :: Property metatypes -> (Propellor Result -> Propellor Result) -> Property metatypes adjustPropertySatisfy (Property t d s i c) f = Property t d (f s) i c @@ -213,7 +201,9 @@ class IsProp p where -- | Gets the info of the property, combined with all info -- of all children properties. getInfoRecursive :: p -> Info - toProp :: p -> ChildProperty + -- | Gets a ChildProperty representing the Property. + -- You should not normally need to use this. + toChildProperty :: p -> ChildProperty -- | Gets the action that can be run to satisfy a Property. -- You should never run this action directly. Use -- 'Propellor.EnsureProperty.ensureProperty` instead. @@ -225,7 +215,7 @@ instance IsProp (Property metatypes) where modifyChildren (Property t d a i c) f = Property t d a i (f c) getInfoRecursive (Property _ _ _ i c) = i <> mconcat (map getInfoRecursive c) - toProp (Property _ d a i c) = ChildProperty d a i c + toChildProperty (Property _ d a i c) = ChildProperty d a i c getSatisfy (Property _ _ a _ _) = a instance IsProp ChildProperty where @@ -234,7 +224,7 @@ instance IsProp ChildProperty where modifyChildren (ChildProperty d a i c) f = ChildProperty d a i (f c) getInfoRecursive (ChildProperty _ _ i c) = i <> mconcat (map getInfoRecursive c) - toProp = id + toChildProperty = id getSatisfy (ChildProperty _ a _ _) = a instance IsProp (RevertableProperty setupmetatypes undometatypes) where @@ -243,10 +233,9 @@ instance IsProp (RevertableProperty setupmetatypes undometatypes) where RevertableProperty (setDesc p1 d) (setDesc p2 ("not " ++ d)) getDesc (RevertableProperty p1 _) = getDesc p1 modifyChildren (RevertableProperty p1 p2) f = RevertableProperty (modifyChildren p1 f) (modifyChildren p2 f) - -- toProp (RevertableProperty p1 _) = p1 -- | Return the Info of the currently active side. getInfoRecursive (RevertableProperty p1 _p2) = getInfoRecursive p1 - toProp (RevertableProperty p1 _p2) = toProp p1 + toChildProperty (RevertableProperty p1 _p2) = toChildProperty p1 getSatisfy (RevertableProperty p1 _) = getSatisfy p1 -- | Type level calculation of the type that results from combining two -- cgit v1.2.3 From 36e97137e538de401bd0340b469e10dca5f4b475 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Sat, 26 Mar 2016 19:31:23 -0400 Subject: ported propagateContainer Renamed several utility functions along the way. --- debian/changelog | 5 ++++ doc/todo/type_level_OS_requirements.mdwn | 7 ++--- propellor.cabal | 1 + src/Propellor/Container.hs | 46 ++++++++++++++++++++++++++++++ src/Propellor/Info.hs | 6 ++-- src/Propellor/PrivData.hs | 4 +-- src/Propellor/PropAccum.hs | 33 ---------------------- src/Propellor/Property/Chroot.hs | 43 +++++++++++++--------------- src/Propellor/Property/Concurrent.hs | 2 +- src/Propellor/Property/Conductor.hs | 8 +++--- src/Propellor/Property/Dns.hs | 10 +++---- src/Propellor/Property/Docker.hs | 10 +++---- src/Propellor/Property/List.hs | 4 +-- src/Propellor/Property/Partition.hs | 2 +- src/Propellor/Property/Postfix.hs | 2 +- src/Propellor/Property/Scheduled.hs | 6 ++-- src/Propellor/Property/Systemd.hs | 18 ++++++------ src/Propellor/Spin.hs | 4 +-- src/Propellor/Types.hs | 48 +++++++++++++------------------- src/Propellor/Types/Info.hs | 6 ++-- 20 files changed, 134 insertions(+), 131 deletions(-) create mode 100644 src/Propellor/Container.hs (limited to 'src/Propellor/Property/Docker.hs') diff --git a/debian/changelog b/debian/changelog index df518753..8a5b67e4 100644 --- a/debian/changelog +++ b/debian/changelog @@ -49,6 +49,11 @@ propellor (3.0.0) UNRELEASED; urgency=medium For example: upgraded :: Property Debian upgraded = tightenTargets (cmdProperty "apt-get" ["upgrade"]) + - Several utility functions have been renamed: + getInfo to fromInfo + propertyInfo to getInfo + propertyDesc to getDesc + propertyChildren to getChildren * The new `pickOS` property combinator can be used to combine different properties, supporting different OS's, into one Property that chooses what to do based on the Host's OS. diff --git a/doc/todo/type_level_OS_requirements.mdwn b/doc/todo/type_level_OS_requirements.mdwn index 7c2fb78f..f1c3e59f 100644 --- a/doc/todo/type_level_OS_requirements.mdwn +++ b/doc/todo/type_level_OS_requirements.mdwn @@ -21,13 +21,12 @@ withOS. The `os` property would need to yield a `Property (os:[])`, where the type level list contains a type-level eqivilant of the value passed to the -property. Is that possible to do? reification or something? -(See: ) -Or, alternatively, could have less polymorphic `debian` etc +property. Is that possible to do? +Or, alternatively, could have less polymorphic `osDebian` etc properties replace the `os` property. If a Host's list of properties, when all combined together, -contains more than one element in its '[OS], that needs to be a type error, +contains more than one element in its '[OS], that could be a type error, the OS of the Host is indeterminite. Which would be fixed by using the `os` property to specify. diff --git a/propellor.cabal b/propellor.cabal index e47bb2e6..4a7739d3 100644 --- a/propellor.cabal +++ b/propellor.cabal @@ -141,6 +141,7 @@ Library Propellor.PropAccum Propellor.Utilities Propellor.CmdLine + Propellor.Container Propellor.Info Propellor.Message Propellor.Debug diff --git a/src/Propellor/Container.hs b/src/Propellor/Container.hs new file mode 100644 index 00000000..6e974efd --- /dev/null +++ b/src/Propellor/Container.hs @@ -0,0 +1,46 @@ +{-# LANGUAGE DataKinds, TypeFamilies #-} + +module Propellor.Container where + +import Propellor.Types +import Propellor.Types.MetaTypes +import Propellor.Types.Info +import Propellor.PrivData + +class Container c where + containerProperties :: c -> [ChildProperty] + containerInfo :: c -> Info + +instance Container Host where + containerProperties = hostProperties + containerInfo = hostInfo + +-- | Adjust the provided Property, adding to its +-- propertyChidren the properties of the provided container. +-- +-- The Info of the propertyChildren is adjusted to only include +-- info that should be propagated out to the Property. +-- +-- Any PrivInfo that uses HostContext is adjusted to use the name +-- of the container as its context. +propagateContainer + :: + -- Since the children being added probably have info, + -- require the Property's metatypes to have info. + ( IncludesInfo metatypes ~ 'True + , Container c + ) + => String + -> c + -> Property metatypes + -> Property metatypes +propagateContainer containername c prop = prop + `addChildren` map convert (containerProperties c) + where + convert p = + let n = property (getDesc p) (getSatisfy p) :: Property UnixLike + n' = n + `addInfoProperty` mapInfo (forceHostContext containername) + (propagatableInfo (getInfo p)) + `addChildren` map convert (getChildren p) + in toChildProperty n' diff --git a/src/Propellor/Info.hs b/src/Propellor/Info.hs index 725a02ad..ff0b3b5e 100644 --- a/src/Propellor/Info.hs +++ b/src/Propellor/Info.hs @@ -42,7 +42,7 @@ pureInfoProperty' desc i = addInfoProperty p i -- | Gets a value from the host's Info. askInfo :: (IsInfo v) => Propellor v -askInfo = asks (getInfo . hostInfo) +askInfo = asks (fromInfo . hostInfo) -- | Specifies that a host's operating system is Debian, -- and further indicates the suite and architecture. @@ -129,7 +129,7 @@ hostMap l = M.fromList $ zip (map hostName l) l aliasMap :: [Host] -> M.Map HostName Host aliasMap = M.fromList . concat . - map (\h -> map (\aka -> (aka, h)) $ fromAliasesInfo $ getInfo $ hostInfo h) + map (\h -> map (\aka -> (aka, h)) $ fromAliasesInfo $ fromInfo $ hostInfo h) findHost :: [Host] -> HostName -> Maybe Host findHost l hn = (findHostNoAlias l hn) <|> (findAlias l hn) @@ -141,7 +141,7 @@ findAlias :: [Host] -> HostName -> Maybe Host findAlias l hn = M.lookup hn (aliasMap l) getAddresses :: Info -> [IPAddr] -getAddresses = mapMaybe getIPAddr . S.toList . fromDnsInfo . getInfo +getAddresses = mapMaybe getIPAddr . S.toList . fromDnsInfo . fromInfo hostAddresses :: HostName -> [Host] -> [IPAddr] hostAddresses hn hosts = maybe [] (getAddresses . hostInfo) (findHost hosts hn) diff --git a/src/Propellor/PrivData.hs b/src/Propellor/PrivData.hs index 77c7133f..0bc0c100 100644 --- a/src/Propellor/PrivData.hs +++ b/src/Propellor/PrivData.hs @@ -161,7 +161,7 @@ filterPrivData :: Host -> PrivMap -> PrivMap filterPrivData host = M.filterWithKey (\k _v -> S.member k used) where used = S.map (\(f, _, c) -> (f, mkHostContext c (hostName host))) $ - fromPrivInfo $ getInfo $ hostInfo host + fromPrivInfo $ fromInfo $ hostInfo host getPrivData :: PrivDataField -> Context -> PrivMap -> Maybe PrivData getPrivData field context m = do @@ -245,7 +245,7 @@ mkUsedByMap = M.unionsWith (++) . map (\h -> mkPrivDataMap h $ const [hostName h mkPrivDataMap :: Host -> (Maybe PrivDataSourceDesc -> a) -> M.Map (PrivDataField, Context) a mkPrivDataMap host mkv = M.fromList $ map (\(f, d, c) -> ((f, mkHostContext c (hostName host)), mkv d)) - (S.toList $ fromPrivInfo $ getInfo $ hostInfo host) + (S.toList $ fromPrivInfo $ fromInfo $ hostInfo host) setPrivDataTo :: PrivDataField -> Context -> PrivData -> IO () setPrivDataTo field context (PrivData value) = do diff --git a/src/Propellor/PropAccum.hs b/src/Propellor/PropAccum.hs index 8281b9a1..af362ca7 100644 --- a/src/Propellor/PropAccum.hs +++ b/src/Propellor/PropAccum.hs @@ -12,7 +12,6 @@ module Propellor.PropAccum , (&) , (&^) , (!) - --, propagateContainer ) where import Propellor.Types @@ -82,35 +81,3 @@ 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)]) - -{- - --- | Adjust the provided Property, adding to its --- propertyChidren the properties of the provided container. --- --- The Info of the propertyChildren is adjusted to only include --- info that should be propagated out to the Property. --- --- Any PrivInfo that uses HostContext is adjusted to use the name --- of the container as its context. -propagateContainer - :: (PropAccum container) - => String - -> container - -> Property metatypes - -> Property metatypes -propagateContainer containername c prop = Property - undefined - (propertyDesc prop) - (getSatisfy prop) - (propertyInfo prop) - (propertyChildren prop ++ hostprops) - where - hostprops = map go $ getProperties c - go p = - let i = mapInfo (forceHostContext containername) - (propagatableInfo (propertyInfo p)) - cs = map go (propertyChildren p) - in infoProperty (propertyDesc p) (getSatisfy p) i cs - --} diff --git a/src/Propellor/Property/Chroot.hs b/src/Propellor/Property/Chroot.hs index 4480f98d..547e5c94 100644 --- a/src/Propellor/Property/Chroot.hs +++ b/src/Propellor/Property/Chroot.hs @@ -41,23 +41,18 @@ data Chroot where Chroot :: ChrootBootstrapper b => FilePath -> b -> Host -> Chroot chrootSystem :: Chroot -> Maybe System -chrootSystem (Chroot _ _ h) = fromInfoVal (getInfo (hostInfo h)) +chrootSystem (Chroot _ _ h) = fromInfoVal (fromInfo (hostInfo h)) instance Show Chroot where show c@(Chroot loc _ _) = "Chroot " ++ loc ++ " " ++ show (chrootSystem c) -instance PropAccum Chroot where - (Chroot l c h) `addProp` p = Chroot l c (h & p) - (Chroot l c h) `addPropFront` p = Chroot l c (h `addPropFront` p) - getProperties (Chroot _ _ h) = hostProperties h - -- | Class of things that can do initial bootstrapping of an operating -- System in a chroot. class ChrootBootstrapper b where -- | Do initial bootstrapping of an operating system in a chroot. -- If the operating System is not supported, return -- Left error message. - buildchroot :: b -> Maybe System -> FilePath -> Either String (Property HasInfo) + buildchroot :: b -> Maybe System -> FilePath -> Either String (Property (HasInfo + UnixLike)) -- | Use this to bootstrap a chroot by extracting a tarball. -- @@ -70,12 +65,11 @@ data ChrootTarball = ChrootTarball FilePath instance ChrootBootstrapper ChrootTarball where buildchroot (ChrootTarball tb) _ loc = Right $ extractTarball loc tb -extractTarball :: FilePath -> FilePath -> Property HasInfo -extractTarball target src = toProp . - check (unpopulated target) $ - cmdProperty "tar" params - `assume` MadeChange - `requires` File.dirExists target +extractTarball :: FilePath -> FilePath -> Property UnixLike +extractTarball target src = check (unpopulated target) $ + cmdProperty "tar" params + `assume` MadeChange + `requires` File.dirExists target where params = [ "-C" @@ -92,14 +86,15 @@ instance ChrootBootstrapper Debootstrapped where (Just s@(System (Debian _) _)) -> Right $ debootstrap s (Just s@(System (Buntish _) _)) -> Right $ debootstrap s (Just (System (FreeBSD _) _)) -> Left "FreeBSD not supported by debootstrap." - Nothing -> Left "Cannot debootstrap; `os` property not specified" + Nothing -> Left "Cannot debootstrap; OS not specified" where debootstrap s = Debootstrap.built loc s cf -- | Defines a Chroot at the given location, built with debootstrap. -- -- Properties can be added to configure the Chroot. At a minimum, --- add the `os` property to specify the operating system to bootstrap. +-- add a property such as `osDebian` to specify the operating system +-- to bootstrap. -- -- > debootstrapped Debootstrap.BuildD "/srv/chroot/ghc-dev" -- > & osDebian Unstable "amd64" @@ -131,25 +126,25 @@ provisioned' propigator c@(Chroot loc bootstrapper _) systemdonly = (propertyList (chrootDesc c "removed") [teardown]) where setup = propellChroot c (inChrootProcess (not systemdonly) c) systemdonly - `requires` toProp built + `requires` built built = case buildchroot bootstrapper (chrootSystem c) loc of Right p -> p Left e -> cantbuild e - cantbuild e = infoProperty (chrootDesc c "built") (error e) mempty [] + cantbuild e = property (chrootDesc c "built") (error e) teardown = check (not <$> unpopulated loc) $ property ("removed " ++ loc) $ makeChange (removeChroot loc) -propagateChrootInfo :: (IsProp (Property i)) => Chroot -> Property i -> Property HasInfo +propagateChrootInfo :: (IsProp (Property i)) => Chroot -> Property i -> Property (HasInfo + UnixLike) propagateChrootInfo c@(Chroot location _ _) p = propagateContainer location c p' where p' = infoProperty - (propertyDesc p) + (getDesc p) (getSatisfy p) - (propertyInfo p <> chrootInfo c) + (getInfo p <> chrootInfo c) (propertyChildren p) chrootInfo :: Chroot -> Info @@ -157,7 +152,7 @@ chrootInfo (Chroot loc _ h) = mempty `addInfo` mempty { _chroots = M.singleton loc h } -- | Propellor is run inside the chroot to provision it. -propellChroot :: Chroot -> ([String] -> IO (CreateProcess, IO ())) -> Bool -> Property NoInfo +propellChroot :: Chroot -> ([String] -> IO (CreateProcess, IO ())) -> Bool -> Property UnixLike propellChroot c@(Chroot loc _ _) mkproc systemdonly = property (chrootDesc c "provisioned") $ do let d = localdir shimdir c let me = localdir "propellor" @@ -205,7 +200,7 @@ chain :: [Host] -> CmdLine -> IO () chain hostlist (ChrootChain hn loc systemdonly onconsole) = case findHostNoAlias hostlist hn of Nothing -> errorMessage ("cannot find host " ++ hn) - Just parenthost -> case M.lookup loc (_chroots $ getInfo $ hostInfo parenthost) of + Just parenthost -> case M.lookup loc (_chroots $ fromInfo $ hostInfo parenthost) of Nothing -> errorMessage ("cannot find chroot " ++ loc ++ " on host " ++ hn) Just h -> go h where @@ -215,7 +210,7 @@ chain hostlist (ChrootChain hn loc systemdonly onconsole) = onlyProcess (provisioningLock loc) $ do r <- runPropellor (setInChroot h) $ ensureChildProperties $ if systemdonly - then [toProp Systemd.installed] + then [toChildProperty Systemd.installed] else hostProperties h flushConcurrentOutput putStrLn $ "\n" ++ show r @@ -257,7 +252,7 @@ chrootDesc (Chroot loc _ _) desc = "chroot " ++ loc ++ " " ++ desc -- This is accomplished by installing a script -- that does not let any daemons be started by packages that use -- invoke-rc.d. Reverting the property removes the script. -noServices :: RevertableProperty NoInfo +noServices :: RevertableProperty DebianLike DebianLike noServices = setup teardown where f = "/usr/sbin/policy-rc.d" diff --git a/src/Propellor/Property/Concurrent.hs b/src/Propellor/Property/Concurrent.hs index a86c839f..ace85a3c 100644 --- a/src/Propellor/Property/Concurrent.hs +++ b/src/Propellor/Property/Concurrent.hs @@ -78,7 +78,7 @@ concurrently p1 p2 = (combineWith go go p1 p2) -- The above example will run foo and bar concurrently, and once either of -- those 2 properties finishes, will start running baz. concurrentList :: SingI metatypes => IO Int -> Desc -> Props (MetaTypes metatypes) -> Property (MetaTypes metatypes) -concurrentList getn d (Props ps) = property d go `modifyChildren` (++ ps) +concurrentList getn d (Props ps) = property d go `addChildren` ps where go = do n <- liftIO getn diff --git a/src/Propellor/Property/Conductor.hs b/src/Propellor/Property/Conductor.hs index ec15281b..8fe607bc 100644 --- a/src/Propellor/Property/Conductor.hs +++ b/src/Propellor/Property/Conductor.hs @@ -126,7 +126,7 @@ mkOrchestra = fromJust . go S.empty where go seen h | S.member (hostName h) seen = Nothing -- break loop - | otherwise = Just $ case getInfo (hostInfo h) of + | otherwise = Just $ case fromInfo (hostInfo h) of ConductorFor [] -> Conducted h ConductorFor l -> let seen' = S.insert (hostName h) seen @@ -214,7 +214,7 @@ orchestrate :: [Host] -> [Host] orchestrate hs = map go hs where go h - | isOrchestrated (getInfo (hostInfo h)) = h + | isOrchestrated (fromInfo (hostInfo h)) = h | otherwise = foldl orchestrate' (removeold h) (map (deloop h) os) os = extractOrchestras hs @@ -222,7 +222,7 @@ orchestrate hs = map go hs removeold' h oldconductor = addPropHost h $ undoRevertableProperty $ conductedBy oldconductor - oldconductors = zip hs (map (getInfo . hostInfo) hs) + oldconductors = zip hs (map (fromInfo . hostInfo) hs) oldconductorsof h = flip mapMaybe oldconductors $ \(oldconductor, NotConductorFor l) -> if any (sameHost h) l @@ -299,7 +299,7 @@ addConductorPrivData h hs = h { hostInfo = hostInfo h <> i } i = mempty `addInfo` mconcat (map privinfo hs) `addInfo` Orchestrated (Any True) - privinfo h' = forceHostContext (hostName h') $ getInfo (hostInfo h') + 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 diff --git a/src/Propellor/Property/Dns.hs b/src/Propellor/Property/Dns.hs index a660a016..2b5596bd 100644 --- a/src/Propellor/Property/Dns.hs +++ b/src/Propellor/Property/Dns.hs @@ -213,7 +213,7 @@ otherServers :: DnsServerType -> [Host] -> Domain -> [HostName] otherServers wantedtype hosts domain = M.keys $ M.filter wanted $ hostMap hosts where - wanted h = case M.lookup domain (fromNamedConfMap $ getInfo $ hostInfo h) of + wanted h = case M.lookup domain (fromNamedConfMap $ fromInfo $ hostInfo h) of Nothing -> False Just conf -> confDnsServerType conf == wantedtype && confDomain conf == domain @@ -468,7 +468,7 @@ genZone inzdomain hostmap zdomain soa = -- So we can just use the IPAddrs. addcnames :: Host -> [Either WarningMessage (BindDomain, Record)] addcnames h = concatMap gen $ filter (inDomain zdomain) $ - mapMaybe getCNAME $ S.toList $ fromDnsInfo $ getInfo info + mapMaybe getCNAME $ S.toList $ fromDnsInfo $ fromInfo info where info = hostInfo h gen c = case getAddresses info of @@ -483,7 +483,7 @@ genZone inzdomain hostmap zdomain soa = where info = hostInfo h l = zip (repeat $ AbsDomain $ hostName h) - (S.toList $ S.filter (\r -> isNothing (getIPAddr r) && isNothing (getCNAME r)) (fromDnsInfo $ getInfo info)) + (S.toList $ S.filter (\r -> isNothing (getIPAddr r) && isNothing (getCNAME r)) (fromDnsInfo $ fromInfo info)) -- Simplifies the list of hosts. Remove duplicate entries. -- Also, filter out any CHAMES where the same domain has an @@ -518,7 +518,7 @@ addNamedConf conf = NamedConfMap (M.singleton domain conf) domain = confDomain conf getNamedConf :: Propellor (M.Map Domain NamedConf) -getNamedConf = asks $ fromNamedConfMap . getInfo . hostInfo +getNamedConf = asks $ fromNamedConfMap . fromInfo . hostInfo -- | Generates SSHFP records for hosts in the domain (or with CNAMES -- in the domain) that have configured ssh public keys. @@ -531,7 +531,7 @@ genSSHFP domain h = concatMap mk . concat <$> (gen =<< get) gen = liftIO . mapM genSSHFP' . M.elems . fromMaybe M.empty mk r = mapMaybe (\d -> if inDomain domain d then Just (d, r) else Nothing) (AbsDomain hostname : cnames) - cnames = mapMaybe getCNAME $ S.toList $ fromDnsInfo $ getInfo info + cnames = mapMaybe getCNAME $ S.toList $ fromDnsInfo $ fromInfo info hostname = hostName h info = hostInfo h diff --git a/src/Propellor/Property/Docker.hs b/src/Propellor/Property/Docker.hs index d19d15aa..fe1e3b18 100644 --- a/src/Propellor/Property/Docker.hs +++ b/src/Propellor/Property/Docker.hs @@ -172,9 +172,9 @@ propagateContainerInfo :: (IsProp (Property i)) => Container -> Property i -> Pr propagateContainerInfo ctr@(Container _ h) p = propagateContainer cn ctr p' where p' = infoProperty - (propertyDesc p) + (getDesc p) (getSatisfy p) - (propertyInfo p <> dockerinfo) + (getInfo p <> dockerinfo) (propertyChildren p) dockerinfo = dockerInfo $ mempty { _dockerContainers = M.singleton cn h } @@ -186,7 +186,7 @@ mkContainerInfo cid@(ContainerId hn _cn) (Container img h) = where runparams = map (\(DockerRunParam mkparam) -> mkparam hn) (_dockerRunParams info) - info = getInfo $ hostInfo h' + info = fromInfo $ hostInfo h' h' = h -- Restart by default so container comes up on -- boot or when docker is upgraded. @@ -435,7 +435,7 @@ myContainerSuffix = ".propellor" containerDesc :: (IsProp (Property i)) => ContainerId -> Property i -> Property i containerDesc cid p = p `describe` desc where - desc = "container " ++ fromContainerId cid ++ " " ++ propertyDesc p + desc = "container " ++ fromContainerId cid ++ " " ++ getDesc p runningContainer :: ContainerId -> Image -> [RunParam] -> Property Linux runningContainer cid@(ContainerId hn cn) image runps = containerDesc cid $ property "running" $ do @@ -574,7 +574,7 @@ chain hostlist hn s = case toContainerId s of Nothing -> errorMessage "bad container id" Just cid -> case findHostNoAlias hostlist hn of Nothing -> errorMessage ("cannot find host " ++ hn) - Just parenthost -> case M.lookup (containerName cid) (_dockerContainers $ getInfo $ hostInfo parenthost) of + Just parenthost -> case M.lookup (containerName cid) (_dockerContainers $ fromInfo $ hostInfo parenthost) of Nothing -> errorMessage ("cannot find container " ++ containerName cid ++ " docked on host " ++ hn) Just h -> go cid h where diff --git a/src/Propellor/Property/List.hs b/src/Propellor/Property/List.hs index 304d0863..a8b8347a 100644 --- a/src/Propellor/Property/List.hs +++ b/src/Propellor/Property/List.hs @@ -35,7 +35,7 @@ toProps ps = Props (map toChildProperty ps) propertyList :: SingI metatypes => Desc -> Props (MetaTypes metatypes) -> Property (MetaTypes metatypes) propertyList desc (Props ps) = property desc (ensureChildProperties cs) - `modifyChildren` (++ cs) + `addChildren` cs where cs = map toChildProperty ps @@ -44,7 +44,7 @@ propertyList desc (Props ps) = combineProperties :: SingI metatypes => Desc -> Props (MetaTypes metatypes) -> Property (MetaTypes metatypes) combineProperties desc (Props ps) = property desc (combineSatisfy cs NoChange) - `modifyChildren` (++ cs) + `addChildren` cs where cs = map toChildProperty ps diff --git a/src/Propellor/Property/Partition.hs b/src/Propellor/Property/Partition.hs index 5aff4ba4..291d4168 100644 --- a/src/Propellor/Property/Partition.hs +++ b/src/Propellor/Property/Partition.hs @@ -68,7 +68,7 @@ kpartx :: FilePath -> ([LoopDev] -> Property DebianLike) -> Property DebianLike kpartx diskimage mkprop = go `requires` Apt.installed ["kpartx"] where go :: Property DebianLike - go = property' (propertyDesc (mkprop [])) $ \w -> do + go = property' (getDesc (mkprop [])) $ \w -> do cleanup -- idempotency loopdevs <- liftIO $ kpartxParse <$> readProcess "kpartx" ["-avs", diskimage] diff --git a/src/Propellor/Property/Postfix.hs b/src/Propellor/Property/Postfix.hs index 7d9e7068..45aa4e42 100644 --- a/src/Propellor/Property/Postfix.hs +++ b/src/Propellor/Property/Postfix.hs @@ -304,7 +304,7 @@ saslAuthdInstalled = setupdaemon -- | Uses `saslpasswd2` to set the password for a user in the sasldb2 file. -- -- The password is taken from the privdata. -saslPasswdSet :: Domain -> User -> Property HasInfo +saslPasswdSet :: Domain -> User -> Property (HasInfo + UnixLike) saslPasswdSet domain (User user) = go `changesFileContent` "/etc/sasldb2" where go = withPrivData src ctx $ \getpw -> diff --git a/src/Propellor/Property/Scheduled.hs b/src/Propellor/Property/Scheduled.hs index 534e1e88..95e4e362 100644 --- a/src/Propellor/Property/Scheduled.hs +++ b/src/Propellor/Property/Scheduled.hs @@ -22,18 +22,18 @@ import qualified Data.Map as M -- last run. period :: (IsProp (Property i)) => Property i -> Recurrance -> Property i period prop recurrance = flip describe desc $ adjustPropertySatisfy prop $ \satisfy -> do - lasttime <- liftIO $ getLastChecked (propertyDesc prop) + lasttime <- liftIO $ getLastChecked (getDesc prop) nexttime <- liftIO $ fmap startTime <$> nextTime schedule lasttime t <- liftIO localNow if Just t >= nexttime then do r <- satisfy - liftIO $ setLastChecked t (propertyDesc prop) + liftIO $ setLastChecked t (getDesc prop) return r else noChange where schedule = Schedule recurrance AnyTime - desc = propertyDesc prop ++ " (period " ++ fromRecurrance recurrance ++ ")" + desc = getDesc prop ++ " (period " ++ fromRecurrance recurrance ++ ")" -- | Like period, but parse a human-friendly string. periodParse :: (IsProp (Property i)) => Property i -> String -> Property i diff --git a/src/Propellor/Property/Systemd.hs b/src/Propellor/Property/Systemd.hs index 2234ad5c..d909e4df 100644 --- a/src/Propellor/Property/Systemd.hs +++ b/src/Propellor/Property/Systemd.hs @@ -214,13 +214,13 @@ container name system mkchroot = Container name c h -- -- Reverting this property stops the container, removes the systemd unit, -- and deletes the chroot and all its contents. -nspawned :: Container -> RevertableProperty HasInfo +nspawned :: Container -> RevertableProperty (HasInfo + UnixLike) UnixLike nspawned c@(Container name (Chroot.Chroot loc builder _) h) = p `describe` ("nspawned " ++ name) where p = enterScript c `before` chrootprovisioned - `before` nspawnService c (_chrootCfg $ getInfo $ hostInfo h) + `before` nspawnService c (_chrootCfg $ fromInfo $ hostInfo h) `before` containerprovisioned -- Chroot provisioning is run in systemd-only mode, @@ -336,7 +336,7 @@ mungename = replace "/" "_" -- When there is no leading dash, "--" is prepended to the parameter. -- -- Reverting the property will remove a parameter, if it's present. -containerCfg :: String -> RevertableProperty HasInfo +containerCfg :: String -> RevertableProperty (HasInfo + UnixLike) UnixLike containerCfg p = RevertableProperty (mk True) (mk False) where mk b = pureInfoProperty ("container configuration " ++ (if b then "" else "without ") ++ p') $ @@ -348,18 +348,18 @@ containerCfg p = RevertableProperty (mk True) (mk False) -- | Bind mounts from the host into the container. -- -- This property is enabled by default. Revert it to disable it. -resolvConfed :: RevertableProperty HasInfo +resolvConfed :: RevertableProperty (HasInfo + UnixLike) UnixLike resolvConfed = containerCfg "bind=/etc/resolv.conf" -- | Link the container's journal to the host's if possible. -- (Only works if the host has persistent journal enabled.) -- -- This property is enabled by default. Revert it to disable it. -linkJournal :: RevertableProperty HasInfo +linkJournal :: RevertableProperty (HasInfo + UnixLike) UnixLike linkJournal = containerCfg "link-journal=try-guest" -- | Disconnect networking of the container from the host. -privateNetwork :: RevertableProperty HasInfo +privateNetwork :: RevertableProperty (HasInfo + UnixLike) UnixLike privateNetwork = containerCfg "private-network" class Publishable a where @@ -397,7 +397,7 @@ instance Publishable (Proto, Bound Port) where -- > & Systemd.running Systemd.networkd -- > & Systemd.publish (Port 80 ->- Port 8080) -- > & Apt.installedRunning "apache2" -publish :: Publishable p => p -> RevertableProperty HasInfo +publish :: Publishable p => p -> RevertableProperty (HasInfo + UnixLike) UnixLike publish p = containerCfg $ "--port=" ++ toPublish p class Bindable a where @@ -410,9 +410,9 @@ instance Bindable (Bound FilePath) where toBind v = hostSide v ++ ":" ++ containerSide v -- | Bind mount a file or directory from the host into the container. -bind :: Bindable p => p -> RevertableProperty HasInfo +bind :: Bindable p => p -> RevertableProperty (HasInfo + UnixLike) UnixLike bind p = containerCfg $ "--bind=" ++ toBind p -- | Read-only mind mount. -bindRo :: Bindable p => p -> RevertableProperty HasInfo +bindRo :: Bindable p => p -> RevertableProperty (HasInfo + UnixLike) UnixLike bindRo p = containerCfg $ "--bind-ro=" ++ toBind p diff --git a/src/Propellor/Spin.hs b/src/Propellor/Spin.hs index 5f103b8a..944696dd 100644 --- a/src/Propellor/Spin.hs +++ b/src/Propellor/Spin.hs @@ -90,7 +90,7 @@ spin' mprivdata relay target hst = do error "remote propellor failed" where hn = fromMaybe target relay - sys = case getInfo (hostInfo hst) of + sys = case fromInfo (hostInfo hst) of InfoVal o -> Just o NoInfoVal -> Nothing @@ -170,7 +170,7 @@ getSshTarget target hst return ip configips = map fromIPAddr $ mapMaybe getIPAddr $ - S.toList $ fromDnsInfo $ getInfo $ hostInfo hst + S.toList $ fromDnsInfo $ fromInfo $ hostInfo hst -- Update the privdata, repo url, and git repo over the ssh -- connection, talking to the user's local propellor instance which is diff --git a/src/Propellor/Types.hs b/src/Propellor/Types.hs index ccbfd3e0..2bddfc1a 100644 --- a/src/Propellor/Types.hs +++ b/src/Propellor/Types.hs @@ -26,11 +26,7 @@ module Propellor.Types , type (+) , addInfoProperty , addInfoProperty' - , addChildrenProperty , adjustPropertySatisfy - , propertyInfo - , propertyDesc - , propertyChildren , RevertableProperty(..) , () , ChildProperty @@ -124,12 +120,15 @@ type Desc = String -- internally, so you needn't worry about them. data Property metatypes = Property metatypes Desc (Propellor Result) Info [ChildProperty] +instance Show (Property metatypes) where + show p = "property " ++ show (getDesc p) + -- | Since there are many different types of Properties, they cannot be put -- into a list. The simplified ChildProperty can be put into a list. data ChildProperty = ChildProperty Desc (Propellor Result) Info [ChildProperty] instance Show ChildProperty where - show (ChildProperty desc _ _ _) = desc + show = getDesc -- | Constructs a Property, from a description and an action to run to -- ensure the Property is met. @@ -170,28 +169,10 @@ addInfoProperty' addInfoProperty' (Property t d a oldi c) newi = Property t d a (oldi <> newi) c --- | Adds children to a Property. -addChildrenProperty :: Property metatypes -> [ChildProperty] -> Property metatypes -addChildrenProperty (Property t s a i cs) cs' = Property t s a i (cs ++ cs') - -- | Changes the action that is performed to satisfy a property. adjustPropertySatisfy :: Property metatypes -> (Propellor Result -> Propellor Result) -> Property metatypes adjustPropertySatisfy (Property t d s i c) f = Property t d (f s) i c -propertyInfo :: Property metatypes -> Info -propertyInfo (Property _ _ _ i _) = i - -propertyDesc :: Property metatypes -> Desc -propertyDesc (Property _ d _ _ _) = d - -instance Show (Property metatypes) where - show p = "property " ++ show (propertyDesc p) - --- | A Property can include a list of child properties that it also --- satisfies. This allows them to be introspected to collect their info, etc. -propertyChildren :: Property metatypes -> [ChildProperty] -propertyChildren (Property _ _ _ _ c) = c - -- | A property that can be reverted. The first Property is run -- normally and the second is run when it's reverted. data RevertableProperty setupmetatypes undometatypes = RevertableProperty @@ -209,14 +190,16 @@ instance Show (RevertableProperty setupmetatypes undometatypes) where -> RevertableProperty setupmetatypes undometatypes setup undo = RevertableProperty setup undo --- | Class of types that can be used as properties of a host. class IsProp p where setDesc :: p -> Desc -> p getDesc :: p -> Desc - modifyChildren :: p -> ([ChildProperty] -> [ChildProperty]) -> p + getChildren :: p -> [ChildProperty] + addChildren :: p -> [ChildProperty] -> p -- | Gets the info of the property, combined with all info -- of all children properties. getInfoRecursive :: p -> Info + -- | Info, not including info from children. + getInfo :: p -> Info -- | Gets a ChildProperty representing the Property. -- You should not normally need to use this. toChildProperty :: p -> ChildProperty @@ -227,19 +210,23 @@ class IsProp p where instance IsProp (Property metatypes) where setDesc (Property t _ a i c) d = Property t d a i c - getDesc = propertyDesc - modifyChildren (Property t d a i c) f = Property t d a i (f c) + getDesc (Property _ d _ _ _) = d + getChildren (Property _ _ _ _ c) = c + addChildren (Property t d a i c) c' = Property t d a i (c ++ c') getInfoRecursive (Property _ _ _ i c) = i <> mconcat (map getInfoRecursive c) + getInfo (Property _ _ _ i _) = i toChildProperty (Property _ d a i c) = ChildProperty d a i c getSatisfy (Property _ _ a _ _) = a instance IsProp ChildProperty where setDesc (ChildProperty _ a i c) d = ChildProperty d a i c getDesc (ChildProperty d _ _ _) = d - modifyChildren (ChildProperty d a i c) f = ChildProperty d a i (f c) + getChildren (ChildProperty _ _ _ c) = c + addChildren (ChildProperty d a i c) c' = ChildProperty d a i (c ++ c') getInfoRecursive (ChildProperty _ _ i c) = i <> mconcat (map getInfoRecursive c) + getInfo (ChildProperty _ _ i _) = i toChildProperty = id getSatisfy (ChildProperty _ a _ _) = a @@ -248,9 +235,12 @@ instance IsProp (RevertableProperty setupmetatypes undometatypes) where setDesc (RevertableProperty p1 p2) d = RevertableProperty (setDesc p1 d) (setDesc p2 ("not " ++ d)) getDesc (RevertableProperty p1 _) = getDesc p1 - modifyChildren (RevertableProperty p1 p2) f = RevertableProperty (modifyChildren p1 f) (modifyChildren p2 f) + getChildren (RevertableProperty p1 _) = getChildren p1 + -- | Only add children to the active side. + addChildren (RevertableProperty p1 p2) c = RevertableProperty (addChildren p1 c) p2 -- | Return the Info of the currently active side. getInfoRecursive (RevertableProperty p1 _p2) = getInfoRecursive p1 + getInfo (RevertableProperty p1 _p2) = getInfo p1 toChildProperty (RevertableProperty p1 _p2) = toChildProperty p1 getSatisfy (RevertableProperty p1 _) = getSatisfy p1 diff --git a/src/Propellor/Types/Info.hs b/src/Propellor/Types/Info.hs index bc1543e2..c7f6b82f 100644 --- a/src/Propellor/Types/Info.hs +++ b/src/Propellor/Types/Info.hs @@ -5,7 +5,7 @@ module Propellor.Types.Info ( IsInfo(..), addInfo, toInfo, - getInfo, + fromInfo, mapInfo, propagatableInfo, InfoVal(..), @@ -51,8 +51,8 @@ toInfo :: IsInfo v => v -> Info toInfo = addInfo mempty -- The list is reversed here because addInfo builds it up in reverse order. -getInfo :: IsInfo v => Info -> v -getInfo (Info l) = mconcat (mapMaybe extractInfoEntry (reverse l)) +fromInfo :: IsInfo v => Info -> v +fromInfo (Info l) = mconcat (mapMaybe extractInfoEntry (reverse l)) -- | Maps a function over all values stored in the Info that are of the -- appropriate type. -- cgit v1.2.3 From 46fc5467e633a9c1f149cb0cd7ee03af1e9e0aa1 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Sat, 26 Mar 2016 21:38:39 -0400 Subject: 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. --- config-simple.hs | 7 -- src/Propellor/Container.hs | 6 +- src/Propellor/PropAccum.hs | 18 ++++ src/Propellor/Property/Chroot.hs | 2 +- src/Propellor/Property/Conductor.hs | 21 ++-- src/Propellor/Property/DiskImage.hs | 16 +-- src/Propellor/Property/Docker.hs | 111 ++++++++++++--------- .../Property/HostingProvider/CloudAtCost.hs | 33 +++--- src/Propellor/Property/Hostname.hs | 21 ++-- src/Propellor/Property/Ssh.hs | 9 +- 10 files changed, 137 insertions(+), 107 deletions(-) (limited to 'src/Propellor/Property/Docker.hs') 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 -- 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 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 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" -- cgit v1.2.3 From 5a04a37a4239c99b7367f796acee0ba6f1216879 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Sun, 27 Mar 2016 16:36:05 -0400 Subject: ported Systemd added mising method in docker --- src/Propellor/Property/Docker.hs | 1 + src/Propellor/Property/Systemd.hs | 121 +++++++++++++++++++++----------------- 2 files changed, 68 insertions(+), 54 deletions(-) (limited to 'src/Propellor/Property/Docker.hs') diff --git a/src/Propellor/Property/Docker.hs b/src/Propellor/Property/Docker.hs index 041e1987..3cb91fd4 100644 --- a/src/Propellor/Property/Docker.hs +++ b/src/Propellor/Property/Docker.hs @@ -93,6 +93,7 @@ data Container = Container Image Host instance IsContainer Container where containerProperties (Container _ h) = containerProperties h containerInfo (Container _ h) = containerInfo h + setContainerProperties (Container i h) ps = Container i (setContainerProperties h ps) class HasImage a where getImageName :: a -> Image diff --git a/src/Propellor/Property/Systemd.hs b/src/Propellor/Property/Systemd.hs index 7dc1ccd8..eaf7df8b 100644 --- a/src/Propellor/Property/Systemd.hs +++ b/src/Propellor/Property/Systemd.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleInstances, TypeFamilies #-} module Propellor.Property.Systemd ( -- * Services @@ -43,6 +43,7 @@ module Propellor.Property.Systemd ( import Propellor.Base import Propellor.Types.Chroot import Propellor.Types.Container +import Propellor.Container import Propellor.Types.Info import qualified Propellor.Property.Chroot as Chroot import qualified Propellor.Property.Apt as Apt @@ -61,23 +62,23 @@ type MachineName = String data Container = Container MachineName Chroot.Chroot Host deriving (Show) -instance PropAccum Container where - (Container n c h) `addProp` p = Container n c (h `addProp` p) - (Container n c h) `addPropFront` p = Container n c (h `addPropFront` p) - getProperties (Container _ _ h) = hostProperties h +instance IsContainer Container where + containerProperties (Container _ _ h) = containerProperties h + containerInfo (Container _ _ h) = containerInfo h + setContainerProperties (Container n c h) ps = Container n c (setContainerProperties h ps) -- | Starts a systemd service. -- -- Note that this does not configure systemd to start the service on boot, -- it only ensures that the service is currently running. started :: ServiceName -> Property Linux -started n = cmdProperty "systemctl" ["start", n] +started n = tightenTargets $ cmdProperty "systemctl" ["start", n] `assume` NoChange `describe` ("service " ++ n ++ " started") -- | Stops a systemd service. stopped :: ServiceName -> Property Linux -stopped n = cmdProperty "systemctl" ["stop", n] +stopped n = tightenTargets $ cmdProperty "systemctl" ["stop", n] `assume` NoChange `describe` ("service " ++ n ++ " stopped") @@ -86,24 +87,24 @@ stopped n = cmdProperty "systemctl" ["stop", n] -- This does not ensure the service is started, it only configures systemd -- to start it on boot. enabled :: ServiceName -> Property Linux -enabled n = cmdProperty "systemctl" ["enable", n] +enabled n = tightenTargets $ cmdProperty "systemctl" ["enable", n] `assume` NoChange `describe` ("service " ++ n ++ " enabled") -- | Disables a systemd service. disabled :: ServiceName -> Property Linux -disabled n = cmdProperty "systemctl" ["disable", n] +disabled n = tightenTargets $ cmdProperty "systemctl" ["disable", n] `assume` NoChange `describe` ("service " ++ n ++ " disabled") -- | Masks a systemd service. -masked :: ServiceName -> RevertableProperty Linux +masked :: ServiceName -> RevertableProperty Linux Linux masked n = systemdMask systemdUnmask where - systemdMask = cmdProperty "systemctl" ["mask", n] + systemdMask = tightenTargets $ cmdProperty "systemctl" ["mask", n] `assume` NoChange `describe` ("service " ++ n ++ " masked") - systemdUnmask = cmdProperty "systemctl" ["unmask", n] + systemdUnmask = tightenTargets $ cmdProperty "systemctl" ["unmask", n] `assume` NoChange `describe` ("service " ++ n ++ " unmasked") @@ -113,7 +114,7 @@ running n = started n `requires` enabled n -- | Restarts a systemd service. restarted :: ServiceName -> Property Linux -restarted n = cmdProperty "systemctl" ["restart", n] +restarted n = tightenTargets $ cmdProperty "systemctl" ["restart", n] `assume` NoChange `describe` ("service " ++ n ++ " restarted") @@ -128,14 +129,13 @@ journald = "systemd-journald" -- | Enables persistent storage of the journal. persistentJournal :: Property DebianLike persistentJournal = check (not <$> doesDirectoryExist dir) $ - combineProperties "persistent systemd journal" - [ cmdProperty "install" ["-d", "-g", "systemd-journal", dir] + combineProperties "persistent systemd journal" $ props + & cmdProperty "install" ["-d", "-g", "systemd-journal", dir] `assume` MadeChange - , cmdProperty "setfacl" ["-R", "-nm", "g:adm:rx,d:g:adm:rx", dir] + & Apt.installed ["acl"] + & cmdProperty "setfacl" ["-R", "-nm", "g:adm:rx,d:g:adm:rx", dir] `assume` MadeChange - , started "systemd-journal-flush" - ] - `requires` Apt.installed ["acl"] + & started "systemd-journal-flush" where dir = "/var/log/journal" @@ -149,10 +149,9 @@ type Option = String -- And it assumes the file already exists with -- the right [Header], so new lines can just be appended to the end. configured :: FilePath -> Option -> String -> Property Linux -configured cfgfile option value = combineProperties desc - [ File.fileProperty desc (mapMaybe removeother) cfgfile - , File.containsLine cfgfile line - ] +configured cfgfile option value = tightenTargets $ combineProperties desc $ props + & File.fileProperty desc (mapMaybe removeother) cfgfile + & File.containsLine cfgfile line where setting = option ++ "=" line = setting ++ value @@ -163,7 +162,7 @@ configured cfgfile option value = combineProperties desc -- | Causes systemd to reload its configuration files. daemonReloaded :: Property Linux -daemonReloaded = cmdProperty "systemctl" ["daemon-reload"] +daemonReloaded = tightenTargets $ cmdProperty "systemctl" ["daemon-reload"] `assume` NoChange -- | Configures journald, restarting it so the changes take effect. @@ -174,30 +173,33 @@ journaldConfigured option value = -- | Ensures machined and machinectl are installed machined :: Property Linux -machined = withOS "machined installed" $ \o -> +machined = withOS "machined installed" $ \w o -> case o of -- Split into separate debian package since systemd 225. (Just (System (Debian suite) _)) - | not (isStable suite) -> ensureProperty $ + | not (isStable suite) -> ensureProperty w $ Apt.installed ["systemd-container"] _ -> noChange -- | Defines a container with a given machine name, and operating system, -- and how to create its chroot if not already present. -- --- Properties can be added to configure the Container. +-- Properties can be added to configure the Container. At a minimum, +-- add a property such as `osDebian` to specify the operating system +-- to bootstrap. -- --- > container "webserver" (System (Debian Unstable) "amd64") (Chroot.debootstrapped mempty) +-- > container "webserver" (Chroot.debootstrapped mempty) +-- > & osDebian Unstable "amd64" -- > & Apt.installedRunning "apache2" -- > & ... -container :: MachineName -> System -> (FilePath -> Chroot.Chroot) -> Container -container name system mkchroot = Container name c h - & os system - & resolvConfed - & linkJournal +container :: MachineName -> (FilePath -> Chroot.Chroot) -> Container +container name mkchroot = + let c = Container name chroot h + in setContainerProps c $ containerProps c + &^ resolvConfed + &^ linkJournal where - c = mkchroot (containerDir name) - & os system + chroot = mkchroot (containerDir name) h = Host name [] mempty -- | Runs a container using systemd-nspawn. @@ -214,10 +216,11 @@ container name system mkchroot = Container name c h -- -- Reverting this property stops the container, removes the systemd unit, -- and deletes the chroot and all its contents. -nspawned :: Container -> RevertableProperty (HasInfo + UnixLike) UnixLike +nspawned :: Container -> RevertableProperty (HasInfo + Linux) Linux nspawned c@(Container name (Chroot.Chroot loc builder _) h) = p `describe` ("nspawned " ++ name) where + p :: RevertableProperty (HasInfo + Linux) Linux p = enterScript c `before` chrootprovisioned `before` nspawnService c (_chrootCfg $ fromInfo $ hostInfo h) @@ -230,8 +233,9 @@ nspawned c@(Container name (Chroot.Chroot loc builder _) h) = -- Use nsenter to enter container and and run propellor to -- finish provisioning. + containerprovisioned :: RevertableProperty Linux Linux containerprovisioned = - Chroot.propellChroot chroot (enterContainerProcess c) False + tightenTargets (Chroot.propellChroot chroot (enterContainerProcess c) False) doNothing @@ -239,7 +243,7 @@ nspawned c@(Container name (Chroot.Chroot loc builder _) h) = -- | Sets up the service file for the container, and then starts -- it running. -nspawnService :: Container -> ChrootCfg -> RevertableProperty Linux +nspawnService :: Container -> ChrootCfg -> RevertableProperty Linux Linux nspawnService (Container name _ _) cfg = setup teardown where service = nspawnServiceName name @@ -264,10 +268,12 @@ nspawnService (Container name _ _) cfg = setup teardown <$> servicefilecontent <*> catchDefaultIO "" (readFile servicefile) + writeservicefile :: Property Linux writeservicefile = property servicefile $ makeChange $ do c <- servicefilecontent File.viaStableTmp (\t -> writeFile t c) servicefile + setupservicefile :: Property Linux setupservicefile = check (not <$> goodservicefile) $ -- if it's running, it has the wrong configuration, -- so stop it @@ -275,8 +281,12 @@ nspawnService (Container name _ _) cfg = setup teardown `requires` daemonReloaded `requires` writeservicefile - setup = started service `requires` setupservicefile `requires` machined + setup :: Property Linux + setup = started service + `requires` setupservicefile + `requires` machined + teardown :: Property Linux teardown = check (doesFileExist servicefile) $ disabled service `requires` stopped service @@ -290,11 +300,12 @@ nspawnServiceParams (SystemdNspawnCfg ps) = -- -- This uses nsenter to enter the container, by looking up the pid of the -- container's init process and using its namespace. -enterScript :: Container -> RevertableProperty Linux -enterScript c@(Container name _ _) = setup teardown +enterScript :: Container -> RevertableProperty Linux Linux +enterScript c@(Container name _ _) = + tightenTargets setup tightenTargets teardown where - setup = combineProperties ("generated " ++ enterScriptFile c) - [ scriptfile `File.hasContent` + setup = combineProperties ("generated " ++ enterScriptFile c) $ props + & scriptfile `File.hasContent` [ "#!/usr/bin/perl" , "# Generated by propellor" , "my $pid=`machinectl show " ++ shellEscape name ++ " -p Leader | cut -d= -f2`;" @@ -309,8 +320,7 @@ enterScript c@(Container name _ _) = setup teardown , "}" , "exit(1);" ] - , scriptfile `File.mode` combineModes (readModes ++ executeModes) - ] + & scriptfile `File.mode` combineModes (readModes ++ executeModes) teardown = File.notPresent scriptfile scriptfile = enterScriptFile c @@ -336,11 +346,14 @@ mungename = replace "/" "_" -- When there is no leading dash, "--" is prepended to the parameter. -- -- Reverting the property will remove a parameter, if it's present. -containerCfg :: String -> RevertableProperty (HasInfo + UnixLike) UnixLike +containerCfg :: String -> RevertableProperty (HasInfo + Linux) (HasInfo + Linux) containerCfg p = RevertableProperty (mk True) (mk False) where - mk b = pureInfoProperty ("container configuration " ++ (if b then "" else "without ") ++ p') $ - mempty { _chrootCfg = SystemdNspawnCfg [(p', b)] } + mk b = tightenTargets $ + pureInfoProperty desc $ + mempty { _chrootCfg = SystemdNspawnCfg [(p', b)] } + where + desc = "container configuration " ++ (if b then "" else "without ") ++ p' p' = case p of ('-':_) -> p _ -> "--" ++ p @@ -348,18 +361,18 @@ containerCfg p = RevertableProperty (mk True) (mk False) -- | Bind mounts from the host into the container. -- -- This property is enabled by default. Revert it to disable it. -resolvConfed :: RevertableProperty (HasInfo + UnixLike) UnixLike +resolvConfed :: RevertableProperty (HasInfo + Linux) (HasInfo + Linux) resolvConfed = containerCfg "bind=/etc/resolv.conf" -- | Link the container's journal to the host's if possible. -- (Only works if the host has persistent journal enabled.) -- -- This property is enabled by default. Revert it to disable it. -linkJournal :: RevertableProperty (HasInfo + UnixLike) UnixLike +linkJournal :: RevertableProperty (HasInfo + Linux) (HasInfo + Linux) linkJournal = containerCfg "link-journal=try-guest" -- | Disconnect networking of the container from the host. -privateNetwork :: RevertableProperty (HasInfo + UnixLike) UnixLike +privateNetwork :: RevertableProperty (HasInfo + Linux) (HasInfo + Linux) privateNetwork = containerCfg "private-network" class Publishable a where @@ -397,7 +410,7 @@ instance Publishable (Proto, Bound Port) where -- > & Systemd.running Systemd.networkd -- > & Systemd.publish (Port 80 ->- Port 8080) -- > & Apt.installedRunning "apache2" -publish :: Publishable p => p -> RevertableProperty (HasInfo + UnixLike) UnixLike +publish :: Publishable p => p -> RevertableProperty (HasInfo + Linux) (HasInfo + Linux) publish p = containerCfg $ "--port=" ++ toPublish p class Bindable a where @@ -410,9 +423,9 @@ instance Bindable (Bound FilePath) where toBind v = hostSide v ++ ":" ++ containerSide v -- | Bind mount a file or directory from the host into the container. -bind :: Bindable p => p -> RevertableProperty (HasInfo + UnixLike) UnixLike +bind :: Bindable p => p -> RevertableProperty (HasInfo + Linux) (HasInfo + Linux) bind p = containerCfg $ "--bind=" ++ toBind p -- | Read-only mind mount. -bindRo :: Bindable p => p -> RevertableProperty (HasInfo + UnixLike) UnixLike +bindRo :: Bindable p => p -> RevertableProperty (HasInfo + Linux) (HasInfo + Linux) bindRo p = containerCfg $ "--bind-ro=" ++ toBind p -- cgit v1.2.3 From f6ccfeae4facbbddd1ef6818313700b990306d1b Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Sun, 27 Mar 2016 17:29:13 -0400 Subject: fix build --- src/Propellor/Property/Docker.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'src/Propellor/Property/Docker.hs') diff --git a/src/Propellor/Property/Docker.hs b/src/Propellor/Property/Docker.hs index 3cb91fd4..ddefef15 100644 --- a/src/Propellor/Property/Docker.hs +++ b/src/Propellor/Property/Docker.hs @@ -196,7 +196,7 @@ mkContainerInfo cid@(ContainerId hn _cn) (Container img h) = runparams = map (\(DockerRunParam mkparam) -> mkparam hn) (_dockerRunParams info) info = fromInfo $ hostInfo h' - h' = modifyHostProps h $ hostProps h + h' = setContainerProps h $ containerProps h -- Restart by default so container comes up on -- boot or when docker is upgraded. &^ restartAlways -- cgit v1.2.3 From 9d6dc29555b8499d8ae6c73c891b0b5dc19f83e5 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Sun, 27 Mar 2016 19:59:20 -0400 Subject: improve haddocks and move code around to make them more clear --- propellor.cabal | 1 + src/Propellor/Container.hs | 4 +- src/Propellor/Engine.hs | 4 +- src/Propellor/EnsureProperty.hs | 1 + src/Propellor/Info.hs | 28 +++++- src/Propellor/PrivData.hs | 2 +- src/Propellor/PropAccum.hs | 5 +- src/Propellor/Property.hs | 1 + src/Propellor/Property/Chroot.hs | 3 +- src/Propellor/Property/Concurrent.hs | 2 + src/Propellor/Property/Conductor.hs | 13 +-- src/Propellor/Property/Dns.hs | 2 +- src/Propellor/Property/Docker.hs | 3 +- src/Propellor/Property/FreeBSD/Pkg.hs | 4 +- src/Propellor/Property/List.hs | 2 + src/Propellor/Property/Partition.hs | 1 + src/Propellor/Property/Scheduled.hs | 1 + src/Propellor/Types.hs | 168 ++++++---------------------------- src/Propellor/Types/Core.hs | 106 +++++++++++++++++++++ src/Propellor/Types/Info.hs | 5 + 20 files changed, 196 insertions(+), 160 deletions(-) create mode 100644 src/Propellor/Types/Core.hs (limited to 'src/Propellor/Property/Docker.hs') diff --git a/propellor.cabal b/propellor.cabal index f11d2afe..e946f697 100644 --- a/propellor.cabal +++ b/propellor.cabal @@ -150,6 +150,7 @@ Library Propellor.EnsureProperty Propellor.Exception Propellor.Types + Propellor.Types.Core Propellor.Types.Chroot Propellor.Types.CmdLine Propellor.Types.Container diff --git a/src/Propellor/Container.hs b/src/Propellor/Container.hs index 4cd46ae5..c4d6f864 100644 --- a/src/Propellor/Container.hs +++ b/src/Propellor/Container.hs @@ -3,8 +3,10 @@ module Propellor.Container where import Propellor.Types +import Propellor.Types.Core import Propellor.Types.MetaTypes import Propellor.Types.Info +import Propellor.Info import Propellor.PrivData import Propellor.PropAccum @@ -54,7 +56,7 @@ propagateContainer containername c prop = prop convert p = let n = property (getDesc p) (getSatisfy p) :: Property UnixLike n' = n - `addInfoProperty` mapInfo (forceHostContext containername) + `setInfoProperty` mapInfo (forceHostContext containername) (propagatableInfo (getInfo p)) `addChildren` map convert (getChildren p) in toChildProperty n' diff --git a/src/Propellor/Engine.hs b/src/Propellor/Engine.hs index 4c37e704..f0035c40 100644 --- a/src/Propellor/Engine.hs +++ b/src/Propellor/Engine.hs @@ -4,7 +4,6 @@ module Propellor.Engine ( mainProperties, runPropellor, - ensureProperty, ensureChildProperties, fromHost, fromHost', @@ -23,10 +22,11 @@ import Control.Applicative import Prelude import Propellor.Types +import Propellor.Types.MetaTypes +import Propellor.Types.Core import Propellor.Message import Propellor.Exception import Propellor.Info -import Propellor.Property import Utility.Exception -- | Gets the Properties of a Host, and ensures them all, diff --git a/src/Propellor/EnsureProperty.hs b/src/Propellor/EnsureProperty.hs index f9094c5b..ce01d436 100644 --- a/src/Propellor/EnsureProperty.hs +++ b/src/Propellor/EnsureProperty.hs @@ -11,6 +11,7 @@ module Propellor.EnsureProperty ) where import Propellor.Types +import Propellor.Types.Core import Propellor.Types.MetaTypes import Propellor.Exception diff --git a/src/Propellor/Info.hs b/src/Propellor/Info.hs index ff0b3b5e..b87369c3 100644 --- a/src/Propellor/Info.hs +++ b/src/Propellor/Info.hs @@ -1,9 +1,11 @@ -{-# LANGUAGE PackageImports #-} +{-# LANGUAGE PackageImports, TypeFamilies, DataKinds, PolyKinds #-} module Propellor.Info ( osDebian, osBuntish, osFreeBSD, + setInfoProperty, + addInfoProperty, pureInfoProperty, pureInfoProperty', askInfo, @@ -22,6 +24,7 @@ module Propellor.Info ( import Propellor.Types import Propellor.Types.Info +import Propellor.Types.MetaTypes import "mtl" Control.Monad.Reader import qualified Data.Set as S @@ -31,11 +34,32 @@ import Data.Monoid import Control.Applicative import Prelude +-- | Adds info to a Property. +-- +-- The new Property will include HasInfo in its metatypes. +setInfoProperty + :: (MetaTypes metatypes' ~ (+) HasInfo metatypes, SingI metatypes') + => Property metatypes + -> Info + -> Property (MetaTypes metatypes') +setInfoProperty (Property _ d a oldi c) newi = + Property sing d a (oldi <> newi) c + +-- | Adds more info to a Property that already HasInfo. +addInfoProperty + :: (IncludesInfo metatypes ~ 'True) + => Property metatypes + -> Info + -> Property metatypes +addInfoProperty (Property t d a oldi c) newi = + Property t d a (oldi <> newi) c + +-- | Makes a property that does nothing but set some `Info`. pureInfoProperty :: (IsInfo v) => Desc -> v -> Property (HasInfo + UnixLike) pureInfoProperty desc v = pureInfoProperty' desc (toInfo v) pureInfoProperty' :: Desc -> Info -> Property (HasInfo + UnixLike) -pureInfoProperty' desc i = addInfoProperty p i +pureInfoProperty' desc i = setInfoProperty p i where p :: Property UnixLike p = property ("has " ++ desc) (return NoChange) diff --git a/src/Propellor/PrivData.hs b/src/Propellor/PrivData.hs index 0bc0c100..d3bb3a6d 100644 --- a/src/Propellor/PrivData.hs +++ b/src/Propellor/PrivData.hs @@ -127,7 +127,7 @@ withPrivData' feed srclist c mkprop = addinfo $ mkprop $ \a -> "Fix this by running:" : showSet (map (\s -> (privDataField s, Context cname, describePrivDataSource s)) srclist) return FailedChange - addinfo p = p `addInfoProperty'` (toInfo privset) + addinfo p = p `addInfoProperty` (toInfo privset) privset = PrivInfo $ S.fromList $ map (\s -> (privDataField s, describePrivDataSource s, hc)) srclist fieldnames = map show fieldlist diff --git a/src/Propellor/PropAccum.hs b/src/Propellor/PropAccum.hs index 856f2e8e..d9fa8ec7 100644 --- a/src/Propellor/PropAccum.hs +++ b/src/Propellor/PropAccum.hs @@ -16,6 +16,7 @@ module Propellor.PropAccum import Propellor.Types import Propellor.Types.MetaTypes +import Propellor.Types.Core import Propellor.Property import Data.Monoid @@ -30,10 +31,6 @@ import Prelude host :: HostName -> Props metatypes -> Host host hn (Props ps) = Host hn ps (mconcat (map getInfoRecursive ps)) --- | Props is a combination of a list of properties, with their combined --- metatypes. -data Props metatypes = Props [ChildProperty] - -- | Start accumulating a list of properties. -- -- Properties can be added to it using `(&)` etc. diff --git a/src/Propellor/Property.hs b/src/Propellor/Property.hs index 70583edc..29a8ec0f 100644 --- a/src/Propellor/Property.hs +++ b/src/Propellor/Property.hs @@ -53,6 +53,7 @@ import Control.Applicative import Prelude import Propellor.Types +import Propellor.Types.Core import Propellor.Types.ResultCheck import Propellor.Types.MetaTypes import Propellor.Info diff --git a/src/Propellor/Property/Chroot.hs b/src/Propellor/Property/Chroot.hs index 811b5baa..09047ce5 100644 --- a/src/Propellor/Property/Chroot.hs +++ b/src/Propellor/Property/Chroot.hs @@ -23,6 +23,7 @@ import Propellor.Container import Propellor.Types.CmdLine import Propellor.Types.Chroot import Propellor.Types.Info +import Propellor.Types.Core import Propellor.Property.Chroot.Util import qualified Propellor.Property.Debootstrap as Debootstrap import qualified Propellor.Property.Systemd.Core as Systemd @@ -151,7 +152,7 @@ provisioned' propigator c@(Chroot loc bootstrapper _) systemdonly = propagateChrootInfo :: Chroot -> Property Linux -> Property (HasInfo + Linux) propagateChrootInfo c@(Chroot location _ _) p = propagateContainer location c $ - p `addInfoProperty` chrootInfo c + p `setInfoProperty` chrootInfo c chrootInfo :: Chroot -> Info chrootInfo (Chroot loc _ h) = mempty `addInfo` diff --git a/src/Propellor/Property/Concurrent.hs b/src/Propellor/Property/Concurrent.hs index ace85a3c..e69dc17d 100644 --- a/src/Propellor/Property/Concurrent.hs +++ b/src/Propellor/Property/Concurrent.hs @@ -37,6 +37,8 @@ module Propellor.Property.Concurrent ( ) where import Propellor.Base +import Propellor.Types.Core +import Propellor.Types.MetaTypes import Control.Concurrent import qualified Control.Concurrent.Async as A diff --git a/src/Propellor/Property/Conductor.hs b/src/Propellor/Property/Conductor.hs index ab747acc..8aa18d20 100644 --- a/src/Propellor/Property/Conductor.hs +++ b/src/Propellor/Property/Conductor.hs @@ -83,16 +83,17 @@ import qualified Propellor.Property.Ssh as Ssh import qualified Data.Set as S -- | Class of things that can be conducted. +-- +-- There are instances for single hosts, and for lists of hosts. +-- With a list, each listed host will be conducted in turn. Failure to conduct +-- one host does not prevent conducting subsequent hosts in the list, but +-- will be propagated as an overall failure of the property. class Conductable c where conducts :: c -> RevertableProperty (HasInfo + UnixLike) (HasInfo + UnixLike) instance Conductable Host where - -- | Conduct the specified host. conducts h = conductorFor h notConductorFor h --- | Each host in the list will be conducted in turn. Failure to conduct --- one host does not prevent conducting subsequent hosts in the list, but --- will be propagated as an overall failure of the property. instance Conductable [Host] where conducts hs = propertyList desc (toProps $ map (setupRevertableProperty . conducts) hs) @@ -246,7 +247,7 @@ orchestrate' h (Conductor c l) -- to have any effect. conductorFor :: Host -> Property (HasInfo + UnixLike) conductorFor h = go - `addInfoProperty` (toInfo (ConductorFor [h])) + `setInfoProperty` (toInfo (ConductorFor [h])) `requires` setupRevertableProperty (conductorKnownHost h) `requires` Ssh.installed where @@ -270,7 +271,7 @@ conductorFor h = go -- Reverts conductorFor. notConductorFor :: Host -> Property (HasInfo + UnixLike) notConductorFor h = (doNothing :: Property UnixLike) - `addInfoProperty` (toInfo (NotConductorFor [h])) + `setInfoProperty` (toInfo (NotConductorFor [h])) `describe` desc `requires` undoRevertableProperty (conductorKnownHost h) where diff --git a/src/Propellor/Property/Dns.hs b/src/Propellor/Property/Dns.hs index 2b5596bd..2e2710a6 100644 --- a/src/Propellor/Property/Dns.hs +++ b/src/Propellor/Property/Dns.hs @@ -81,7 +81,7 @@ setupPrimary zonefile mknamedconffile hosts domain soa rs = (partialzone, zonewarnings) = genZone indomain hostmap domain soa baseprop = primaryprop - `addInfoProperty` (toInfo (addNamedConf conf)) + `setInfoProperty` (toInfo (addNamedConf conf)) primaryprop :: Property DebianLike primaryprop = property ("dns primary for " ++ domain) $ do sshfps <- concat <$> mapM (genSSHFP domain) (M.elems hostmap) diff --git a/src/Propellor/Property/Docker.hs b/src/Propellor/Property/Docker.hs index ddefef15..2ef97438 100644 --- a/src/Propellor/Property/Docker.hs +++ b/src/Propellor/Property/Docker.hs @@ -48,6 +48,7 @@ module Propellor.Property.Docker ( import Propellor.Base hiding (init) import Propellor.Types.Docker import Propellor.Types.Container +import Propellor.Types.Core import Propellor.Types.CmdLine import Propellor.Types.Info import Propellor.Container @@ -183,7 +184,7 @@ imagePulled ctr = pulled `describe` msg propagateContainerInfo :: Container -> Property (HasInfo + Linux) -> Property (HasInfo + Linux) propagateContainerInfo ctr@(Container _ h) p = propagateContainer cn ctr $ - p `addInfoProperty'` dockerinfo + p `addInfoProperty` dockerinfo where dockerinfo = dockerInfo $ mempty { _dockerContainers = M.singleton cn h } diff --git a/src/Propellor/Property/FreeBSD/Pkg.hs b/src/Propellor/Property/FreeBSD/Pkg.hs index 6c775b94..704c1db9 100644 --- a/src/Propellor/Property/FreeBSD/Pkg.hs +++ b/src/Propellor/Property/FreeBSD/Pkg.hs @@ -51,7 +51,7 @@ update = go = ifM (pkgUpdated <$> askInfo) ((noChange), (liftIO upd >> return MadeChange)) in (property "pkg update has run" go :: Property FreeBSD) - `addInfoProperty` (toInfo (PkgUpdate "")) + `setInfoProperty` (toInfo (PkgUpdate "")) newtype PkgUpgrade = PkgUpgrade String deriving (Typeable, Monoid, Show) @@ -68,7 +68,7 @@ upgrade = go = ifM (pkgUpgraded <$> askInfo) ((noChange), (liftIO upd >> return MadeChange)) in (property "pkg upgrade has run" go :: Property FreeBSD) - `addInfoProperty` (toInfo (PkgUpdate "")) + `setInfoProperty` (toInfo (PkgUpdate "")) `requires` update type Package = String diff --git a/src/Propellor/Property/List.hs b/src/Propellor/Property/List.hs index a8b8347a..0eec04c7 100644 --- a/src/Propellor/Property/List.hs +++ b/src/Propellor/Property/List.hs @@ -13,6 +13,8 @@ module Propellor.Property.List ( ) where import Propellor.Types +import Propellor.Types.Core +import Propellor.Types.MetaTypes import Propellor.PropAccum import Propellor.Engine import Propellor.Exception diff --git a/src/Propellor/Property/Partition.hs b/src/Propellor/Property/Partition.hs index 291d4168..2bf5b927 100644 --- a/src/Propellor/Property/Partition.hs +++ b/src/Propellor/Property/Partition.hs @@ -3,6 +3,7 @@ module Propellor.Property.Partition where import Propellor.Base +import Propellor.Types.Core import qualified Propellor.Property.Apt as Apt import Utility.Applicative diff --git a/src/Propellor/Property/Scheduled.hs b/src/Propellor/Property/Scheduled.hs index 95e4e362..729a3749 100644 --- a/src/Propellor/Property/Scheduled.hs +++ b/src/Propellor/Property/Scheduled.hs @@ -10,6 +10,7 @@ module Propellor.Property.Scheduled ) where import Propellor.Base +import Propellor.Types.Core import Utility.Scheduled import Data.Time.Clock diff --git a/src/Propellor/Types.hs b/src/Propellor/Types.hs index d5959cbb..6d6b14ea 100644 --- a/src/Propellor/Types.hs +++ b/src/Propellor/Types.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE PackageImports #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-} @@ -8,15 +7,18 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-} -module Propellor.Types - ( Host(..) +module Propellor.Types ( + -- * Core data types + Host(..) , Property(..) , property - , Info , Desc - , MetaType(..) - , MetaTypes - , TargetOS(..) + , RevertableProperty(..) + , () + , Propellor(..) + , LiftPropellor(..) + , Info + -- * Types of properties , UnixLike , Linux , DebianLike @@ -25,34 +27,22 @@ module Propellor.Types , FreeBSD , HasInfo , type (+) - , addInfoProperty - , addInfoProperty' - , adjustPropertySatisfy - , RevertableProperty(..) - , () - , ChildProperty - , IsProp(..) + , TightenTargets(..) + -- * Combining and modifying properties , Combines(..) , CombinedType , ResultCombiner - , Propellor(..) - , LiftPropellor(..) - , EndAction(..) + , adjustPropertySatisfy + -- * Other included types , module Propellor.Types.OS , module Propellor.Types.Dns , module Propellor.Types.Result , module Propellor.Types.ZFS - , TightenTargets(..) - , SingI ) where import Data.Monoid -import "mtl" Control.Monad.RWS.Strict -import Control.Monad.Catch -import Data.Typeable -import Control.Applicative -import Prelude +import Propellor.Types.Core import Propellor.Types.Info import Propellor.Types.OS import Propellor.Types.Dns @@ -60,89 +50,38 @@ import Propellor.Types.Result import Propellor.Types.MetaTypes import Propellor.Types.ZFS --- | Everything Propellor knows about a system: Its hostname, --- properties and their collected info. -data Host = Host - { hostName :: HostName - , hostProperties :: [ChildProperty] - , hostInfo :: Info - } - deriving (Show, Typeable) - --- | Propellor's monad provides read-only access to info about the host --- it's running on, and a writer to accumulate EndActions. -newtype Propellor p = Propellor { runWithHost :: RWST Host [EndAction] () IO p } - deriving - ( Monad - , Functor - , Applicative - , MonadReader Host - , MonadWriter [EndAction] - , MonadIO - , MonadCatch - , MonadThrow - , MonadMask - ) - -class LiftPropellor m where - liftPropellor :: m a -> Propellor a - -instance LiftPropellor Propellor where - liftPropellor = id - -instance LiftPropellor IO where - liftPropellor = liftIO - -instance Monoid (Propellor Result) where - mempty = return NoChange - -- | The second action is only run if the first action does not fail. - mappend x y = do - rx <- x - case rx of - FailedChange -> return FailedChange - _ -> do - ry <- y - return (rx <> ry) - --- | An action that Propellor runs at the end, after trying to satisfy all --- properties. It's passed the combined Result of the entire Propellor run. -data EndAction = EndAction Desc (Result -> Propellor Result) - -type Desc = String - -- | The core data type of Propellor, this represents a property --- that the system should have, with a descrition, an action to ensure --- it has the property, and perhaps some Info that can be added to Hosts +-- that the system should have, with a descrition, and an action to ensure +-- it has the property. -- that have the property. -- --- A property has a list of `[MetaType]`, which is part of its type. +-- There are different types of properties that target different OS's, +-- and so have different metatypes. +-- For example: "Property DebianLike" and "Property FreeBSD". -- --- There are many instances and type families, which are mostly used +-- Also, some properties have associated `Info`, which is indicated in +-- their type: "Property (HasInfo + DebianLike)" +-- +-- There are many associated type families, which are mostly used -- internally, so you needn't worry about them. data Property metatypes = Property metatypes Desc (Propellor Result) Info [ChildProperty] instance Show (Property metatypes) where show p = "property " ++ show (getDesc p) --- | Since there are many different types of Properties, they cannot be put --- into a list. The simplified ChildProperty can be put into a list. -data ChildProperty = ChildProperty Desc (Propellor Result) Info [ChildProperty] - -instance Show ChildProperty where - show = getDesc - -- | Constructs a Property, from a description and an action to run to -- ensure the Property is met. -- --- You can specify any metatypes that make sense to indicate what OS --- the property targets, etc. +-- Due to the polymorphic return type of this function, most uses will need +-- to specify a type signature. This lets you specify what OS the property +-- targets, etc. -- -- For example: -- -- > foo :: Property Debian --- > foo = mkProperty "foo" (...) --- --- Note that using this needs LANGUAGE PolyKinds. +-- > foo = property "foo" $ do +-- > ... +-- > return MadeChange property :: SingI metatypes => Desc @@ -150,26 +89,6 @@ property -> Property (MetaTypes metatypes) property d a = Property sing d a mempty mempty --- | Adds info to a Property. --- --- The new Property will include HasInfo in its metatypes. -addInfoProperty - :: (MetaTypes metatypes' ~ (+) HasInfo metatypes, SingI metatypes') - => Property metatypes - -> Info - -> Property (MetaTypes metatypes') -addInfoProperty (Property _ d a oldi c) newi = - Property sing d a (oldi <> newi) c - --- | Adds more info to a Property that already HasInfo. -addInfoProperty' - :: (IncludesInfo metatypes ~ 'True) - => Property metatypes - -> Info - -> Property metatypes -addInfoProperty' (Property t d a oldi c) newi = - Property t d a (oldi <> newi) c - -- | Changes the action that is performed to satisfy a property. adjustPropertySatisfy :: Property metatypes -> (Propellor Result -> Propellor Result) -> Property metatypes adjustPropertySatisfy (Property t d s i c) f = Property t d (f s) i c @@ -191,24 +110,6 @@ instance Show (RevertableProperty setupmetatypes undometatypes) where -> RevertableProperty setupmetatypes undometatypes setup undo = RevertableProperty setup undo -class IsProp p where - setDesc :: p -> Desc -> p - getDesc :: p -> Desc - getChildren :: p -> [ChildProperty] - addChildren :: p -> [ChildProperty] -> p - -- | Gets the info of the property, combined with all info - -- of all children properties. - getInfoRecursive :: p -> Info - -- | Info, not including info from children. - getInfo :: p -> Info - -- | Gets a ChildProperty representing the Property. - -- You should not normally need to use this. - toChildProperty :: p -> ChildProperty - -- | Gets the action that can be run to satisfy a Property. - -- You should never run this action directly. Use - -- 'Propellor.EnsureProperty.ensureProperty` instead. - getSatisfy :: p -> Propellor Result - instance IsProp (Property metatypes) where setDesc (Property t _ a i c) d = Property t d a i c getDesc (Property _ d _ _ _) = d @@ -220,17 +121,6 @@ instance IsProp (Property metatypes) where toChildProperty (Property _ d a i c) = ChildProperty d a i c getSatisfy (Property _ _ a _ _) = a -instance IsProp ChildProperty where - setDesc (ChildProperty _ a i c) d = ChildProperty d a i c - getDesc (ChildProperty d _ _ _) = d - getChildren (ChildProperty _ _ _ c) = c - addChildren (ChildProperty d a i c) c' = ChildProperty d a i (c ++ c') - getInfoRecursive (ChildProperty _ _ i c) = - i <> mconcat (map getInfoRecursive c) - getInfo (ChildProperty _ _ i _) = i - toChildProperty = id - getSatisfy (ChildProperty _ a _ _) = a - instance IsProp (RevertableProperty setupmetatypes undometatypes) where -- | Sets the description of both sides. setDesc (RevertableProperty p1 p2) d = diff --git a/src/Propellor/Types/Core.hs b/src/Propellor/Types/Core.hs new file mode 100644 index 00000000..fa939d2b --- /dev/null +++ b/src/Propellor/Types/Core.hs @@ -0,0 +1,106 @@ +{-# LANGUAGE PackageImports #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleInstances #-} + +module Propellor.Types.Core where + +import Propellor.Types.Info +import Propellor.Types.OS +import Propellor.Types.Result + +import Data.Monoid +import "mtl" Control.Monad.RWS.Strict +import Control.Monad.Catch +import Control.Applicative +import Prelude + +-- | Everything Propellor knows about a system: Its hostname, +-- properties and their collected info. +data Host = Host + { hostName :: HostName + , hostProperties :: [ChildProperty] + , hostInfo :: Info + } + deriving (Show, Typeable) + +-- | Propellor's monad provides read-only access to info about the host +-- it's running on, and a writer to accumulate EndActions. +newtype Propellor p = Propellor { runWithHost :: RWST Host [EndAction] () IO p } + deriving + ( Monad + , Functor + , Applicative + , MonadReader Host + , MonadWriter [EndAction] + , MonadIO + , MonadCatch + , MonadThrow + , MonadMask + ) + +class LiftPropellor m where + liftPropellor :: m a -> Propellor a + +instance LiftPropellor Propellor where + liftPropellor = id + +instance LiftPropellor IO where + liftPropellor = liftIO + +instance Monoid (Propellor Result) where + mempty = return NoChange + -- | The second action is only run if the first action does not fail. + mappend x y = do + rx <- x + case rx of + FailedChange -> return FailedChange + _ -> do + ry <- y + return (rx <> ry) + +-- | An action that Propellor runs at the end, after trying to satisfy all +-- properties. It's passed the combined Result of the entire Propellor run. +data EndAction = EndAction Desc (Result -> Propellor Result) + +type Desc = String + +-- | Props is a combination of a list of properties, with their combined +-- metatypes. +data Props metatypes = Props [ChildProperty] + +-- | Since there are many different types of Properties, they cannot be put +-- into a list. The simplified ChildProperty can be put into a list. +data ChildProperty = ChildProperty Desc (Propellor Result) Info [ChildProperty] + +instance Show ChildProperty where + show = getDesc + +class IsProp p where + setDesc :: p -> Desc -> p + getDesc :: p -> Desc + getChildren :: p -> [ChildProperty] + addChildren :: p -> [ChildProperty] -> p + -- | Gets the info of the property, combined with all info + -- of all children properties. + getInfoRecursive :: p -> Info + -- | Info, not including info from children. + getInfo :: p -> Info + -- | Gets a ChildProperty representing the Property. + -- You should not normally need to use this. + toChildProperty :: p -> ChildProperty + -- | Gets the action that can be run to satisfy a Property. + -- You should never run this action directly. Use + -- 'Propellor.EnsureProperty.ensureProperty` instead. + getSatisfy :: p -> Propellor Result + +instance IsProp ChildProperty where + setDesc (ChildProperty _ a i c) d = ChildProperty d a i c + getDesc (ChildProperty d _ _ _) = d + getChildren (ChildProperty _ _ _ c) = c + addChildren (ChildProperty d a i c) c' = ChildProperty d a i (c ++ c') + getInfoRecursive (ChildProperty _ _ i c) = + i <> mconcat (map getInfoRecursive c) + getInfo (ChildProperty _ _ i _) = i + toChildProperty = id + getSatisfy (ChildProperty _ a _ _) = a diff --git a/src/Propellor/Types/Info.hs b/src/Propellor/Types/Info.hs index c7f6b82f..2e188ae5 100644 --- a/src/Propellor/Types/Info.hs +++ b/src/Propellor/Types/Info.hs @@ -19,6 +19,9 @@ import Data.Monoid import Prelude -- | Information about a Host, which can be provided by its properties. +-- +-- Many different types of data can be contained in the same Info value +-- at the same time. See `toInfo` and `fromInfo`. newtype Info = Info [InfoEntry] deriving (Monoid, Show) @@ -47,6 +50,8 @@ class (Typeable v, Monoid v, Show v) => IsInfo v where addInfo :: IsInfo v => Info -> v -> Info addInfo (Info l) v = Info (InfoEntry v:l) +-- | Converts any value in the `IsInfo` type class into an Info, +-- which is otherwise empty. toInfo :: IsInfo v => v -> Info toInfo = addInfo mempty -- cgit v1.2.3