summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
authorJoey Hess2016-03-27 19:59:20 -0400
committerJoey Hess2016-03-27 19:59:20 -0400
commit9d6dc29555b8499d8ae6c73c891b0b5dc19f83e5 (patch)
tree875311342f65bcdc380b31a14be8def60533b670 /src
parent3383d008c7df57e6b5dd066fa1dfa80ac39cdd8e (diff)
improve haddocks and move code around to make them more clear
Diffstat (limited to 'src')
-rw-r--r--src/Propellor/Container.hs4
-rw-r--r--src/Propellor/Engine.hs4
-rw-r--r--src/Propellor/EnsureProperty.hs1
-rw-r--r--src/Propellor/Info.hs28
-rw-r--r--src/Propellor/PrivData.hs2
-rw-r--r--src/Propellor/PropAccum.hs5
-rw-r--r--src/Propellor/Property.hs1
-rw-r--r--src/Propellor/Property/Chroot.hs3
-rw-r--r--src/Propellor/Property/Concurrent.hs2
-rw-r--r--src/Propellor/Property/Conductor.hs13
-rw-r--r--src/Propellor/Property/Dns.hs2
-rw-r--r--src/Propellor/Property/Docker.hs3
-rw-r--r--src/Propellor/Property/FreeBSD/Pkg.hs4
-rw-r--r--src/Propellor/Property/List.hs2
-rw-r--r--src/Propellor/Property/Partition.hs1
-rw-r--r--src/Propellor/Property/Scheduled.hs1
-rw-r--r--src/Propellor/Types.hs168
-rw-r--r--src/Propellor/Types/Core.hs106
-rw-r--r--src/Propellor/Types/Info.hs5
19 files changed, 195 insertions, 160 deletions
diff --git a/src/Propellor/Container.hs b/src/Propellor/Container.hs
index 4cd46ae5..c4d6f864 100644
--- a/src/Propellor/Container.hs
+++ b/src/Propellor/Container.hs
@@ -3,8 +3,10 @@
module Propellor.Container where
import Propellor.Types
+import Propellor.Types.Core
import Propellor.Types.MetaTypes
import Propellor.Types.Info
+import Propellor.Info
import Propellor.PrivData
import Propellor.PropAccum
@@ -54,7 +56,7 @@ propagateContainer containername c prop = prop
convert p =
let n = property (getDesc p) (getSatisfy p) :: Property UnixLike
n' = n
- `addInfoProperty` mapInfo (forceHostContext containername)
+ `setInfoProperty` mapInfo (forceHostContext containername)
(propagatableInfo (getInfo p))
`addChildren` map convert (getChildren p)
in toChildProperty n'
diff --git a/src/Propellor/Engine.hs b/src/Propellor/Engine.hs
index 4c37e704..f0035c40 100644
--- a/src/Propellor/Engine.hs
+++ b/src/Propellor/Engine.hs
@@ -4,7 +4,6 @@
module Propellor.Engine (
mainProperties,
runPropellor,
- ensureProperty,
ensureChildProperties,
fromHost,
fromHost',
@@ -23,10 +22,11 @@ import Control.Applicative
import Prelude
import Propellor.Types
+import Propellor.Types.MetaTypes
+import Propellor.Types.Core
import Propellor.Message
import Propellor.Exception
import Propellor.Info
-import Propellor.Property
import Utility.Exception
-- | Gets the Properties of a Host, and ensures them all,
diff --git a/src/Propellor/EnsureProperty.hs b/src/Propellor/EnsureProperty.hs
index f9094c5b..ce01d436 100644
--- a/src/Propellor/EnsureProperty.hs
+++ b/src/Propellor/EnsureProperty.hs
@@ -11,6 +11,7 @@ module Propellor.EnsureProperty
) where
import Propellor.Types
+import Propellor.Types.Core
import Propellor.Types.MetaTypes
import Propellor.Exception
diff --git a/src/Propellor/Info.hs b/src/Propellor/Info.hs
index ff0b3b5e..b87369c3 100644
--- a/src/Propellor/Info.hs
+++ b/src/Propellor/Info.hs
@@ -1,9 +1,11 @@
-{-# LANGUAGE PackageImports #-}
+{-# LANGUAGE PackageImports, TypeFamilies, DataKinds, PolyKinds #-}
module Propellor.Info (
osDebian,
osBuntish,
osFreeBSD,
+ setInfoProperty,
+ addInfoProperty,
pureInfoProperty,
pureInfoProperty',
askInfo,
@@ -22,6 +24,7 @@ module Propellor.Info (
import Propellor.Types
import Propellor.Types.Info
+import Propellor.Types.MetaTypes
import "mtl" Control.Monad.Reader
import qualified Data.Set as S
@@ -31,11 +34,32 @@ import Data.Monoid
import Control.Applicative
import Prelude
+-- | Adds info to a Property.
+--
+-- The new Property will include HasInfo in its metatypes.
+setInfoProperty
+ :: (MetaTypes metatypes' ~ (+) HasInfo metatypes, SingI metatypes')
+ => Property metatypes
+ -> Info
+ -> Property (MetaTypes metatypes')
+setInfoProperty (Property _ d a oldi c) newi =
+ Property sing d a (oldi <> newi) c
+
+-- | Adds more info to a Property that already HasInfo.
+addInfoProperty
+ :: (IncludesInfo metatypes ~ 'True)
+ => Property metatypes
+ -> Info
+ -> Property metatypes
+addInfoProperty (Property t d a oldi c) newi =
+ Property t d a (oldi <> newi) c
+
+-- | Makes a property that does nothing but set some `Info`.
pureInfoProperty :: (IsInfo v) => Desc -> v -> Property (HasInfo + UnixLike)
pureInfoProperty desc v = pureInfoProperty' desc (toInfo v)
pureInfoProperty' :: Desc -> Info -> Property (HasInfo + UnixLike)
-pureInfoProperty' desc i = addInfoProperty p i
+pureInfoProperty' desc i = setInfoProperty p i
where
p :: Property UnixLike
p = property ("has " ++ desc) (return NoChange)
diff --git a/src/Propellor/PrivData.hs b/src/Propellor/PrivData.hs
index 0bc0c100..d3bb3a6d 100644
--- a/src/Propellor/PrivData.hs
+++ b/src/Propellor/PrivData.hs
@@ -127,7 +127,7 @@ withPrivData' feed srclist c mkprop = addinfo $ mkprop $ \a ->
"Fix this by running:" :
showSet (map (\s -> (privDataField s, Context cname, describePrivDataSource s)) srclist)
return FailedChange
- addinfo p = p `addInfoProperty'` (toInfo privset)
+ addinfo p = p `addInfoProperty` (toInfo privset)
privset = PrivInfo $ S.fromList $
map (\s -> (privDataField s, describePrivDataSource s, hc)) srclist
fieldnames = map show fieldlist
diff --git a/src/Propellor/PropAccum.hs b/src/Propellor/PropAccum.hs
index 856f2e8e..d9fa8ec7 100644
--- a/src/Propellor/PropAccum.hs
+++ b/src/Propellor/PropAccum.hs
@@ -16,6 +16,7 @@ module Propellor.PropAccum
import Propellor.Types
import Propellor.Types.MetaTypes
+import Propellor.Types.Core
import Propellor.Property
import Data.Monoid
@@ -30,10 +31,6 @@ import Prelude
host :: HostName -> Props metatypes -> Host
host hn (Props ps) = Host hn ps (mconcat (map getInfoRecursive ps))
--- | Props is a combination of a list of properties, with their combined
--- metatypes.
-data Props metatypes = Props [ChildProperty]
-
-- | Start accumulating a list of properties.
--
-- Properties can be added to it using `(&)` etc.
diff --git a/src/Propellor/Property.hs b/src/Propellor/Property.hs
index 70583edc..29a8ec0f 100644
--- a/src/Propellor/Property.hs
+++ b/src/Propellor/Property.hs
@@ -53,6 +53,7 @@ import Control.Applicative
import Prelude
import Propellor.Types
+import Propellor.Types.Core
import Propellor.Types.ResultCheck
import Propellor.Types.MetaTypes
import Propellor.Info
diff --git a/src/Propellor/Property/Chroot.hs b/src/Propellor/Property/Chroot.hs
index 811b5baa..09047ce5 100644
--- a/src/Propellor/Property/Chroot.hs
+++ b/src/Propellor/Property/Chroot.hs
@@ -23,6 +23,7 @@ import Propellor.Container
import Propellor.Types.CmdLine
import Propellor.Types.Chroot
import Propellor.Types.Info
+import Propellor.Types.Core
import Propellor.Property.Chroot.Util
import qualified Propellor.Property.Debootstrap as Debootstrap
import qualified Propellor.Property.Systemd.Core as Systemd
@@ -151,7 +152,7 @@ provisioned' propigator c@(Chroot loc bootstrapper _) systemdonly =
propagateChrootInfo :: Chroot -> Property Linux -> Property (HasInfo + Linux)
propagateChrootInfo c@(Chroot location _ _) p = propagateContainer location c $
- p `addInfoProperty` chrootInfo c
+ p `setInfoProperty` chrootInfo c
chrootInfo :: Chroot -> Info
chrootInfo (Chroot loc _ h) = mempty `addInfo`
diff --git a/src/Propellor/Property/Concurrent.hs b/src/Propellor/Property/Concurrent.hs
index ace85a3c..e69dc17d 100644
--- a/src/Propellor/Property/Concurrent.hs
+++ b/src/Propellor/Property/Concurrent.hs
@@ -37,6 +37,8 @@ module Propellor.Property.Concurrent (
) where
import Propellor.Base
+import Propellor.Types.Core
+import Propellor.Types.MetaTypes
import Control.Concurrent
import qualified Control.Concurrent.Async as A
diff --git a/src/Propellor/Property/Conductor.hs b/src/Propellor/Property/Conductor.hs
index ab747acc..8aa18d20 100644
--- a/src/Propellor/Property/Conductor.hs
+++ b/src/Propellor/Property/Conductor.hs
@@ -83,16 +83,17 @@ import qualified Propellor.Property.Ssh as Ssh
import qualified Data.Set as S
-- | Class of things that can be conducted.
+--
+-- There are instances for single hosts, and for lists of hosts.
+-- With a list, each listed host will be conducted in turn. Failure to conduct
+-- one host does not prevent conducting subsequent hosts in the list, but
+-- will be propagated as an overall failure of the property.
class Conductable c where
conducts :: c -> RevertableProperty (HasInfo + UnixLike) (HasInfo + UnixLike)
instance Conductable Host where
- -- | Conduct the specified host.
conducts h = conductorFor h <!> notConductorFor h
--- | Each host in the list will be conducted in turn. Failure to conduct
--- one host does not prevent conducting subsequent hosts in the list, but
--- will be propagated as an overall failure of the property.
instance Conductable [Host] where
conducts hs =
propertyList desc (toProps $ map (setupRevertableProperty . conducts) hs)
@@ -246,7 +247,7 @@ orchestrate' h (Conductor c l)
-- to have any effect.
conductorFor :: Host -> Property (HasInfo + UnixLike)
conductorFor h = go
- `addInfoProperty` (toInfo (ConductorFor [h]))
+ `setInfoProperty` (toInfo (ConductorFor [h]))
`requires` setupRevertableProperty (conductorKnownHost h)
`requires` Ssh.installed
where
@@ -270,7 +271,7 @@ conductorFor h = go
-- Reverts conductorFor.
notConductorFor :: Host -> Property (HasInfo + UnixLike)
notConductorFor h = (doNothing :: Property UnixLike)
- `addInfoProperty` (toInfo (NotConductorFor [h]))
+ `setInfoProperty` (toInfo (NotConductorFor [h]))
`describe` desc
`requires` undoRevertableProperty (conductorKnownHost h)
where
diff --git a/src/Propellor/Property/Dns.hs b/src/Propellor/Property/Dns.hs
index 2b5596bd..2e2710a6 100644
--- a/src/Propellor/Property/Dns.hs
+++ b/src/Propellor/Property/Dns.hs
@@ -81,7 +81,7 @@ setupPrimary zonefile mknamedconffile hosts domain soa rs =
(partialzone, zonewarnings) = genZone indomain hostmap domain soa
baseprop = primaryprop
- `addInfoProperty` (toInfo (addNamedConf conf))
+ `setInfoProperty` (toInfo (addNamedConf conf))
primaryprop :: Property DebianLike
primaryprop = property ("dns primary for " ++ domain) $ do
sshfps <- concat <$> mapM (genSSHFP domain) (M.elems hostmap)
diff --git a/src/Propellor/Property/Docker.hs b/src/Propellor/Property/Docker.hs
index ddefef15..2ef97438 100644
--- a/src/Propellor/Property/Docker.hs
+++ b/src/Propellor/Property/Docker.hs
@@ -48,6 +48,7 @@ module Propellor.Property.Docker (
import Propellor.Base hiding (init)
import Propellor.Types.Docker
import Propellor.Types.Container
+import Propellor.Types.Core
import Propellor.Types.CmdLine
import Propellor.Types.Info
import Propellor.Container
@@ -183,7 +184,7 @@ imagePulled ctr = pulled `describe` msg
propagateContainerInfo :: Container -> Property (HasInfo + Linux) -> Property (HasInfo + Linux)
propagateContainerInfo ctr@(Container _ h) p = propagateContainer cn ctr $
- p `addInfoProperty'` dockerinfo
+ p `addInfoProperty` dockerinfo
where
dockerinfo = dockerInfo $
mempty { _dockerContainers = M.singleton cn h }
diff --git a/src/Propellor/Property/FreeBSD/Pkg.hs b/src/Propellor/Property/FreeBSD/Pkg.hs
index 6c775b94..704c1db9 100644
--- a/src/Propellor/Property/FreeBSD/Pkg.hs
+++ b/src/Propellor/Property/FreeBSD/Pkg.hs
@@ -51,7 +51,7 @@ update =
go = ifM (pkgUpdated <$> askInfo) ((noChange), (liftIO upd >> return MadeChange))
in
(property "pkg update has run" go :: Property FreeBSD)
- `addInfoProperty` (toInfo (PkgUpdate ""))
+ `setInfoProperty` (toInfo (PkgUpdate ""))
newtype PkgUpgrade = PkgUpgrade String
deriving (Typeable, Monoid, Show)
@@ -68,7 +68,7 @@ upgrade =
go = ifM (pkgUpgraded <$> askInfo) ((noChange), (liftIO upd >> return MadeChange))
in
(property "pkg upgrade has run" go :: Property FreeBSD)
- `addInfoProperty` (toInfo (PkgUpdate ""))
+ `setInfoProperty` (toInfo (PkgUpdate ""))
`requires` update
type Package = String
diff --git a/src/Propellor/Property/List.hs b/src/Propellor/Property/List.hs
index a8b8347a..0eec04c7 100644
--- a/src/Propellor/Property/List.hs
+++ b/src/Propellor/Property/List.hs
@@ -13,6 +13,8 @@ module Propellor.Property.List (
) where
import Propellor.Types
+import Propellor.Types.Core
+import Propellor.Types.MetaTypes
import Propellor.PropAccum
import Propellor.Engine
import Propellor.Exception
diff --git a/src/Propellor/Property/Partition.hs b/src/Propellor/Property/Partition.hs
index 291d4168..2bf5b927 100644
--- a/src/Propellor/Property/Partition.hs
+++ b/src/Propellor/Property/Partition.hs
@@ -3,6 +3,7 @@
module Propellor.Property.Partition where
import Propellor.Base
+import Propellor.Types.Core
import qualified Propellor.Property.Apt as Apt
import Utility.Applicative
diff --git a/src/Propellor/Property/Scheduled.hs b/src/Propellor/Property/Scheduled.hs
index 95e4e362..729a3749 100644
--- a/src/Propellor/Property/Scheduled.hs
+++ b/src/Propellor/Property/Scheduled.hs
@@ -10,6 +10,7 @@ module Propellor.Property.Scheduled
) where
import Propellor.Base
+import Propellor.Types.Core
import Utility.Scheduled
import Data.Time.Clock
diff --git a/src/Propellor/Types.hs b/src/Propellor/Types.hs
index d5959cbb..6d6b14ea 100644
--- a/src/Propellor/Types.hs
+++ b/src/Propellor/Types.hs
@@ -1,4 +1,3 @@
-{-# LANGUAGE PackageImports #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
@@ -8,15 +7,18 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveDataTypeable #-}
-module Propellor.Types
- ( Host(..)
+module Propellor.Types (
+ -- * Core data types
+ Host(..)
, Property(..)
, property
- , Info
, Desc
- , MetaType(..)
- , MetaTypes
- , TargetOS(..)
+ , RevertableProperty(..)
+ , (<!>)
+ , Propellor(..)
+ , LiftPropellor(..)
+ , Info
+ -- * Types of properties
, UnixLike
, Linux
, DebianLike
@@ -25,34 +27,22 @@ module Propellor.Types
, FreeBSD
, HasInfo
, type (+)
- , addInfoProperty
- , addInfoProperty'
- , adjustPropertySatisfy
- , RevertableProperty(..)
- , (<!>)
- , ChildProperty
- , IsProp(..)
+ , TightenTargets(..)
+ -- * Combining and modifying properties
, Combines(..)
, CombinedType
, ResultCombiner
- , Propellor(..)
- , LiftPropellor(..)
- , EndAction(..)
+ , adjustPropertySatisfy
+ -- * Other included types
, module Propellor.Types.OS
, module Propellor.Types.Dns
, module Propellor.Types.Result
, module Propellor.Types.ZFS
- , TightenTargets(..)
- , SingI
) where
import Data.Monoid
-import "mtl" Control.Monad.RWS.Strict
-import Control.Monad.Catch
-import Data.Typeable
-import Control.Applicative
-import Prelude
+import Propellor.Types.Core
import Propellor.Types.Info
import Propellor.Types.OS
import Propellor.Types.Dns
@@ -60,89 +50,38 @@ import Propellor.Types.Result
import Propellor.Types.MetaTypes
import Propellor.Types.ZFS
--- | Everything Propellor knows about a system: Its hostname,
--- properties and their collected info.
-data Host = Host
- { hostName :: HostName
- , hostProperties :: [ChildProperty]
- , hostInfo :: Info
- }
- deriving (Show, Typeable)
-
--- | Propellor's monad provides read-only access to info about the host
--- it's running on, and a writer to accumulate EndActions.
-newtype Propellor p = Propellor { runWithHost :: RWST Host [EndAction] () IO p }
- deriving
- ( Monad
- , Functor
- , Applicative
- , MonadReader Host
- , MonadWriter [EndAction]
- , MonadIO
- , MonadCatch
- , MonadThrow
- , MonadMask
- )
-
-class LiftPropellor m where
- liftPropellor :: m a -> Propellor a
-
-instance LiftPropellor Propellor where
- liftPropellor = id
-
-instance LiftPropellor IO where
- liftPropellor = liftIO
-
-instance Monoid (Propellor Result) where
- mempty = return NoChange
- -- | The second action is only run if the first action does not fail.
- mappend x y = do
- rx <- x
- case rx of
- FailedChange -> return FailedChange
- _ -> do
- ry <- y
- return (rx <> ry)
-
--- | An action that Propellor runs at the end, after trying to satisfy all
--- properties. It's passed the combined Result of the entire Propellor run.
-data EndAction = EndAction Desc (Result -> Propellor Result)
-
-type Desc = String
-
-- | The core data type of Propellor, this represents a property
--- that the system should have, with a descrition, an action to ensure
--- it has the property, and perhaps some Info that can be added to Hosts
+-- that the system should have, with a descrition, and an action to ensure
+-- it has the property.
-- that have the property.
--
--- A property has a list of `[MetaType]`, which is part of its type.
+-- There are different types of properties that target different OS's,
+-- and so have different metatypes.
+-- For example: "Property DebianLike" and "Property FreeBSD".
--
--- There are many instances and type families, which are mostly used
+-- Also, some properties have associated `Info`, which is indicated in
+-- their type: "Property (HasInfo + DebianLike)"
+--
+-- There are many associated type families, which are mostly used
-- internally, so you needn't worry about them.
data Property metatypes = Property metatypes Desc (Propellor Result) Info [ChildProperty]
instance Show (Property metatypes) where
show p = "property " ++ show (getDesc p)
--- | Since there are many different types of Properties, they cannot be put
--- into a list. The simplified ChildProperty can be put into a list.
-data ChildProperty = ChildProperty Desc (Propellor Result) Info [ChildProperty]
-
-instance Show ChildProperty where
- show = getDesc
-
-- | Constructs a Property, from a description and an action to run to
-- ensure the Property is met.
--
--- You can specify any metatypes that make sense to indicate what OS
--- the property targets, etc.
+-- Due to the polymorphic return type of this function, most uses will need
+-- to specify a type signature. This lets you specify what OS the property
+-- targets, etc.
--
-- For example:
--
-- > foo :: Property Debian
--- > foo = mkProperty "foo" (...)
---
--- Note that using this needs LANGUAGE PolyKinds.
+-- > foo = property "foo" $ do
+-- > ...
+-- > return MadeChange
property
:: SingI metatypes
=> Desc
@@ -150,26 +89,6 @@ property
-> Property (MetaTypes metatypes)
property d a = Property sing d a mempty mempty
--- | Adds info to a Property.
---
--- The new Property will include HasInfo in its metatypes.
-addInfoProperty
- :: (MetaTypes metatypes' ~ (+) HasInfo metatypes, SingI metatypes')
- => Property metatypes
- -> Info
- -> Property (MetaTypes metatypes')
-addInfoProperty (Property _ d a oldi c) newi =
- Property sing d a (oldi <> newi) c
-
--- | Adds more info to a Property that already HasInfo.
-addInfoProperty'
- :: (IncludesInfo metatypes ~ 'True)
- => Property metatypes
- -> Info
- -> Property metatypes
-addInfoProperty' (Property t d a oldi c) newi =
- Property t d a (oldi <> newi) c
-
-- | 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
@@ -191,24 +110,6 @@ instance Show (RevertableProperty setupmetatypes undometatypes) where
-> RevertableProperty setupmetatypes undometatypes
setup <!> undo = RevertableProperty setup undo
-class IsProp p where
- setDesc :: p -> Desc -> p
- getDesc :: p -> Desc
- getChildren :: p -> [ChildProperty]
- addChildren :: p -> [ChildProperty] -> p
- -- | Gets the info of the property, combined with all info
- -- of all children properties.
- getInfoRecursive :: p -> Info
- -- | Info, not including info from children.
- getInfo :: p -> Info
- -- | 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.
- getSatisfy :: p -> Propellor Result
-
instance IsProp (Property metatypes) where
setDesc (Property t _ a i c) d = Property t d a i c
getDesc (Property _ d _ _ _) = d
@@ -220,17 +121,6 @@ instance IsProp (Property metatypes) where
toChildProperty (Property _ d a i c) = ChildProperty d a i c
getSatisfy (Property _ _ a _ _) = a
-instance IsProp ChildProperty where
- setDesc (ChildProperty _ a i c) d = ChildProperty d a i c
- getDesc (ChildProperty d _ _ _) = d
- getChildren (ChildProperty _ _ _ c) = c
- addChildren (ChildProperty d a i c) c' = ChildProperty d a i (c ++ c')
- getInfoRecursive (ChildProperty _ _ i c) =
- i <> mconcat (map getInfoRecursive c)
- getInfo (ChildProperty _ _ i _) = i
- toChildProperty = id
- getSatisfy (ChildProperty _ a _ _) = a
-
instance IsProp (RevertableProperty setupmetatypes undometatypes) where
-- | Sets the description of both sides.
setDesc (RevertableProperty p1 p2) d =
diff --git a/src/Propellor/Types/Core.hs b/src/Propellor/Types/Core.hs
new file mode 100644
index 00000000..fa939d2b
--- /dev/null
+++ b/src/Propellor/Types/Core.hs
@@ -0,0 +1,106 @@
+{-# LANGUAGE PackageImports #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE FlexibleInstances #-}
+
+module Propellor.Types.Core where
+
+import Propellor.Types.Info
+import Propellor.Types.OS
+import Propellor.Types.Result
+
+import Data.Monoid
+import "mtl" Control.Monad.RWS.Strict
+import Control.Monad.Catch
+import Control.Applicative
+import Prelude
+
+-- | Everything Propellor knows about a system: Its hostname,
+-- properties and their collected info.
+data Host = Host
+ { hostName :: HostName
+ , hostProperties :: [ChildProperty]
+ , hostInfo :: Info
+ }
+ deriving (Show, Typeable)
+
+-- | Propellor's monad provides read-only access to info about the host
+-- it's running on, and a writer to accumulate EndActions.
+newtype Propellor p = Propellor { runWithHost :: RWST Host [EndAction] () IO p }
+ deriving
+ ( Monad
+ , Functor
+ , Applicative
+ , MonadReader Host
+ , MonadWriter [EndAction]
+ , MonadIO
+ , MonadCatch
+ , MonadThrow
+ , MonadMask
+ )
+
+class LiftPropellor m where
+ liftPropellor :: m a -> Propellor a
+
+instance LiftPropellor Propellor where
+ liftPropellor = id
+
+instance LiftPropellor IO where
+ liftPropellor = liftIO
+
+instance Monoid (Propellor Result) where
+ mempty = return NoChange
+ -- | The second action is only run if the first action does not fail.
+ mappend x y = do
+ rx <- x
+ case rx of
+ FailedChange -> return FailedChange
+ _ -> do
+ ry <- y
+ return (rx <> ry)
+
+-- | An action that Propellor runs at the end, after trying to satisfy all
+-- properties. It's passed the combined Result of the entire Propellor run.
+data EndAction = EndAction Desc (Result -> Propellor Result)
+
+type Desc = String
+
+-- | Props is a combination of a list of properties, with their combined
+-- metatypes.
+data Props metatypes = Props [ChildProperty]
+
+-- | Since there are many different types of Properties, they cannot be put
+-- into a list. The simplified ChildProperty can be put into a list.
+data ChildProperty = ChildProperty Desc (Propellor Result) Info [ChildProperty]
+
+instance Show ChildProperty where
+ show = getDesc
+
+class IsProp p where
+ setDesc :: p -> Desc -> p
+ getDesc :: p -> Desc
+ getChildren :: p -> [ChildProperty]
+ addChildren :: p -> [ChildProperty] -> p
+ -- | Gets the info of the property, combined with all info
+ -- of all children properties.
+ getInfoRecursive :: p -> Info
+ -- | Info, not including info from children.
+ getInfo :: p -> Info
+ -- | 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.
+ getSatisfy :: p -> Propellor Result
+
+instance IsProp ChildProperty where
+ setDesc (ChildProperty _ a i c) d = ChildProperty d a i c
+ getDesc (ChildProperty d _ _ _) = d
+ getChildren (ChildProperty _ _ _ c) = c
+ addChildren (ChildProperty d a i c) c' = ChildProperty d a i (c ++ c')
+ getInfoRecursive (ChildProperty _ _ i c) =
+ i <> mconcat (map getInfoRecursive c)
+ getInfo (ChildProperty _ _ i _) = i
+ toChildProperty = id
+ getSatisfy (ChildProperty _ a _ _) = a
diff --git a/src/Propellor/Types/Info.hs b/src/Propellor/Types/Info.hs
index c7f6b82f..2e188ae5 100644
--- a/src/Propellor/Types/Info.hs
+++ b/src/Propellor/Types/Info.hs
@@ -19,6 +19,9 @@ import Data.Monoid
import Prelude
-- | Information about a Host, which can be provided by its properties.
+--
+-- Many different types of data can be contained in the same Info value
+-- at the same time. See `toInfo` and `fromInfo`.
newtype Info = Info [InfoEntry]
deriving (Monoid, Show)
@@ -47,6 +50,8 @@ class (Typeable v, Monoid v, Show v) => IsInfo v where
addInfo :: IsInfo v => Info -> v -> Info
addInfo (Info l) v = Info (InfoEntry v:l)
+-- | Converts any value in the `IsInfo` type class into an Info,
+-- which is otherwise empty.
toInfo :: IsInfo v => v -> Info
toInfo = addInfo mempty