initial check-in

too young to have a name

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