This commit is contained in:
Joey Hess 2014-03-30 15:31:57 -04:00
parent 8d31a6226a
commit 90efcd3203
12 changed files with 130 additions and 136 deletions

18
Common.hs Normal file
View File

@ -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

View File

@ -1,6 +1,5 @@
import Property import Common
import HostName import HostName
import Utility.SafeCommand
import qualified Property.File as File import qualified Property.File as File
import qualified Property.Apt as Apt import qualified Property.Apt as Apt
import qualified Property.Ssh as Ssh import qualified Property.Ssh as Ssh

View File

@ -1,7 +1,6 @@
module Property where module Property where
import System.Directory import System.Directory
import Control.Applicative
import Control.Monad import Control.Monad
import System.Console.ANSI import System.Console.ANSI
import System.Exit import System.Exit
@ -9,23 +8,18 @@ import System.IO
import Utility.Monad import Utility.Monad
import Utility.Exception import Utility.Exception
import Utility.SafeCommand
import Utility.Tmp
import Utility.Env
-- Ensures that the system has some property. data Property = Property
-- Actions must be idempotent; will be run repeatedly. { propertyDesc :: Desc
data Property -- must be idempotent; may run repeatedly
= FileProperty Desc FilePath ([Line] -> [Line]) , propertySatisfy :: IO Result
| CmdProperty Desc String [CommandParam] [(String, String)] }
| IOProperty Desc (IO Result)
type Desc = String
data Result = NoChange | MadeChange | FailedChange data Result = NoChange | MadeChange | FailedChange
deriving (Show, Eq) deriving (Show, Eq)
type Line = String
type Desc = String
combineResult :: Result -> Result -> Result combineResult :: Result -> Result -> Result
combineResult FailedChange _ = FailedChange combineResult FailedChange _ = FailedChange
combineResult _ FailedChange = FailedChange combineResult _ FailedChange = FailedChange
@ -33,10 +27,11 @@ combineResult MadeChange _ = MadeChange
combineResult _ MadeChange = MadeChange combineResult _ MadeChange = MadeChange
combineResult NoChange NoChange = NoChange combineResult NoChange NoChange = NoChange
propertyDesc :: Property -> Desc makeChange :: IO () -> IO Result
propertyDesc (FileProperty d _ _) = d makeChange a = a >> return MadeChange
propertyDesc (CmdProperty d _ _ _) = d
propertyDesc (IOProperty d _) = d noChange :: IO Result
noChange = return NoChange
{- Combines a list of properties, resulting in a single property {- Combines a list of properties, resulting in a single property
- that when run will run each property in the list in turn, - 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. - on failure; does propigate overall success/failure.
-} -}
propertyList :: Desc -> [Property] -> Property 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 {- Combines a list of properties, resulting in one property that
- ensures each in turn, stopping on failure. -} - ensures each in turn, stopping on failure. -}
combineProperties :: Desc -> [Property] -> Property combineProperties :: Desc -> [Property] -> Property
combineProperties desc ps = IOProperty desc $ go ps NoChange combineProperties desc ps = Property desc $ go ps NoChange
where where
go [] rs = return rs go [] rs = return rs
go (l:ls) rs = do go (l:ls) rs = do
@ -58,26 +53,45 @@ combineProperties desc ps = IOProperty desc $ go ps NoChange
FailedChange -> return FailedChange FailedChange -> return FailedChange
_ -> go ls (combineResult r rs) _ -> go ls (combineResult r rs)
ensureProperty :: Property -> IO Result {- Makes a perhaps non-idempotent Property be idempotent by using a flag
ensureProperty = catchDefaultIO FailedChange . ensureProperty' - file to indicate whether it has run before.
- Use with caution. -}
ensureProperty' :: Property -> IO Result flagFile :: Property -> FilePath -> Property
ensureProperty' (FileProperty _ f a) = go =<< doesFileExist f flagFile property flagfile = Property (propertyDesc property) $
go =<< doesFileExist flagfile
where where
go True = do go True = return NoChange
ls <- lines <$> readFile f go False = do
let ls' = a ls r <- ensureProperty property
if ls' == ls when (r == MadeChange) $
then noChange writeFile flagfile ""
else makeChange $ viaTmp writeFile f (unlines ls') return r
go False = makeChange $ writeFile f (unlines $ a [])
ensureProperty' (CmdProperty _ cmd params env) = do {- Whenever a change has to be made for a Property, causes a hook
env' <- addEntries env <$> getEnvironment - Property to also be run, but not otherwise. -}
ifM (boolSystemEnv cmd params (Just env')) onChange :: Property -> Property -> Property
( return MadeChange property `onChange` hook = Property (propertyDesc property) $ do
, return FailedChange 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' (IOProperty _ a) = a
ensureProperty :: Property -> IO Result
ensureProperty = catchDefaultIO FailedChange . propertySatisfy
ensureProperties :: [Property] -> IO () ensureProperties :: [Property] -> IO ()
ensureProperties ps = do ensureProperties ps = do
@ -109,55 +123,3 @@ ensureProperties' ps = ensure ps NoChange
putStrLn "done" putStrLn "done"
setSGR [] setSGR []
ensure ls (combineResult r rs) 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
)

View File

@ -6,10 +6,9 @@ import Data.List
import System.IO import System.IO
import Control.Monad import Control.Monad
import Property import Common
import qualified Property.File as File import qualified Property.File as File
import Utility.SafeCommand import Property.File (Line)
import Utility.Process
sourcesList :: FilePath sourcesList :: FilePath
sourcesList = "/etc/apt/sources.list" sourcesList = "/etc/apt/sources.list"
@ -109,7 +108,7 @@ unattendedUpgrades enabled = installed ["unattended-upgrades"]
reConfigure :: Package -> [(String, String, String)] -> Property reConfigure :: Package -> [(String, String, String)] -> Property
reConfigure package vals = reconfigure `requires` setselections reConfigure package vals = reconfigure `requires` setselections
where where
setselections = IOProperty "preseed" $ makeChange $ setselections = Property "preseed" $ makeChange $
withHandle StdinHandle createProcessSuccess withHandle StdinHandle createProcessSuccess
(proc "debconf-set-selections" []) $ \h -> do (proc "debconf-set-selections" []) $ \h -> do
forM_ vals $ \(template, tmpltype, value) -> forM_ vals $ \(template, tmpltype, value) ->

28
Property/Cmd.hs Normal file
View File

@ -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

View File

@ -1,18 +1,17 @@
module Property.File where module Property.File where
import System.Directory import Common
import Property type Line = String
import Utility.Directory
{- Replaces all the content of a file. -} {- Replaces all the content of a file. -}
hasContent :: FilePath -> [Line] -> Property hasContent :: FilePath -> [Line] -> Property
f `hasContent` newcontent = FileProperty ("replace " ++ f) f `hasContent` newcontent = fileProperty ("replace " ++ f)
f (\_oldcontent -> newcontent) (\_oldcontent -> newcontent) f
{- Ensures that a line is present in a file, adding it to the end if not. -} {- Ensures that a line is present in a file, adding it to the end if not. -}
containsLine :: FilePath -> Line -> Property containsLine :: FilePath -> Line -> Property
f `containsLine` l = FileProperty (f ++ " contains:" ++ l) f go f `containsLine` l = fileProperty (f ++ " contains:" ++ l) go f
where where
go ls go ls
| l `elem` ls = 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 - Note that the file is ensured to exist, so if it doesn't, an empty
- file will be written. -} - file will be written. -}
lacksLine :: FilePath -> Line -> Property 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. -} {- Note: Does not remove symlinks or non-plain-files. -}
notPresent :: FilePath -> Property notPresent :: FilePath -> Property
notPresent f = check (doesFileExist f) $ IOProperty (f ++ " not present") $ notPresent f = check (doesFileExist f) $ Property (f ++ " not present") $
makeChange $ nukeFile f 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 [])

