From 90efcd3203d64c2c5691e30ccc23307aae8d20c8 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Sun, 30 Mar 2014 15:31:57 -0400 Subject: refactor --- Common.hs | 18 +++++++ Propellor.hs | 3 +- Property.hs | 142 +++++++++++++++++++-------------------------------- Property/Apt.hs | 7 ++- Property/Cmd.hs | 28 ++++++++++ Property/File.hs | 26 +++++++--- Property/GitHome.hs | 15 ++---- Property/Hostname.hs | 3 +- Property/Reboot.hs | 2 +- Property/Ssh.hs | 12 ++--- Property/Tor.hs | 3 +- Property/User.hs | 7 +-- 12 files changed, 130 insertions(+), 136 deletions(-) create mode 100644 Common.hs create mode 100644 Property/Cmd.hs diff --git a/Common.hs b/Common.hs new file mode 100644 index 00000000..10594d3c --- /dev/null +++ b/Common.hs @@ -0,0 +1,18 @@ +module Common (module X) where + +import Property as X +import Property.Cmd as X + +import Control.Applicative as X +import Control.Monad as X +import Utility.Process as X +import System.Directory as X +import System.IO as X +import Utility.Exception as X +import Utility.Env as X +import Utility.Directory as X +import Utility.Tmp as X +import System.FilePath as X +import Data.Maybe as X +import Data.Either as X +import Utility.Monad as X diff --git a/Propellor.hs b/Propellor.hs index ea2188f7..9e50b2f6 100644 --- a/Propellor.hs +++ b/Propellor.hs @@ -1,6 +1,5 @@ -import Property +import Common import HostName -import Utility.SafeCommand import qualified Property.File as File import qualified Property.Apt as Apt import qualified Property.Ssh as Ssh diff --git a/Property.hs b/Property.hs index f00ddfa2..4055ab2a 100644 --- a/Property.hs +++ b/Property.hs @@ -1,7 +1,6 @@ module Property where import System.Directory -import Control.Applicative import Control.Monad import System.Console.ANSI import System.Exit @@ -9,23 +8,18 @@ import System.IO import Utility.Monad import Utility.Exception -import Utility.SafeCommand -import Utility.Tmp -import Utility.Env --- Ensures that the system has some property. --- Actions must be idempotent; will be run repeatedly. -data Property - = FileProperty Desc FilePath ([Line] -> [Line]) - | CmdProperty Desc String [CommandParam] [(String, String)] - | IOProperty Desc (IO Result) +data Property = Property + { propertyDesc :: Desc + -- must be idempotent; may run repeatedly + , propertySatisfy :: IO Result + } + +type Desc = String data Result = NoChange | MadeChange | FailedChange deriving (Show, Eq) -type Line = String -type Desc = String - combineResult :: Result -> Result -> Result combineResult FailedChange _ = FailedChange combineResult _ FailedChange = FailedChange @@ -33,10 +27,11 @@ combineResult MadeChange _ = MadeChange combineResult _ MadeChange = MadeChange combineResult NoChange NoChange = NoChange -propertyDesc :: Property -> Desc -propertyDesc (FileProperty d _ _) = d -propertyDesc (CmdProperty d _ _ _) = d -propertyDesc (IOProperty d _) = d +makeChange :: IO () -> IO Result +makeChange a = a >> return MadeChange + +noChange :: IO Result +noChange = return NoChange {- Combines a list of properties, resulting in a single property - that when run will run each property in the list in turn, @@ -44,12 +39,12 @@ propertyDesc (IOProperty d _) = d - on failure; does propigate overall success/failure. -} propertyList :: Desc -> [Property] -> Property -propertyList desc ps = IOProperty desc $ ensureProperties' ps +propertyList desc ps = Property desc $ ensureProperties' ps {- Combines a list of properties, resulting in one property that - ensures each in turn, stopping on failure. -} combineProperties :: Desc -> [Property] -> Property -combineProperties desc ps = IOProperty desc $ go ps NoChange +combineProperties desc ps = Property desc $ go ps NoChange where go [] rs = return rs go (l:ls) rs = do @@ -58,26 +53,45 @@ combineProperties desc ps = IOProperty desc $ go ps NoChange FailedChange -> return FailedChange _ -> go ls (combineResult r rs) -ensureProperty :: Property -> IO Result -ensureProperty = catchDefaultIO FailedChange . ensureProperty' - -ensureProperty' :: Property -> IO Result -ensureProperty' (FileProperty _ f a) = go =<< doesFileExist f +{- Makes a perhaps non-idempotent Property be idempotent by using a flag + - file to indicate whether it has run before. + - Use with caution. -} +flagFile :: Property -> FilePath -> Property +flagFile property flagfile = Property (propertyDesc property) $ + go =<< doesFileExist flagfile where - go True = do - ls <- lines <$> readFile f - let ls' = a ls - if ls' == ls - then noChange - else makeChange $ viaTmp writeFile f (unlines ls') - go False = makeChange $ writeFile f (unlines $ a []) -ensureProperty' (CmdProperty _ cmd params env) = do - env' <- addEntries env <$> getEnvironment - ifM (boolSystemEnv cmd params (Just env')) - ( return MadeChange - , return FailedChange - ) -ensureProperty' (IOProperty _ a) = a + go True = return NoChange + go False = do + r <- ensureProperty property + when (r == MadeChange) $ + writeFile flagfile "" + return r + +{- Whenever a change has to be made for a Property, causes a hook + - Property to also be run, but not otherwise. -} +onChange :: Property -> Property -> Property +property `onChange` hook = Property (propertyDesc property) $ do + r <- ensureProperty property + case r of + MadeChange -> do + r' <- ensureProperty hook + return $ combineResult r r' + _ -> return r + +{- Indicates that the first property can only be satisfied once + - the second is. -} +requires :: Property -> Property -> Property +x `requires` y = combineProperties (propertyDesc x) [y, x] + +{- Makes a Property only be performed when a test succeeds. -} +check :: IO Bool -> Property -> Property +check c property = Property (propertyDesc property) $ ifM c + ( ensureProperty property + , return NoChange + ) + +ensureProperty :: Property -> IO Result +ensureProperty = catchDefaultIO FailedChange . propertySatisfy ensureProperties :: [Property] -> IO () ensureProperties ps = do @@ -109,55 +123,3 @@ ensureProperties' ps = ensure ps NoChange putStrLn "done" setSGR [] ensure ls (combineResult r rs) - -makeChange :: IO () -> IO Result -makeChange a = a >> return MadeChange - -noChange :: IO Result -noChange = return NoChange - -cmdProperty :: String -> [CommandParam] -> Property -cmdProperty cmd params = cmdProperty' cmd params [] - -cmdProperty' :: String -> [CommandParam] -> [(String, String)] -> Property -cmdProperty' cmd params env = CmdProperty desc cmd params env - where - desc = unwords $ cmd : map showp params - showp (Params s) = s - showp (Param s) = s - showp (File s) = s - -{- Makes a perhaps non-idempotent Property be idempotent by using a flag - - file to indicate whether it has run before. - - Use with caution. -} -flagFile :: Property -> FilePath -> Property -flagFile property flagfile = IOProperty (propertyDesc property) $ - go =<< doesFileExist flagfile - where - go True = return NoChange - go False = do - r <- ensureProperty property - when (r == MadeChange) $ - writeFile flagfile "" - return r - -{- Whenever a change has to be made for a Property, causes a hook - - Property to also be run, but not otherwise. -} -onChange :: Property -> Property -> Property -property `onChange` hook = IOProperty (propertyDesc property) $ do - r <- ensureProperty property - case r of - MadeChange -> do - r' <- ensureProperty hook - return $ combineResult r r' - _ -> return r - -requires :: Property -> Property -> Property -x `requires` y = combineProperties (propertyDesc x) [y, x] - -{- Makes a Property only be performed when a test succeeds. -} -check :: IO Bool -> Property -> Property -check c property = IOProperty (propertyDesc property) $ ifM c - ( ensureProperty property - , return NoChange - ) diff --git a/Property/Apt.hs b/Property/Apt.hs index 653c0fca..a5720e72 100644 --- a/Property/Apt.hs +++ b/Property/Apt.hs @@ -6,10 +6,9 @@ import Data.List import System.IO import Control.Monad -import Property +import Common import qualified Property.File as File -import Utility.SafeCommand -import Utility.Process +import Property.File (Line) sourcesList :: FilePath sourcesList = "/etc/apt/sources.list" @@ -109,7 +108,7 @@ unattendedUpgrades enabled = installed ["unattended-upgrades"] reConfigure :: Package -> [(String, String, String)] -> Property reConfigure package vals = reconfigure `requires` setselections where - setselections = IOProperty "preseed" $ makeChange $ + setselections = Property "preseed" $ makeChange $ withHandle StdinHandle createProcessSuccess (proc "debconf-set-selections" []) $ \h -> do forM_ vals $ \(template, tmpltype, value) -> diff --git a/Property/Cmd.hs b/Property/Cmd.hs new file mode 100644 index 00000000..c78adaeb --- /dev/null +++ b/Property/Cmd.hs @@ -0,0 +1,28 @@ +module Property.Cmd ( + cmdProperty, + cmdProperty', + module Utility.SafeCommand +) where + +import Control.Applicative + +import Property +import Utility.Monad +import Utility.SafeCommand +import Utility.Env + +cmdProperty :: String -> [CommandParam] -> Property +cmdProperty cmd params = cmdProperty' cmd params [] + +cmdProperty' :: String -> [CommandParam] -> [(String, String)] -> Property +cmdProperty' cmd params env = Property desc $ do + env' <- addEntries env <$> getEnvironment + ifM (boolSystemEnv cmd params (Just env')) + ( return MadeChange + , return FailedChange + ) + where + desc = unwords $ cmd : map showp params + showp (Params s) = s + showp (Param s) = s + showp (File s) = s diff --git a/Property/File.hs b/Property/File.hs index 9d07f130..55ca4fec 100644 --- a/Property/File.hs +++ b/Property/File.hs @@ -1,18 +1,17 @@ module Property.File where -import System.Directory +import Common -import Property -import Utility.Directory +type Line = String {- Replaces all the content of a file. -} hasContent :: FilePath -> [Line] -> Property -f `hasContent` newcontent = FileProperty ("replace " ++ f) - f (\_oldcontent -> newcontent) +f `hasContent` newcontent = fileProperty ("replace " ++ f) + (\_oldcontent -> newcontent) f {- Ensures that a line is present in a file, adding it to the end if not. -} containsLine :: FilePath -> Line -> Property -f `containsLine` l = FileProperty (f ++ " contains:" ++ l) f go +f `containsLine` l = fileProperty (f ++ " contains:" ++ l) go f where go ls | l `elem` ls = ls @@ -22,9 +21,20 @@ f `containsLine` l = FileProperty (f ++ " contains:" ++ l) f go - Note that the file is ensured to exist, so if it doesn't, an empty - file will be written. -} lacksLine :: FilePath -> Line -> Property -f `lacksLine` l = FileProperty (f ++ " remove: " ++ l) f (filter (/= l)) +f `lacksLine` l = fileProperty (f ++ " remove: " ++ l) (filter (/= l)) f {- Note: Does not remove symlinks or non-plain-files. -} notPresent :: FilePath -> Property -notPresent f = check (doesFileExist f) $ IOProperty (f ++ " not present") $ +notPresent f = check (doesFileExist f) $ Property (f ++ " not present") $ makeChange $ nukeFile f + +fileProperty :: Desc -> ([Line] -> [Line]) -> FilePath -> Property +fileProperty desc a f = Property desc $ go =<< doesFileExist f + where + go True = do + ls <- lines <$> catchDefaultIO [] (readFile f) + let ls' = a ls + if ls' == ls + then noChange + else makeChange $ viaTmp writeFile f (unlines ls') + go False = makeChange $ writeFile f (unlines $ a []) diff --git a/Property/GitHome.hs b/Property/GitHome.hs index 09d21326..99402b8e 100644 --- a/Property/GitHome.hs +++ b/Property/GitHome.hs @@ -1,22 +1,13 @@ module Property.GitHome where -import System.FilePath -import System.Directory -import Control.Applicative -import Control.Monad - -import Property -import Property.User -import Utility.SafeCommand -import Utility.Directory -import Utility.Monad -import Utility.Exception +import Common import qualified Property.Apt as Apt +import Property.User {- Clones Joey Hess's git home directory, and runs its fixups script. -} installedFor :: UserName -> Property installedFor user = check (not <$> hasGitDir user) $ - IOProperty ("githome " ++ user) (go =<< homedir user) + Property ("githome " ++ user) (go =<< homedir user) `requires` Apt.installed ["git", "myrepos"] where go Nothing = noChange diff --git a/Property/Hostname.hs b/Property/Hostname.hs index 38e9dbe8..8bc7a6b8 100644 --- a/Property/Hostname.hs +++ b/Property/Hostname.hs @@ -1,8 +1,7 @@ module Property.Hostname where -import Property +import Common import qualified Property.File as File -import Utility.SafeCommand type HostName = String diff --git a/Property/Reboot.hs b/Property/Reboot.hs index b6e3030e..79aa6010 100644 --- a/Property/Reboot.hs +++ b/Property/Reboot.hs @@ -1,6 +1,6 @@ module Property.Reboot where -import Property +import Common now :: Property now = cmdProperty "reboot" [] diff --git a/Property/Ssh.hs b/Property/Ssh.hs index 98149bcb..1b0a6c53 100644 --- a/Property/Ssh.hs +++ b/Property/Ssh.hs @@ -1,14 +1,8 @@ module Property.Ssh where -import Control.Applicative -import Control.Monad -import System.FilePath - -import Property -import Property.User +import Common import qualified Property.File as File -import Utility.SafeCommand -import Utility.Exception +import Property.User sshBool :: Bool -> String sshBool True = "yes" @@ -48,7 +42,7 @@ uniqueHostKeys :: Property uniqueHostKeys = flagFile prop "/etc/ssh/.unique_host_keys" `onChange` restartSshd where - prop = IOProperty "ssh unique host keys" $ do + prop = Property "ssh unique host keys" $ do void $ boolSystem "sh" [ Param "-c" , Param "rm -f /etc/ssh/ssh_host_*" diff --git a/Property/Tor.hs b/Property/Tor.hs index 7f7e7245..a4184edf 100644 --- a/Property/Tor.hs +++ b/Property/Tor.hs @@ -1,7 +1,6 @@ module Property.Tor where -import Property -import Utility.SafeCommand +import Common import qualified Property.File as File import qualified Property.Apt as Apt diff --git a/Property/User.hs b/Property/User.hs index 3cd74964..733e26ea 100644 --- a/Property/User.hs +++ b/Property/User.hs @@ -1,13 +1,8 @@ module Property.User where import System.Posix -import Control.Applicative -import Data.Maybe -import Property -import Utility.SafeCommand -import Utility.Exception -import Utility.Process +import Common type UserName = String -- cgit v1.2.3