summaryrefslogtreecommitdiff
path: root/Propellor
diff options
context:
space:
mode:
authorJoey Hess2014-04-13 15:34:01 -0400
committerJoey Hess2014-04-13 15:34:01 -0400
commit95ac5163da904780ae166c2bf3a0addcb8d8870e (patch)
treec476ec0951db984c2784a9e5ba7370bac333e64a /Propellor
parent576acfed33abfae2065354431100701713e83a23 (diff)
Properties can now be satisfied differently on different operating systems.
Diffstat (limited to 'Propellor')
-rw-r--r--Propellor/Attr.hs7
-rw-r--r--Propellor/Message.hs4
-rw-r--r--Propellor/Property.hs8
-rw-r--r--Propellor/Types.hs28
-rw-r--r--Propellor/Types/Attr.hs7
-rw-r--r--Propellor/Types/OS.hs19
6 files changed, 44 insertions, 29 deletions
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