propellor

propellor config for hosts.
git clone git://git.ricketyspace.net/propellor.git
Log | Files | Refs | LICENSE

Property.hs (11464B)


      1 {-# LANGUAGE PackageImports #-}
      2 {-# LANGUAGE FlexibleContexts #-}
      3 {-# LANGUAGE FlexibleInstances #-}
      4 {-# LANGUAGE DataKinds #-}
      5 {-# LANGUAGE TypeFamilies #-}
      6 {-# LANGUAGE PolyKinds #-}
      7 
      8 module Propellor.Property (
      9 	-- * Property combinators
     10 	  requires
     11 	, before
     12 	, onChange
     13 	, onChangeFlagOnFail
     14 	, flagFile
     15 	, flagFile'
     16 	, check
     17 	, fallback
     18 	, revert
     19 	-- * Property descriptions
     20 	, describe
     21 	, (==>)
     22 	-- * Constructing properties
     23 	, Propellor
     24 	, property
     25 	, property'
     26 	, OuterMetaTypesWitness
     27 	, ensureProperty
     28 	, pickOS
     29 	, withOS
     30 	, unsupportedOS
     31 	, unsupportedOS'
     32 	, makeChange
     33 	, noChange
     34 	, doNothing
     35 	, impossible
     36 	, endAction
     37 	-- * Property result checking
     38 	, UncheckedProperty
     39 	, unchecked
     40 	, changesFile
     41 	, changesFileContent
     42 	, isNewerThan
     43 	, checkResult
     44 	, Checkable
     45 	, assume
     46 ) where
     47 
     48 import System.FilePath
     49 import Control.Monad
     50 import Data.Monoid
     51 import Control.Monad.IfElse
     52 import "mtl" Control.Monad.RWS.Strict
     53 import System.Posix.Files
     54 import Data.Maybe
     55 import Data.List
     56 import Data.Hashable
     57 import Control.Applicative
     58 import GHC.Stack
     59 import Prelude
     60 
     61 import Propellor.Types
     62 import Propellor.Types.Core
     63 import Propellor.Types.ResultCheck
     64 import Propellor.Types.MetaTypes
     65 import Propellor.Types.Singletons
     66 import Propellor.Info
     67 import Propellor.Message
     68 import Propellor.EnsureProperty
     69 import Utility.Exception
     70 import Utility.Monad
     71 import Utility.Directory
     72 import Utility.Misc
     73 
     74 -- | Makes a perhaps non-idempotent Property be idempotent by using a flag
     75 -- file to indicate whether it has run before.
     76 -- Use with caution.
     77 flagFile :: Property i -> FilePath -> Property i
     78 flagFile p = flagFile' p . return
     79 
     80 flagFile' :: Property i -> IO FilePath -> Property i
     81 flagFile' p getflagfile = adjustPropertySatisfy p $ \satisfy -> do
     82 	flagfile <- liftIO getflagfile
     83 	go satisfy flagfile =<< liftIO (doesFileExist flagfile)
     84   where
     85 	go _ _ True = return NoChange
     86 	go satisfy flagfile False = do
     87 		r <- satisfy
     88 		when (r == MadeChange) $ liftIO $
     89 			unlessM (doesFileExist flagfile) $ do
     90 				createDirectoryIfMissing True (takeDirectory flagfile)
     91 				writeFile flagfile ""
     92 		return r
     93 
     94 -- | Indicates that the first property depends on the second,
     95 -- so before the first is ensured, the second must be ensured.
     96 --
     97 -- The combined property uses the description of the first property.
     98 requires :: Combines x y => x -> y -> CombinedType x y
     99 requires = combineWith
    100 	-- Run action of y, then x
    101 	(flip (<>))
    102 	-- When reverting, run in reverse order.
    103 	(<>)
    104 
    105 -- | Combines together two properties, resulting in one property
    106 -- that ensures the first, and if the first succeeds, ensures the second.
    107 --
    108 -- The combined property uses the description of the first property.
    109 before :: Combines x y => x -> y -> CombinedType x y
    110 before = combineWith
    111 	-- Run action of x, then y
    112 	(<>)
    113 	-- When reverting, run in reverse order.
    114 	(flip (<>))
    115 
    116 -- | Whenever a change has to be made for a Property, causes a hook
    117 -- Property to also be run, but not otherwise.
    118 onChange
    119 	:: (Combines x y)
    120 	=> x
    121         -> y
    122         -> CombinedType x y
    123 onChange = combineWith combiner revertcombiner
    124   where
    125 	combiner (Just p) (Just hook) = Just $ do
    126 		r <- p
    127 		case r of
    128 			MadeChange -> do
    129 				r' <- hook
    130 				return $ r <> r'
    131 			_ -> return r
    132 	combiner (Just p) Nothing = Just p
    133 	combiner Nothing _ = Nothing
    134 	revertcombiner = (<>)
    135 
    136 -- | Same as `onChange` except that if property y fails, a flag file
    137 -- is generated. On next run, if the flag file is present, property y
    138 -- is executed even if property x doesn't change.
    139 --
    140 -- With `onChange`, if y fails, the property x `onChange` y returns
    141 -- `FailedChange`. But if this property is applied again, it returns
    142 -- `NoChange`. This behavior can cause trouble...
    143 onChangeFlagOnFail
    144 	:: (Combines x y)
    145 	=> FilePath
    146         -> x
    147         -> y
    148         -> CombinedType x y
    149 onChangeFlagOnFail flagfile = combineWith combiner revertcombiner
    150   where
    151 	combiner (Just s1) s2 = Just $ do
    152 		r1 <- s1
    153 		case r1 of
    154 			MadeChange -> flagFailed s2
    155 			_ -> ifM (liftIO $ doesFileExist flagfile)
    156 				( flagFailed s2
    157 				, return r1
    158 				)
    159 	combiner Nothing _ = Nothing
    160 
    161 	revertcombiner = (<>)
    162 
    163 	flagFailed (Just s) = do
    164 		r <- s
    165 		liftIO $ case r of
    166 			FailedChange -> createFlagFile
    167 			_ -> removeFlagFile
    168 		return r
    169 	flagFailed Nothing = return NoChange
    170 
    171 	createFlagFile = unlessM (doesFileExist flagfile) $ do
    172 		createDirectoryIfMissing True (takeDirectory flagfile)
    173 		writeFile flagfile ""
    174 	
    175 	removeFlagFile = whenM (doesFileExist flagfile) $ removeFile flagfile
    176 
    177 -- | Changes the description of a property.
    178 describe :: IsProp p => p -> Desc -> p
    179 describe = setDesc
    180 
    181 -- | Alias for @flip describe@
    182 (==>) :: IsProp (Property i) => Desc -> Property i -> Property i
    183 (==>) = flip describe
    184 infixl 1 ==>
    185 
    186 -- | Tries the first property, but if it fails to work, instead uses
    187 -- the second.
    188 fallback :: (Combines p1 p2) => p1 -> p2 -> CombinedType p1 p2
    189 fallback = combineWith combiner revertcombiner
    190   where
    191 	combiner (Just a1) (Just a2) = Just $ do
    192 		r <- a1
    193 		if r == FailedChange
    194 			then a2
    195 			else return r
    196 	combiner (Just a1) Nothing = Just a1
    197 	combiner Nothing _ = Nothing
    198 	revertcombiner = (<>)
    199 
    200 -- | Indicates that a Property may change a particular file. When the file
    201 -- is modified in any way (including changing its permissions or mtime),
    202 -- the property will return MadeChange instead of NoChange.
    203 changesFile :: Checkable p i => p i -> FilePath -> Property i
    204 changesFile p f = checkResult getstat comparestat p
    205   where
    206 	getstat = catchMaybeIO $ getSymbolicLinkStatus f
    207 	comparestat oldstat = do
    208 		newstat <- getstat
    209 		return $ if samestat oldstat newstat then NoChange else MadeChange
    210 	samestat Nothing Nothing = True
    211 	samestat (Just a) (Just b) = and
    212 		-- everything except for atime
    213 		[ deviceID a == deviceID b
    214 		, fileID a == fileID b
    215 		, fileMode a == fileMode b
    216 		, fileOwner a == fileOwner b
    217 		, fileGroup a == fileGroup b
    218 		, specialDeviceID a == specialDeviceID b
    219 		, fileSize a == fileSize b
    220 		, modificationTimeHiRes a == modificationTimeHiRes b
    221 		, isBlockDevice a == isBlockDevice b
    222 		, isCharacterDevice a == isCharacterDevice b
    223 		, isNamedPipe a == isNamedPipe b
    224 		, isRegularFile a == isRegularFile b
    225 		, isDirectory a == isDirectory b
    226 		, isSymbolicLink a == isSymbolicLink b
    227 		, isSocket a == isSocket b
    228 		]
    229 	samestat _ _ = False
    230 
    231 -- | Like `changesFile`, but compares the content of the file.
    232 -- Changes to mtime etc that do not change file content are treated as
    233 -- NoChange.
    234 changesFileContent :: Checkable p i => p i -> FilePath -> Property i
    235 changesFileContent p f = checkResult gethash comparehash p
    236   where
    237 	gethash = catchMaybeIO $ hash <$> readFileStrict f
    238 	comparehash oldhash = do
    239 		newhash <- gethash
    240 		return $ if oldhash == newhash then NoChange else MadeChange
    241 
    242 -- | Determines if the first file is newer than the second file.
    243 --
    244 -- This can be used with `check` to only run a command when a file
    245 -- has changed.
    246 --
    247 -- > check ("/etc/aliases" `isNewerThan` "/etc/aliases.db")
    248 -- > 	(cmdProperty "newaliases" [] `assume` MadeChange) -- updates aliases.db
    249 --
    250 -- Or it can be used with `checkResult` to test if a command made a change.
    251 --
    252 -- > checkResult (return ())
    253 -- > 	(\_ -> "/etc/aliases.db" `isNewerThan` "/etc/aliases")
    254 -- > 	(cmdProperty "newaliases" [])
    255 --
    256 -- (If one of the files does not exist, the file that does exist is
    257 -- considered to be the newer of the two.)
    258 isNewerThan :: FilePath -> FilePath -> IO Bool
    259 isNewerThan x y = do
    260 	mx <- mtime x
    261 	my <- mtime y
    262 	return (mx > my)
    263   where
    264 	mtime f = catchMaybeIO $ modificationTimeHiRes <$> getFileStatus f
    265 
    266 -- | Picks one of the two input properties to use,
    267 -- depending on the targeted OS.
    268 --
    269 -- If both input properties support the targeted OS, then the
    270 -- first will be used.
    271 --
    272 -- The resulting property will use the description of the first property
    273 -- no matter which property is used in the end. So, it's often a good
    274 -- idea to change the description to something clearer.
    275 --
    276 -- For example:
    277 --
    278 -- > upgraded :: Property (DebianLike + FreeBSD)
    279 -- > upgraded = (Apt.upgraded `pickOS` Pkg.upgraded)
    280 -- > 	`describe` "OS upgraded"
    281 --
    282 -- If neither input property supports the targeted OS, calls
    283 -- `unsupportedOS`. Using the example above on a Fedora system would
    284 -- fail that way.
    285 pickOS
    286 	::
    287 		HasCallStack =>
    288 		( SingKind ('KProxy :: KProxy ka)
    289 		, SingKind ('KProxy :: KProxy kb)
    290 		, DemoteRep ('KProxy :: KProxy ka) ~ [MetaType]
    291 		, DemoteRep ('KProxy :: KProxy kb) ~ [MetaType]
    292 		, SingI c
    293 		-- Would be nice to have this constraint, but
    294 		-- union will not generate metatypes lists with the same
    295 		-- order of OS's as is used everywhere else. So,
    296 		-- would need a type-level sort.
    297 		--, Union a b ~ c
    298 		)
    299 	=> Property (MetaTypes (a :: ka))
    300 	-> Property (MetaTypes (b :: kb))
    301 	-> Property (MetaTypes c)
    302 pickOS a b = c `addChildren` [toChildProperty a, toChildProperty b]
    303   where
    304 	-- This use of getSatisfy is safe, because both a and b
    305 	-- are added as children, so their info will propigate.
    306 	c = property (getDesc a) $ do
    307 		o <- getOS
    308 		if matching o a
    309 			then maybe (pure NoChange) id (getSatisfy a)
    310 			else if matching o b
    311 				then maybe (pure NoChange) id (getSatisfy b)
    312 				else unsupportedOS'
    313 	matching Nothing _ = False
    314 	matching (Just o) p =
    315 		Targeting (systemToTargetOS o)
    316 			`elem`
    317 		fromSing (proptype p)
    318 	proptype (Property t _ _ _ _) = t
    319 
    320 -- | Makes a property that is satisfied differently depending on specifics
    321 -- of the host's operating system.
    322 --
    323 -- > myproperty :: Property Debian
    324 -- > myproperty = withOS "foo installed" $ \w o -> case o of
    325 -- > 	(Just (System (Debian kernel (Stable release)) arch)) -> ensureProperty w ...
    326 -- > 	(Just (System (Debian kernel suite) arch)) -> ensureProperty w ...
    327 -- >	_ -> unsupportedOS'
    328 --
    329 -- Note that the operating system specifics may not be declared for all hosts,
    330 -- which is where Nothing comes in.
    331 withOS
    332 	:: (SingI metatypes)
    333 	=> Desc
    334 	-> (OuterMetaTypesWitness metatypes -> Maybe System -> Propellor Result)
    335 	-> Property (MetaTypes metatypes)
    336 withOS desc a = property' desc $ \w -> a w =<< getOS
    337 
    338 -- | A property that always fails with an unsupported OS error.
    339 unsupportedOS :: Property UnixLike
    340 unsupportedOS = property "unsupportedOS" unsupportedOS'
    341 
    342 -- | Throws an error, for use in `withOS` when a property is lacking
    343 -- support for an OS.
    344 unsupportedOS' :: HasCallStack => Propellor Result
    345 unsupportedOS' = go =<< getOS
    346 	  where
    347 		go Nothing = error "Unknown host OS is not supported by this property."
    348 		go (Just o) = error $ "This property is not implemented for " ++ show o
    349 
    350 -- | Undoes the effect of a RevertableProperty.
    351 revert :: RevertableProperty setup undo -> RevertableProperty undo setup
    352 revert (RevertableProperty p1 p2) = RevertableProperty p2 p1
    353 
    354 makeChange :: IO () -> Propellor Result
    355 makeChange a = liftIO a >> return MadeChange
    356 
    357 noChange :: Propellor Result
    358 noChange = return NoChange
    359 
    360 -- | A no-op property.
    361 --
    362 -- This is the same as `mempty` from the `Monoid` instance.
    363 doNothing :: SingI t => Property (MetaTypes t)
    364 doNothing = mempty
    365 
    366 -- | In situations where it's not possible to provide a property that
    367 -- works, this can be used to make a property that always fails with an
    368 -- error message you provide.
    369 impossible :: SingI t => String -> Property (MetaTypes t)
    370 impossible msg = property "impossible" $ errorMessage msg
    371 
    372 -- | Registers an action that should be run at the very end, after
    373 -- propellor has checks all the properties of a host.
    374 endAction :: Desc -> (Result -> Propellor Result) -> Propellor ()
    375 endAction desc a = tell [EndAction desc a]