From 7ff39bb09840c27b4bd04f692dff2e4d45c83924 Mon Sep 17 00:00:00 2001 From: Antoine Eiche Date: Tue, 21 Jul 2015 11:30:40 +0200 Subject: 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... --- src/Propellor/Property.hs | 37 +++++++++++++++++++++++++++++++++++++ 1 file changed, 37 insertions(+) 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 -- cgit v1.2.3