From 7115d1ec162b4059b3e8e8f84bd8d5898c1db025 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 14 May 2014 19:41:05 -0400 Subject: moved source code to src This is to work around OSX's brain-damange regarding filename case insensitivity. Avoided moving config.hs, because it's a config file. Put in a symlink to make build work. --- src/Propellor/Types.hs | 153 +++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 153 insertions(+) create mode 100644 src/Propellor/Types.hs (limited to 'src/Propellor/Types.hs') diff --git a/src/Propellor/Types.hs b/src/Propellor/Types.hs new file mode 100644 index 00000000..22df9ddb --- /dev/null +++ b/src/Propellor/Types.hs @@ -0,0 +1,153 @@ +{-# LANGUAGE PackageImports #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ExistentialQuantification #-} + +module Propellor.Types + ( Host(..) + , Attr + , SetAttr + , Propellor(..) + , Property(..) + , RevertableProperty(..) + , IsProp + , describe + , toProp + , setAttr + , requires + , Desc + , Result(..) + , ActionResult(..) + , CmdLine(..) + , PrivDataField(..) + , GpgKeyId + , SshKeyType(..) + , module Propellor.Types.OS + , module Propellor.Types.Dns + ) where + +import Data.Monoid +import Control.Applicative +import System.Console.ANSI +import "mtl" Control.Monad.Reader +import "MonadCatchIO-transformers" Control.Monad.CatchIO + +import Propellor.Types.Attr +import Propellor.Types.OS +import Propellor.Types.Dns + +data Host = Host [Property] SetAttr + +-- | Propellor's monad provides read-only access to attributes of the +-- system. +newtype Propellor p = Propellor { runWithAttr :: ReaderT Attr IO p } + deriving + ( Monad + , Functor + , Applicative + , MonadReader Attr + , MonadIO + , MonadCatchIO + ) + +-- | The core data type of Propellor, this represents a property +-- that the system should have, and an action to ensure it has the +-- property. +data Property = Property + { propertyDesc :: Desc + , propertySatisfy :: Propellor Result + -- ^ must be idempotent; may run repeatedly + , propertyAttr :: SetAttr + -- ^ a property can set an Attr on the host that has the property. + } + +-- | A property that can be reverted. +data RevertableProperty = RevertableProperty Property Property + +class IsProp p where + -- | Sets description. + describe :: p -> Desc -> p + toProp :: p -> Property + -- | Indicates that the first property can only be satisfied + -- once the second one is. + requires :: p -> Property -> p + setAttr :: p -> SetAttr + +instance IsProp Property where + describe p d = p { propertyDesc = d } + toProp p = p + setAttr = propertyAttr + x `requires` y = Property (propertyDesc x) satisfy attr + where + attr = propertyAttr x . propertyAttr y + satisfy = do + r <- propertySatisfy y + case r of + FailedChange -> return FailedChange + _ -> propertySatisfy x + + +instance IsProp RevertableProperty where + -- | Sets the description of both sides. + describe (RevertableProperty p1 p2) d = + RevertableProperty (describe p1 d) (describe p2 ("not " ++ d)) + toProp (RevertableProperty p1 _) = p1 + (RevertableProperty p1 p2) `requires` y = + RevertableProperty (p1 `requires` y) p2 + -- | Return the SetAttr of the currently active side. + setAttr (RevertableProperty p1 _p2) = setAttr p1 + +type Desc = String + +data Result = NoChange | MadeChange | FailedChange + deriving (Read, Show, Eq) + +instance Monoid Result where + mempty = NoChange + + mappend FailedChange _ = FailedChange + mappend _ FailedChange = FailedChange + mappend MadeChange _ = MadeChange + mappend _ MadeChange = MadeChange + mappend NoChange NoChange = NoChange + +-- | Results of actions, with color. +class ActionResult a where + getActionResult :: a -> (String, ColorIntensity, Color) + +instance ActionResult Bool where + getActionResult False = ("failed", Vivid, Red) + getActionResult True = ("done", Dull, Green) + +instance ActionResult Result where + getActionResult NoChange = ("ok", Dull, Green) + getActionResult MadeChange = ("done", Vivid, Green) + getActionResult FailedChange = ("failed", Vivid, Red) + +data CmdLine + = Run HostName + | Spin HostName + | Boot HostName + | Set HostName PrivDataField + | AddKey String + | Continue CmdLine + | Chain HostName + | Docker HostName + deriving (Read, Show, Eq) + +-- | Note that removing or changing field names will break the +-- serialized privdata files, so don't do that! +-- It's fine to add new fields. +data PrivDataField + = DockerAuthentication + | SshPubKey SshKeyType UserName + | SshPrivKey SshKeyType UserName + | SshAuthorizedKeys UserName + | Password UserName + | PrivFile FilePath + | GpgKey GpgKeyId + deriving (Read, Show, Ord, Eq) + +type GpgKeyId = String + +data SshKeyType = SshRsa | SshDsa | SshEcdsa | SshEd25519 + deriving (Read, Show, Ord, Eq) -- cgit v1.2.3