summaryrefslogtreecommitdiff
path: root/src/Propellor/Property.hs
diff options
context:
space:
mode:
authorAntoine Eiche2015-07-21 11:30:40 +0200
committerJoey Hess2015-07-21 11:14:44 -0400
commit7ff39bb09840c27b4bd04f692dff2e4d45c83924 (patch)
treef355316efc032e022b638dff24f8c7fb10349c11 /src/Propellor/Property.hs
parent2932c2b420a3d059be0faecc2113f19f1171af4d (diff)
Add operator onChangeFlagOnFail.
It seems like `onChange` except that if property y fails, a flag file is generated. On next runs, if the flag file is present, property y is executed even if property x doesn't change. With `onChange`, if y fails, the property x `onChange` y returns `FailedChange`. But if this property is applied again, it returns `NoChange`. This behavior can cause trouble...
Diffstat (limited to 'src/Propellor/Property.hs')
-rw-r--r--src/Propellor/Property.hs37
1 files changed, 37 insertions, 0 deletions
diff --git a/src/Propellor/Property.hs b/src/Propellor/Property.hs
index 1801902e..4da9acf3 100644
--- a/src/Propellor/Property.hs
+++ b/src/Propellor/Property.hs
@@ -54,6 +54,43 @@ onChange = combineWith $ \p hook -> do
return $ r <> r'
_ -> return r
+-- | Same than `onChange` except that if property y fails, a flag file
+-- is generated. On next run, if the flag file is present, property y
+-- is executed even if property x doesn't change.
+--
+-- With `onChange`, if y fails, the property x `onChange` y returns
+-- `FailedChange`. But if this property is applied again, it returns
+-- `NoChange`. This behavior can cause trouble...
+--
+-- Use with caution.
+onChangeFlagOnFail
+ :: (Combines (Property x) (Property y))
+ => FilePath
+ -> Property x
+ -> Property y
+ -> CombinedType (Property x) (Property y)
+onChangeFlagOnFail flagfile p1 p2 =
+ combineWith go p1 p2
+ where
+ go s1 s2 = do
+ r1 <- s1
+ case r1 of
+ MadeChange -> flagFailed s2
+ _ -> ifM (liftIO $ doesFileExist flagfile)
+ (flagFailed s2
+ , return r1)
+ flagFailed s = do
+ r <- s
+ liftIO $ case r of
+ FailedChange -> createFlagFile
+ _ -> removeFlagFile
+ return r
+ createFlagFile = unlessM (doesFileExist flagfile) $ do
+ createDirectoryIfMissing True (takeDirectory flagfile)
+ writeFile flagfile ""
+ removeFlagFile = whenM (doesFileExist flagfile) $ removeFile flagfile
+
+
-- | Alias for @flip describe@
(==>) :: IsProp (Property i) => Desc -> Property i -> Property i
(==>) = flip describe