From 95ac5163da904780ae166c2bf3a0addcb8d8870e Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Sun, 13 Apr 2014 15:34:01 -0400 Subject: Properties can now be satisfied differently on different operating systems. --- Propellor/Attr.hs | 7 +++++++ Propellor/Message.hs | 4 ++-- Propellor/Property.hs | 8 ++++++++ Propellor/Types.hs | 28 ++-------------------------- Propellor/Types/Attr.hs | 7 ++++++- Propellor/Types/OS.hs | 19 +++++++++++++++++++ config-joey.hs | 12 +++++++----- debian/changelog | 2 ++ propellor.cabal | 1 + 9 files changed, 54 insertions(+), 34 deletions(-) create mode 100644 Propellor/Types/OS.hs diff --git a/Propellor/Attr.hs b/Propellor/Attr.hs index 67ea8b8c..9a9d8446 100644 --- a/Propellor/Attr.hs +++ b/Propellor/Attr.hs @@ -21,6 +21,13 @@ hostname name = pureAttrProperty ("hostname " ++ name) $ getHostName :: Propellor HostName getHostName = asks _hostname +os :: System -> AttrProperty +os system = pureAttrProperty ("OS " ++ show system) $ + \d -> d { _os = Just system } + +getOS :: Propellor (Maybe System) +getOS = asks _os + cname :: Domain -> AttrProperty cname domain = pureAttrProperty ("cname " ++ domain) (addCName domain) diff --git a/Propellor/Message.hs b/Propellor/Message.hs index 2e63061e..780471c3 100644 --- a/Propellor/Message.hs +++ b/Propellor/Message.hs @@ -29,7 +29,7 @@ actionMessage desc a = do return r warningMessage :: MonadIO m => String -> m () -warningMessage s = liftIO $ colorLine Vivid Red $ "** warning: " ++ s +warningMessage s = liftIO $ colorLine Vivid Magenta $ "** warning: " ++ s colorLine :: ColorIntensity -> Color -> String -> IO () colorLine intensity color msg = do @@ -43,7 +43,7 @@ colorLine intensity color msg = do errorMessage :: String -> IO a errorMessage s = do - warningMessage s + liftIO $ colorLine Vivid Red $ "** error: " ++ s error "Cannot continue!" -- | Causes a debug message to be displayed when PROPELLOR_DEBUG=1 diff --git a/Propellor/Property.hs b/Propellor/Property.hs index 3e41fbcb..95d17c05 100644 --- a/Propellor/Property.hs +++ b/Propellor/Property.hs @@ -10,6 +10,7 @@ import "mtl" Control.Monad.Reader import Propellor.Types import Propellor.Types.Attr +import Propellor.Attr import Propellor.Engine import Utility.Monad import System.FilePath @@ -91,6 +92,13 @@ check c property = Property (propertyDesc property) $ ifM (liftIO c) , return NoChange ) +-- | Makes a property that is satisfied differently depending on the host's +-- operating system. +-- +-- Note that the operating system may not be declared for some hosts. +withOS :: Desc -> (Maybe System -> Propellor Result) -> Property +withOS desc a = Property desc $ a =<< getOS + boolProperty :: Desc -> IO Bool -> Property boolProperty desc a = Property desc $ ifM (liftIO a) ( return MadeChange diff --git a/Propellor/Types.hs b/Propellor/Types.hs index b8f8f167..5f575daf 100644 --- a/Propellor/Types.hs +++ b/Propellor/Types.hs @@ -6,8 +6,6 @@ module Propellor.Types ( Host(..) , Attr , HostName - , UserName - , GroupName , Propellor(..) , Property(..) , RevertableProperty(..) @@ -19,16 +17,12 @@ module Propellor.Types , requires , Desc , Result(..) - , System(..) - , Distribution(..) - , DebianSuite(..) - , Release - , Architecture , ActionResult(..) , CmdLine(..) , PrivDataField(..) , GpgKeyId , SshKeyType(..) + , module Propellor.Types.OS ) where import Data.Monoid @@ -38,12 +32,10 @@ import "mtl" Control.Monad.Reader import "MonadCatchIO-transformers" Control.Monad.CatchIO import Propellor.Types.Attr +import Propellor.Types.OS data Host = Host [Property] (Attr -> Attr) -type UserName = String -type GroupName = String - -- | Propellor's monad provides read-only access to attributes of the -- system. newtype Propellor p = Propellor { runWithAttr :: ReaderT Attr IO p } @@ -119,22 +111,6 @@ instance Monoid Result where mappend _ MadeChange = MadeChange mappend NoChange NoChange = NoChange --- | High level descritption of a operating system. -data System = System Distribution Architecture - deriving (Show) - -data Distribution - = Debian DebianSuite - | Ubuntu Release - deriving (Show) - -data DebianSuite = Experimental | Unstable | Testing | Stable | DebianRelease Release - deriving (Show, Eq) - -type Release = String - -type Architecture = String - -- | Results of actions, with color. class ActionResult a where getActionResult :: a -> (String, ColorIntensity, Color) diff --git a/Propellor/Types/Attr.hs b/Propellor/Types/Attr.hs index cdbe9ca3..1ff58148 100644 --- a/Propellor/Types/Attr.hs +++ b/Propellor/Types/Attr.hs @@ -1,11 +1,14 @@ module Propellor.Types.Attr where +import Propellor.Types.OS + import qualified Data.Set as S -- | The attributes of a host. For example, its hostname. data Attr = Attr { _hostname :: HostName , _cnames :: S.Set Domain + , _os :: Maybe System , _sshPubKey :: Maybe String , _dockerImage :: Maybe String @@ -16,6 +19,7 @@ instance Eq Attr where x == y = and [ _hostname x == _hostname y , _cnames x == _cnames y + , _os x == _os y , _sshPubKey x == _sshPubKey y , _dockerImage x == _dockerImage y @@ -27,13 +31,14 @@ instance Show Attr where show a = unlines [ "hostname " ++ _hostname a , "cnames " ++ show (_cnames a) + , "OS " ++ show (_os a) , "sshPubKey " ++ show (_sshPubKey a) , "docker image " ++ show (_dockerImage a) , "docker run params " ++ show (map (\mk -> mk "") (_dockerRunParams a)) ] newAttr :: HostName -> Attr -newAttr hn = Attr hn S.empty Nothing Nothing [] +newAttr hn = Attr hn S.empty Nothing Nothing Nothing [] type HostName = String type Domain = String diff --git a/Propellor/Types/OS.hs b/Propellor/Types/OS.hs new file mode 100644 index 00000000..5b0e376d --- /dev/null +++ b/Propellor/Types/OS.hs @@ -0,0 +1,19 @@ +module Propellor.Types.OS where + +type UserName = String +type GroupName = String + +-- | High level descritption of a operating system. +data System = System Distribution Architecture + deriving (Show, Eq) + +data Distribution + = Debian DebianSuite + | Ubuntu Release + deriving (Show, Eq) + +data DebianSuite = Experimental | Unstable | Testing | Stable | DebianRelease Release + deriving (Show, Eq) + +type Release = String +type Architecture = String diff --git a/config-joey.hs b/config-joey.hs index aba648dc..ed214e82 100644 --- a/config-joey.hs +++ b/config-joey.hs @@ -29,7 +29,7 @@ hosts = & Apt.buildDep ["git-annex"] `period` Daily -- Nothing super-important lives here. - , standardSystem "clam.kitenet.net" Unstable + , standardSystem "clam.kitenet.net" Unstable "amd64" & cleanCloudAtCost & Apt.unattendedUpgrades & Network.ipv6to4 @@ -53,7 +53,7 @@ hosts = & Apt.installed ["git-annex", "mtr", "screen"] -- Orca is the main git-annex build box. - , standardSystem "orca.kitenet.net" Unstable + , standardSystem "orca.kitenet.net" Unstable "amd64" & Hostname.sane & Apt.unattendedUpgrades & Docker.configured @@ -65,7 +65,7 @@ hosts = & Apt.buildDep ["git-annex"] `period` Daily -- Important stuff that needs not too much memory or CPU. - , standardSystem "diatom.kitenet.net" Stable + , standardSystem "diatom.kitenet.net" Stable "amd64" & Hostname.sane & Ssh.hostKey SshDsa & Ssh.hostKey SshRsa @@ -142,8 +142,9 @@ gitAnnexBuilder arch buildminute = Docker.container (arch ++ "-git-annex-builder & Apt.unattendedUpgrades -- This is my standard system setup. -standardSystem :: HostName -> DebianSuite -> Host -standardSystem hn suite = host hn +standardSystem :: HostName -> DebianSuite -> Architecture -> Host +standardSystem hn suite arch = host hn + & os (System (Debian suite) arch) & Apt.stdSourcesList suite `onChange` Apt.upgrade & Apt.installed ["etckeeper"] & Apt.installed ["ssh"] @@ -166,6 +167,7 @@ standardSystem hn suite = host hn -- This is my standard container setup, featuring automatic upgrades. standardContainer :: Docker.ContainerName -> DebianSuite -> Architecture -> Host standardContainer name suite arch = Docker.container name (image system) + & os (System (Debian suite) arch) & Apt.stdSourcesList suite & Apt.unattendedUpgrades where diff --git a/debian/changelog b/debian/changelog index b3cc554a..4c18df20 100644 --- a/debian/changelog +++ b/debian/changelog @@ -4,6 +4,8 @@ propellor (0.3.1) UNRELEASED; urgency=medium * Support for provisioning hosts with ssh and gpg keys. * Obnam support. * Apache support. + * Properties can now be satisfied differently on different operating + systems. -- Joey Hess Fri, 11 Apr 2014 15:00:11 -0400 diff --git a/propellor.cabal b/propellor.cabal index a7b7fbca..1d625381 100644 --- a/propellor.cabal +++ b/propellor.cabal @@ -97,6 +97,7 @@ Library Propellor.Engine Propellor.Exception Propellor.Types + Propellor.Types.OS Other-Modules: Propellor.Types.Attr Propellor.CmdLine -- cgit v1.2.3