summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--src/Propellor/Base.hs8
-rw-r--r--src/Propellor/PropAccum.hs14
-rw-r--r--src/Propellor/Property.hs10
-rw-r--r--src/Propellor/Property/List.hs10
-rw-r--r--src/Propellor/Property/User.hs29
5 files changed, 40 insertions, 31 deletions
diff --git a/src/Propellor/Base.hs b/src/Propellor/Base.hs
index 4afad2ab..2a0f5cbc 100644
--- a/src/Propellor/Base.hs
+++ b/src/Propellor/Base.hs
@@ -7,12 +7,12 @@ module Propellor.Base (
module Propellor.Types
, module Propellor.Property
, module Propellor.Property.Cmd
- --, module Propellor.Property.List
+ , module Propellor.Property.List
, module Propellor.Types.PrivData
, module Propellor.PropAccum
, module Propellor.Info
, module Propellor.PrivData
- --, module Propellor.Engine
+ , module Propellor.Engine
, module Propellor.Exception
, module Propellor.Message
, module Propellor.Debug
@@ -34,8 +34,8 @@ module Propellor.Base (
import Propellor.Types
import Propellor.Property
---import Propellor.Engine
---import Propellor.Property.List
+import Propellor.Engine
+import Propellor.Property.List
import Propellor.Property.Cmd
import Propellor.PrivData
import Propellor.Types.PrivData
diff --git a/src/Propellor/PropAccum.hs b/src/Propellor/PropAccum.hs
index 8177b97b..91d7b80d 100644
--- a/src/Propellor/PropAccum.hs
+++ b/src/Propellor/PropAccum.hs
@@ -30,17 +30,17 @@ import Propellor.PrivData
-- > ! oldproperty
-- > & otherproperty
host :: HostName -> Props metatypes -> Host
-host hn (Props i c) = Host hn c i
+host hn (Props c) = Host hn c (mconcat (map getInfoRecursive c))
-- | Props is a combination of a list of properties, with their combined
--- metatypes and info.
-data Props metatypes = Props Info [ChildProperty]
+-- metatypes.
+data Props metatypes = Props [ChildProperty]
-- | Start accumulating a list of properties.
--
-- Properties can be added to it using `(&)` etc.
props :: Props UnixLike
-props = Props mempty []
+props = Props []
infixl 1 &
infixl 1 &^
@@ -62,7 +62,7 @@ type instance GetMetaTypes (RevertableProperty (MetaTypes t) undo) = MetaTypes t
=> Props (MetaTypes x)
-> p
-> Props (MetaTypes (Combine x y))
-Props i c & p = Props (i <> getInfoRecursive p) (c ++ [toProp p])
+Props c & p = Props (c ++ [toProp p])
-- | Adds a property before any other properties.
(&^)
@@ -74,7 +74,7 @@ Props i c & p = Props (i <> getInfoRecursive p) (c ++ [toProp p])
=> Props (MetaTypes x)
-> p
-> Props (MetaTypes (Combine x y))
-Props i c &^ p = Props (i <> getInfoRecursive p) (toProp p : c)
+Props c &^ p = Props (toProp p : c)
-- | Adds a property in reverted form.
(!)
@@ -82,7 +82,7 @@ Props i c &^ p = Props (i <> getInfoRecursive p) (toProp p : c)
=> Props (MetaTypes x)
-> RevertableProperty (MetaTypes y) (MetaTypes z)
-> Props (MetaTypes (Combine x z))
-Props i c ! p = Props (i <> getInfoRecursive p) (c ++ [toProp (revert p)])
+Props c ! p = Props (c ++ [toProp (revert p)])
{-
diff --git a/src/Propellor/Property.hs b/src/Propellor/Property.hs
index 8999d8d8..ba30209e 100644
--- a/src/Propellor/Property.hs
+++ b/src/Propellor/Property.hs
@@ -255,12 +255,12 @@ isNewerThan x y = do
tightenTargets
::
-- Note that this uses PolyKinds
- ( (Targets old `NotSuperset` Targets new) ~ 'CanCombine
- , (NonTargets new `NotSuperset` NonTargets old) ~ 'CanCombine
- , SingI new
+ ( (Targets untightened `NotSuperset` Targets tightened) ~ 'CanCombine
+ , (NonTargets tightened `NotSuperset` NonTargets untightened) ~ 'CanCombine
+ , SingI tightened
)
- => Property (MetaTypes old)
- -> Property (MetaTypes new)
+ => Property (MetaTypes untightened)
+ -> Property (MetaTypes tightened)
tightenTargets (Property _old d a i c) = Property sing d a i c
{-
diff --git a/src/Propellor/Property/List.hs b/src/Propellor/Property/List.hs
index b4a72fa8..44916f23 100644
--- a/src/Propellor/Property/List.hs
+++ b/src/Propellor/Property/List.hs
@@ -7,18 +7,22 @@
module Propellor.Property.List (
props,
Props,
+ toProps,
propertyList,
combineProperties,
) where
import Propellor.Types
import Propellor.Types.MetaTypes
-import Propellor.Engine
import Propellor.PropAccum
+import Propellor.Engine
import Propellor.Exception
import Data.Monoid
+toProps :: [Property (MetaTypes metatypes)] -> Props (MetaTypes metatypes)
+toProps ps = Props (map toProp ps)
+
-- | Combines a list of properties, resulting in a single property
-- that when run will run each property in the list in turn,
-- and print out the description of each as it's run. Does not stop
@@ -30,7 +34,7 @@ import Data.Monoid
-- > & bar
-- > & baz
propertyList :: SingI metatypes => Desc -> Props (MetaTypes metatypes) -> Property (MetaTypes metatypes)
-propertyList desc (Props _i ps) =
+propertyList desc (Props ps) =
property desc (ensureChildProperties cs)
`modifyChildren` (++ cs)
where
@@ -39,7 +43,7 @@ propertyList desc (Props _i ps) =
-- | Combines a list of properties, resulting in one property that
-- ensures each in turn. Stops if a property fails.
combineProperties :: SingI metatypes => Desc -> Props (MetaTypes metatypes) -> Property (MetaTypes metatypes)
-combineProperties desc (Props _i ps) =
+combineProperties desc (Props ps) =
property desc (combineSatisfy cs NoChange)
`modifyChildren` (++ cs)
where
diff --git a/src/Propellor/Property/User.hs b/src/Propellor/Property/User.hs
index 8cbd11e4..76eae647 100644
--- a/src/Propellor/Property/User.hs
+++ b/src/Propellor/Property/User.hs
@@ -8,7 +8,7 @@ import qualified Propellor.Property.File as File
data Eep = YesReallyDeleteHome
accountFor :: User -> Property DebianLike
-accountFor user@(User u) = check nohomedir go
+accountFor user@(User u) = tightenTargets $ check nohomedir go
`describe` ("account for " ++ u)
where
nohomedir = isNothing <$> catchMaybeIO (homedir user)
@@ -22,7 +22,7 @@ systemAccountFor :: User -> Property DebianLike
systemAccountFor user@(User u) = systemAccountFor' user Nothing (Just (Group u))
systemAccountFor' :: User -> Maybe FilePath -> Maybe Group -> Property DebianLike
-systemAccountFor' (User u) mhome mgroup = check nouser go
+systemAccountFor' (User u) mhome mgroup = tightenTargets $ check nouser go
`describe` ("system account for " ++ u)
where
nouser = isNothing <$> catchMaybeIO (getUserEntryForName u)
@@ -44,7 +44,7 @@ systemAccountFor' (User u) mhome mgroup = check nouser go
-- | Removes user home directory!! Use with caution.
nuked :: User -> Eep -> Property DebianLike
-nuked user@(User u) _ = check hashomedir go
+nuked user@(User u) _ = tightenTargets $ check hashomedir go
`describe` ("nuked user " ++ u)
where
hashomedir = isJust <$> catchMaybeIO (homedir user)
@@ -75,8 +75,10 @@ hasPassword :: User -> Property (HasInfo + DebianLike)
hasPassword user = hasPassword' user hostContext
hasPassword' :: IsContext c => User -> c -> Property (HasInfo + DebianLike)
-hasPassword' (User u) context = go `requires` shadowConfig True
+hasPassword' (User u) context = go
+ `requires` shadowConfig True
where
+ go :: Property (HasInfo + UnixLike)
go = withSomePrivData srcs context $
property (u ++ " has password") . setPassword
srcs =
@@ -105,8 +107,9 @@ chpasswd (User user) v ps = makeChange $ withHandle StdinHandle createProcessSuc
hClose h
lockedPassword :: User -> Property DebianLike
-lockedPassword user@(User u) = check (not <$> isLockedPassword user) go
- `describe` ("locked " ++ u ++ " password")
+lockedPassword user@(User u) = tightenTargets $
+ check (not <$> isLockedPassword user) go
+ `describe` ("locked " ++ u ++ " password")
where
go = cmdProperty "passwd"
[ "--lock"
@@ -131,7 +134,7 @@ homedir :: User -> IO FilePath
homedir (User user) = homeDirectory <$> getUserEntryForName user
hasGroup :: User -> Group -> Property DebianLike
-hasGroup (User user) (Group group') = check test go
+hasGroup (User user) (Group group') = tightenTargets $ check test go
`describe` unwords ["user", user, "in group", group']
where
test = not . elem group' . words <$> readProcess "groups" [user]
@@ -150,7 +153,8 @@ hasDesktopGroups user@(User u) = property' desc $ \o -> do
existinggroups <- map (fst . break (== ':')) . lines
<$> liftIO (readFile "/etc/group")
let toadd = filter (`elem` existinggroups) desktopgroups
- ensureProperty o $ propertyList desc $ map (hasGroup user . Group) toadd
+ ensureProperty o $ propertyList desc $ toProps $
+ map (hasGroup user . Group) toadd
where
desc = "user " ++ u ++ " is in standard desktop groups"
-- This list comes from user-setup's debconf
@@ -171,10 +175,10 @@ hasDesktopGroups user@(User u) = property' desc $ \o -> do
-- | Controls whether shadow passwords are enabled or not.
shadowConfig :: Bool -> Property DebianLike
-shadowConfig True = check (not <$> shadowExists)
+shadowConfig True = tightenTargets $ check (not <$> shadowExists)
(cmdProperty "shadowconfig" ["on"])
`describe` "shadow passwords enabled"
-shadowConfig False = check shadowExists
+shadowConfig False = tightenTargets $ check shadowExists
(cmdProperty "shadowconfig" ["off"])
`describe` "shadow passwords disabled"
@@ -187,7 +191,7 @@ hasLoginShell :: User -> FilePath -> Property DebianLike
hasLoginShell user loginshell = shellSetTo user loginshell `requires` shellEnabled loginshell
shellSetTo :: User -> FilePath -> Property DebianLike
-shellSetTo (User u) loginshell = check needchangeshell
+shellSetTo (User u) loginshell = tightenTargets $ check needchangeshell
(cmdProperty "chsh" ["--shell", loginshell, u])
`describe` (u ++ " has login shell " ++ loginshell)
where
@@ -197,4 +201,5 @@ shellSetTo (User u) loginshell = check needchangeshell
-- | Ensures that /etc/shells contains a shell.
shellEnabled :: FilePath -> Property DebianLike
-shellEnabled loginshell = "/etc/shells" `File.containsLine` loginshell
+shellEnabled loginshell = tightenTargets $
+ "/etc/shells" `File.containsLine` loginshell