View File

@ -1,22 +1,13 @@
module Property.GitHome where module Property.GitHome where
import System.FilePath import Common
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 qualified Property.Apt as Apt import qualified Property.Apt as Apt
import Property.User
{- Clones Joey Hess's git home directory, and runs its fixups script. -} {- Clones Joey Hess's git home directory, and runs its fixups script. -}
installedFor :: UserName -> Property installedFor :: UserName -> Property
installedFor user = check (not <$> hasGitDir user) $ installedFor user = check (not <$> hasGitDir user) $
IOProperty ("githome " ++ user) (go =<< homedir user) Property ("githome " ++ user) (go =<< homedir user)
`requires` Apt.installed ["git", "myrepos"] `requires` Apt.installed ["git", "myrepos"]
where where
go Nothing = noChange go Nothing = noChange

View File

@ -1,8 +1,7 @@
module Property.Hostname where module Property.Hostname where
import Property import Common
import qualified Property.File as File import qualified Property.File as File
import Utility.SafeCommand
type HostName = String type HostName = String

View File

@ -1,6 +1,6 @@
module Property.Reboot where module Property.Reboot where
import Property import Common
now :: Property now :: Property
now = cmdProperty "reboot" [] now = cmdProperty "reboot" []

View File

@ -1,14 +1,8 @@
module Property.Ssh where module Property.Ssh where
import Control.Applicative import Common
import Control.Monad
import System.FilePath
import Property
import Property.User
import qualified Property.File as File import qualified Property.File as File
import Utility.SafeCommand import Property.User
import Utility.Exception
sshBool :: Bool -> String sshBool :: Bool -> String
sshBool True = "yes" sshBool True = "yes"
@ -48,7 +42,7 @@ uniqueHostKeys :: Property
uniqueHostKeys = flagFile prop "/etc/ssh/.unique_host_keys" uniqueHostKeys = flagFile prop "/etc/ssh/.unique_host_keys"
`onChange` restartSshd `onChange` restartSshd
where where
prop = IOProperty "ssh unique host keys" $ do prop = Property "ssh unique host keys" $ do
void $ boolSystem "sh" void $ boolSystem "sh"
[ Param "-c" [ Param "-c"
, Param "rm -f /etc/ssh/ssh_host_*" , Param "rm -f /etc/ssh/ssh_host_*"

View File

@ -1,7 +1,6 @@
module Property.Tor where module Property.Tor where
import Property import Common
import Utility.SafeCommand
import qualified Property.File as File import qualified Property.File as File
import qualified Property.Apt as Apt import qualified Property.Apt as Apt

View File

@ -1,13 +1,8 @@
module Property.User where module Property.User where
import System.Posix import System.Posix
import Control.Applicative
import Data.Maybe
import Property import Common
import Utility.SafeCommand
import Utility.Exception
import Utility.Process
type UserName = String type UserName = String