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 Utility.SafeCommand
import qualified Property.File as File
import qualified Property.Apt as Apt
import qualified Property.Ssh as Ssh

View File

@ -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
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' (IOProperty _ a) = a
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
)

View File

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

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
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 [])

View File

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

View File

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

View File

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

View File

@ -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_*"

View File

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

View File

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