2014-04-10 21:22:32 +00:00
|
|
|
{-# LANGUAGE PackageImports #-}
|
|
|
|
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
2014-04-11 01:09:20 +00:00
|
|
|
{-# LANGUAGE ExistentialQuantification #-}
|
|
|
|
|
|
|
|
module Propellor.Types
|
|
|
|
( Host(..)
|
|
|
|
, Attr
|
|
|
|
, HostName
|
|
|
|
, Propellor(..)
|
|
|
|
, Property(..)
|
|
|
|
, RevertableProperty(..)
|
|
|
|
, AttrProperty(..)
|
|
|
|
, IsProp
|
|
|
|
, describe
|
|
|
|
, toProp
|
|
|
|
, getAttr
|
|
|
|
, requires
|
|
|
|
, Desc
|
|
|
|
, Result(..)
|
|
|
|
, ActionResult(..)
|
|
|
|
, CmdLine(..)
|
|
|
|
, PrivDataField(..)
|
2014-04-13 01:34:25 +00:00
|
|
|
, GpgKeyId
|
|
|
|
, SshKeyType(..)
|
2014-04-13 19:34:01 +00:00
|
|
|
, module Propellor.Types.OS
|
2014-04-11 01:09:20 +00:00
|
|
|
) where
|
2014-03-30 23:10:32 +00:00
|
|
|
|
2014-03-31 14:36:45 +00:00
|
|
|
import Data.Monoid
|
2014-04-10 21:22:32 +00:00
|
|
|
import Control.Applicative
|
2014-03-31 22:31:08 +00:00
|
|
|
import System.Console.ANSI
|
2014-04-10 21:22:32 +00:00
|
|
|
import "mtl" Control.Monad.Reader
|
|
|
|
import "MonadCatchIO-transformers" Control.Monad.CatchIO
|
2014-03-31 14:36:45 +00:00
|
|
|
|
2014-04-11 01:09:20 +00:00
|
|
|
import Propellor.Types.Attr
|
2014-04-13 19:34:01 +00:00
|
|
|
import Propellor.Types.OS
|
2014-03-30 23:10:32 +00:00
|
|
|
|
2014-04-11 01:09:20 +00:00
|
|
|
data Host = Host [Property] (Attr -> Attr)
|
2014-03-30 23:10:32 +00:00
|
|
|
|
2014-04-10 21:22:32 +00:00
|
|
|
-- | Propellor's monad provides read-only access to attributes of the
|
|
|
|
-- system.
|
2014-04-11 01:09:20 +00:00
|
|
|
newtype Propellor p = Propellor { runWithAttr :: ReaderT Attr IO p }
|
2014-04-10 21:22:32 +00:00
|
|
|
deriving
|
|
|
|
( Monad
|
|
|
|
, Functor
|
|
|
|
, Applicative
|
2014-04-11 01:09:20 +00:00
|
|
|
, MonadReader Attr
|
2014-04-10 21:22:32 +00:00
|
|
|
, MonadIO
|
|
|
|
, MonadCatchIO
|
|
|
|
)
|
|
|
|
|
2014-04-11 01:09:20 +00:00
|
|
|
-- | 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
|
|
|
|
-- | must be idempotent; may run repeatedly
|
|
|
|
, propertySatisfy :: Propellor Result
|
2014-04-10 21:22:32 +00:00
|
|
|
}
|
|
|
|
|
2014-04-11 01:09:20 +00:00
|
|
|
-- | A property that can be reverted.
|
|
|
|
data RevertableProperty = RevertableProperty Property Property
|
2014-04-10 21:22:32 +00:00
|
|
|
|
2014-04-11 01:09:20 +00:00
|
|
|
-- | A property that affects the Attr.
|
|
|
|
data AttrProperty = forall p. IsProp p => AttrProperty p (Attr -> Attr)
|
2014-04-10 21:22:32 +00:00
|
|
|
|
2014-04-02 16:13:39 +00:00
|
|
|
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
|
2014-04-11 01:09:20 +00:00
|
|
|
getAttr :: p -> (Attr -> Attr)
|
2014-04-02 16:13:39 +00:00
|
|
|
|
|
|
|
instance IsProp Property where
|
|
|
|
describe p d = p { propertyDesc = d }
|
|
|
|
toProp p = p
|
|
|
|
x `requires` y = Property (propertyDesc x) $ do
|
|
|
|
r <- propertySatisfy y
|
|
|
|
case r of
|
|
|
|
FailedChange -> return FailedChange
|
|
|
|
_ -> propertySatisfy x
|
2014-04-11 01:09:20 +00:00
|
|
|
getAttr _ = id
|
2014-04-02 16:13:39 +00:00
|
|
|
|
|
|
|
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
|
2014-04-11 01:09:20 +00:00
|
|
|
getAttr _ = id
|
|
|
|
|
|
|
|
instance IsProp AttrProperty where
|
|
|
|
describe (AttrProperty p a) d = AttrProperty (describe p d) a
|
|
|
|
toProp (AttrProperty p _) = toProp p
|
|
|
|
(AttrProperty p a) `requires` y = AttrProperty (p `requires` y) a
|
|
|
|
getAttr (AttrProperty _ a) = a
|
2014-04-02 16:13:39 +00:00
|
|
|
|
2014-03-30 23:10:32 +00:00
|
|
|
type Desc = String
|
|
|
|
|
|
|
|
data Result = NoChange | MadeChange | FailedChange
|
2014-04-01 05:12:05 +00:00
|
|
|
deriving (Read, Show, Eq)
|
2014-03-30 23:10:32 +00:00
|
|
|
|
2014-03-31 14:36:45 +00:00
|
|
|
instance Monoid Result where
|
|
|
|
mempty = NoChange
|
|
|
|
|
|
|
|
mappend FailedChange _ = FailedChange
|
|
|
|
mappend _ FailedChange = FailedChange
|
|
|
|
mappend MadeChange _ = MadeChange
|
|
|
|
mappend _ MadeChange = MadeChange
|
|
|
|
mappend NoChange NoChange = NoChange
|
2014-03-31 22:31:08 +00:00
|
|
|
|
2014-04-01 20:58:11 +00:00
|
|
|
-- | Results of actions, with color.
|
2014-03-31 22:31:08 +00:00
|
|
|
class ActionResult a where
|
|
|
|
getActionResult :: a -> (String, ColorIntensity, Color)
|
|
|
|
|
|
|
|
instance ActionResult Bool where
|
2014-03-31 22:36:53 +00:00
|
|
|
getActionResult False = ("failed", Vivid, Red)
|
2014-04-02 04:52:39 +00:00
|
|
|
getActionResult True = ("done", Dull, Green)
|
2014-03-31 22:31:08 +00:00
|
|
|
|
|
|
|
instance ActionResult Result where
|
2014-04-02 04:52:39 +00:00
|
|
|
getActionResult NoChange = ("ok", Dull, Green)
|
2014-03-31 22:31:08 +00:00
|
|
|
getActionResult MadeChange = ("done", Vivid, Green)
|
|
|
|
getActionResult FailedChange = ("failed", Vivid, Red)
|
2014-04-01 17:51:58 +00:00
|
|
|
|
|
|
|
data CmdLine
|
|
|
|
= Run HostName
|
|
|
|
| Spin HostName
|
|
|
|
| Boot HostName
|
|
|
|
| Set HostName PrivDataField
|
|
|
|
| AddKey String
|
|
|
|
| Continue CmdLine
|
|
|
|
| Chain HostName
|
2014-04-02 00:47:25 +00:00
|
|
|
| Docker HostName
|
2014-04-01 17:51:58 +00:00
|
|
|
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
|
2014-04-13 01:43:30 +00:00
|
|
|
| SshPubKey SshKeyType UserName
|
|
|
|
| SshPrivKey SshKeyType UserName
|
2014-04-13 07:09:00 +00:00
|
|
|
| SshAuthorizedKeys UserName
|
2014-04-01 17:51:58 +00:00
|
|
|
| Password UserName
|
2014-04-08 20:58:11 +00:00
|
|
|
| PrivFile FilePath
|
2014-04-13 01:34:25 +00:00
|
|
|
| GpgKey GpgKeyId
|
2014-04-01 17:51:58 +00:00
|
|
|
deriving (Read, Show, Ord, Eq)
|
2014-04-02 16:13:39 +00:00
|
|
|
|
2014-04-13 01:34:25 +00:00
|
|
|
type GpgKeyId = String
|
2014-04-02 16:13:39 +00:00
|
|
|
|
2014-04-13 15:58:22 +00:00
|
|
|
data SshKeyType = SshRsa | SshDsa | SshEcdsa
|
2014-04-13 01:34:25 +00:00
|
|
|
deriving (Read, Show, Ord, Eq)
|