From 1edce2b72614e2e8eceefde97436db024799ff20 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Fri, 25 Mar 2016 15:28:31 -0400 Subject: ported Property.Apt --- config-simple.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) (limited to 'config-simple.hs') diff --git a/config-simple.hs b/config-simple.hs index 21accd18..28b38409 100644 --- a/config-simple.hs +++ b/config-simple.hs @@ -25,7 +25,7 @@ hosts = -- An example host. mybox :: Host -mybox = host "mybox.example.com" +mybox = host "mybox.example.com" $ props & os (System (Debian Unstable) "amd64") & Apt.stdSourcesList & Apt.unattendedUpgrades @@ -40,7 +40,7 @@ mybox = host "mybox.example.com" -- A generic webserver in a Docker container. webserverContainer :: Docker.Container -webserverContainer = Docker.container "webserver" (Docker.latestImage "debian") +webserverContainer = Docker.container "webserver" (Docker.latestImage "debian") $ props & os (System (Debian (Stable "jessie")) "amd64") & Apt.stdSourcesList & Docker.publish "80:80" -- 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 'config-simple.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 e4ac94860bcc4511370e878e14ef9d45b60aeb2a Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Sat, 26 Mar 2016 15:35:55 -0400 Subject: remove `os` property The new properties let the type checker know what the target OS is. --- config-freebsd.hs | 7 +++--- config-simple.hs | 2 +- debian/changelog | 2 ++ doc/haskell_newbie.mdwn | 4 ++-- src/Propellor/Info.hs | 51 ++++++++++++++++++++++++++++++++++------ src/Propellor/Property/Chroot.hs | 2 +- src/Propellor/Property/OS.hs | 2 +- 7 files changed, 54 insertions(+), 16 deletions(-) (limited to 'config-simple.hs') diff --git a/config-freebsd.hs b/config-freebsd.hs index b6334c31..07aeb391 100644 --- a/config-freebsd.hs +++ b/config-freebsd.hs @@ -28,7 +28,7 @@ hosts = -- An example freebsd host. freebsdbox :: Host freebsdbox = host "freebsdbox.example.com" - & os (System (FreeBSD (FBSDProduction FBSD102)) "amd64") + & osFreeBSD (FBSDProduction FBSD102) "amd64" & Pkg.update & Pkg.upgrade & Poudriere.poudriere poudriereZFS @@ -44,7 +44,7 @@ poudriereZFS = Poudriere.defaultConfig -- An example linux host. linuxbox :: Host linuxbox = host "linuxbox.example.com" - & os (System (Debian Unstable) "amd64") + & osDebian Unstable "amd64" & Apt.stdSourcesList & Apt.unattendedUpgrades & Apt.installed ["etckeeper"] @@ -59,9 +59,8 @@ linuxbox = host "linuxbox.example.com" -- A generic webserver in a Docker container. webserverContainer :: Docker.Container webserverContainer = Docker.container "webserver" (Docker.latestImage "debian") - & os (System (Debian (Stable "jessie")) "amd64") + & osDebian (Stable "jessie") "amd64" & Apt.stdSourcesList & Docker.publish "80:80" & Docker.volume "/var/www:/var/www" & Apt.serviceInstalledRunning "apache2" - diff --git a/config-simple.hs b/config-simple.hs index da1580c6..277e2edd 100644 --- a/config-simple.hs +++ b/config-simple.hs @@ -25,7 +25,7 @@ hosts = -- An example host. mybox :: Host mybox = host "mybox.example.com" $ props - & os (System (Debian Unstable) "amd64") + & osDebian Unstable "amd64" & Apt.stdSourcesList & Apt.unattendedUpgrades & Apt.installed ["etckeeper"] diff --git a/debian/changelog b/debian/changelog index 562eccd7..df518753 100644 --- a/debian/changelog +++ b/debian/changelog @@ -10,6 +10,8 @@ propellor (3.0.0) UNRELEASED; urgency=medium lists of properties. (If you have such a list, use `toProps`.) - And similarly, Chroot and Docker need `props` to be used to combine together the properies used inside them. + - The `os` property is removed. Instead use `osDebian`, `osBuntish`, + or `osFreeBSD`. These tell the type checker the target OS of a host. - Change "Property NoInfo" to "Property UnixLike" - Change "Property HasInfo" to "Property (HasInfo + UnixLike)" - Change "RevertableProperty NoInfo" to diff --git a/doc/haskell_newbie.mdwn b/doc/haskell_newbie.mdwn index a150b202..bd343cd6 100644 --- a/doc/haskell_newbie.mdwn +++ b/doc/haskell_newbie.mdwn @@ -48,12 +48,12 @@ Finally, you need to define the configuration for each host in the list: [[!format haskell """ mylaptop :: Host mylaptop = host "mylaptop.example.com" - & os (System (Debian Unstable) "amd64") + & osDebian Unstable "amd64" & Apt.stdSourcesList myserver :: Host myserver = host "server.example.com" - & os (System (Debian (Stable "jessie")) "amd64") + & osDebian (Stable "jessie") "amd64" & Apt.stdSourcesList & Apt.installed ["ssh"] """]] diff --git a/src/Propellor/Info.hs b/src/Propellor/Info.hs index 071bf4c2..725a02ad 100644 --- a/src/Propellor/Info.hs +++ b/src/Propellor/Info.hs @@ -1,6 +1,24 @@ {-# LANGUAGE PackageImports #-} -module Propellor.Info where +module Propellor.Info ( + osDebian, + osBuntish, + osFreeBSD, + pureInfoProperty, + pureInfoProperty', + askInfo, + getOS, + ipv4, + ipv6, + alias, + addDNS, + hostMap, + aliasMap, + findHost, + findHostNoAlias, + getAddresses, + hostAddresses, +) where import Propellor.Types import Propellor.Types.Info @@ -26,10 +44,32 @@ pureInfoProperty' desc i = addInfoProperty p i askInfo :: (IsInfo v) => Propellor v askInfo = asks (getInfo . hostInfo) --- | Specifies the operating system of a host. +-- | Specifies that a host's operating system is Debian, +-- and further indicates the suite and architecture. +-- +-- This provides info for other Properties, so they can act +-- conditionally on the details of the OS. -- --- This only provides info for other Properties, so they can act --- conditionally on the os. +-- It also lets the type checker know that all the properties of the +-- host must support Debian. +-- +-- > & osDebian (Stable "jessie") "amd64" +osDebian :: DebianSuite -> Architecture -> Property (HasInfo + Debian) +osDebian suite arch = tightenTargets $ os (System (Debian suite) arch) + +-- | Specifies that a host's operating system is a well-known Debian +-- derivative founded by a space tourist. +-- +-- (The actual name of this distribution is not used in Propellor per +-- ) +osBuntish :: Release -> Architecture -> Property (HasInfo + Buntish) +osBuntish release arch = tightenTargets $ os (System (Buntish release) arch) + +-- | Specifies that a host's operating system is FreeBSD +-- and further indicates the release and architecture. +osFreeBSD :: FreeBSDRelease -> Architecture -> Property (HasInfo + FreeBSD) +osFreeBSD release arch = tightenTargets $ os (System (FreeBSD release) arch) + os :: System -> Property (HasInfo + UnixLike) os system = pureInfoProperty ("Operating " ++ show system) (InfoVal system) @@ -105,6 +145,3 @@ getAddresses = mapMaybe getIPAddr . S.toList . fromDnsInfo . getInfo hostAddresses :: HostName -> [Host] -> [IPAddr] hostAddresses hn hosts = maybe [] (getAddresses . hostInfo) (findHost hosts hn) - -addHostInfo ::IsInfo v => Host -> v -> Host -addHostInfo h v = h { hostInfo = addInfo (hostInfo h) v } diff --git a/src/Propellor/Property/Chroot.hs b/src/Propellor/Property/Chroot.hs index bf6f2083..4480f98d 100644 --- a/src/Propellor/Property/Chroot.hs +++ b/src/Propellor/Property/Chroot.hs @@ -102,7 +102,7 @@ instance ChrootBootstrapper Debootstrapped where -- add the `os` property to specify the operating system to bootstrap. -- -- > debootstrapped Debootstrap.BuildD "/srv/chroot/ghc-dev" --- > & os (System (Debian Unstable) "amd64") +-- > & osDebian Unstable "amd64" -- > & Apt.installed ["ghc", "haskell-platform"] -- > & ... debootstrapped :: Debootstrap.DebootstrapConfig -> FilePath -> Chroot diff --git a/src/Propellor/Property/OS.hs b/src/Propellor/Property/OS.hs index 42504453..72753248 100644 --- a/src/Propellor/Property/OS.hs +++ b/src/Propellor/Property/OS.hs @@ -46,7 +46,7 @@ import Control.Exception (throw) -- install succeeds, to bootstrap from the cleanly installed system to -- a fully working system. For example: -- --- > & os (System (Debian Unstable) "amd64") +-- > & osDebian Unstable "amd64" -- > & cleanInstallOnce (Confirmed "foo.example.com") -- > `onChange` propertyList "fixing up after clean install" -- > [ preserveNetwork -- 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 'config-simple.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