summaryrefslogtreecommitdiff
path: root/Property.hs
diff options
context:
space:
mode:
authorJoey Hess2014-03-29 23:10:52 -0400
committerJoey Hess2014-03-29 23:16:43 -0400
commitd9af8bac5eb7836a3c90e37e870fd73d30b841fd (patch)
tree40443efd384415172cf393571fe3f1651ea57423 /Property.hs
initial check-in
too young to have a name
Diffstat (limited to 'Property.hs')
-rw-r--r--Property.hs160
1 files changed, 160 insertions, 0 deletions
diff --git a/Property.hs b/Property.hs
new file mode 100644
index 00000000..5f1b3e24
--- /dev/null
+++ b/Property.hs
@@ -0,0 +1,160 @@
+module Property where
+
+import System.Directory
+import Control.Applicative
+import Control.Monad
+import System.Console.ANSI
+import System.Exit
+import System.IO
+
+import Utility.Tmp
+import Utility.Exception
+import Utility.SafeCommand
+import Utility.Monad
+
+-- 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]
+ | IOProperty Desc (IO Result)
+
+data Result = NoChange | MadeChange | FailedChange
+ deriving (Show, Eq)
+
+type Line = String
+type Desc = String
+
+combineResult :: Result -> Result -> Result
+combineResult FailedChange _ = FailedChange
+combineResult _ FailedChange = FailedChange
+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
+
+combineProperties :: Desc -> [Property] -> Property
+combineProperties desc ps = IOProperty desc $ go ps NoChange
+ where
+ go [] rs = return rs
+ go (l:ls) rs = do
+ r <- ensureProperty l
+ case r of
+ 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
+ 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) = ifM (boolSystem ("./" ++ cmd) params)
+ ( return MadeChange
+ , return FailedChange
+ )
+ensureProperty' (IOProperty _ a) = a
+
+ensureProperties :: [Property] -> IO [(Desc, Result)]
+ensureProperties ps = zip (map propertyDesc ps) <$> mapM ensureProperty ps
+
+defaultMain :: [Property] -> IO ()
+defaultMain ps = do
+ r <- ensure ps NoChange
+ case r of
+ FailedChange -> exitWith (ExitFailure 1)
+ _ -> exitWith ExitSuccess
+ where
+ ensure [] rs = return rs
+ ensure (l:ls) rs = do
+ putStr $ propertyDesc l ++ "... "
+ hFlush stdout
+ r <- ensureProperty l
+ case r of
+ FailedChange -> do
+ setSGR [SetColor Foreground Vivid Red]
+ putStrLn "failed"
+ NoChange -> do
+ setSGR [SetColor Foreground Dull Green]
+ putStrLn "(ok)"
+ MadeChange -> do
+ setSGR [SetColor Foreground Vivid Green]
+ putStrLn "(ok)"
+ 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 desc cmd params
+ where
+ desc = unwords $ cmd : map showp params
+ showp (Params s) = s
+ showp (Param s) = s
+ showp (File s) = s
+
+{- Replaces all the content of a file. -}
+fileHasContent :: FilePath -> [Line] -> Property
+fileHasContent f newcontent = FileProperty ("replace " ++ f)
+ f (\_oldcontent -> newcontent)
+
+{- Ensures that a line is present in a file, adding it to the end if not. -}
+lineInFile :: FilePath -> Line -> Property
+lineInFile f l = FileProperty (f ++ " contains:" ++ l) f go
+ where
+ go ls
+ | l `elem` ls = ls
+ | otherwise = ls++[l]
+
+{- Ensures that a line is not present in a file.
+ - Note that the file is ensured to exist, so if it doesn't, an empty
+ - file will be written. -}
+lineNotInFile :: FilePath -> Line -> Property
+lineNotInFile f l = FileProperty (f ++ " remove: " ++ l) f (filter (/= l))
+
+{- 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
+
+{- 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
+ )