From caeed5492fa3c66668d750a79ea5886248c6bd07 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 19 Nov 2014 20:35:33 -0400 Subject: allow debootstrapped to be reverted --- src/Propellor/Property/Debootstrap.hs | 33 ++++++++++++++++++++++++++++----- 1 file changed, 28 insertions(+), 5 deletions(-) (limited to 'src/Propellor/Property') diff --git a/src/Propellor/Property/Debootstrap.hs b/src/Propellor/Property/Debootstrap.hs index 8f93fe5b..876c12cb 100644 --- a/src/Propellor/Property/Debootstrap.hs +++ b/src/Propellor/Property/Debootstrap.hs @@ -22,14 +22,24 @@ type Url = String -- -- The System can be any OS and architecture that debootstrap -- and the kernel support. -debootstrapped :: FilePath -> System -> [CommandParam] -> Property -debootstrapped target system@(System _ arch) extraparams = - check (unpopulated target) prop - `requires` unrevertable installed +-- +-- Reverting this property deletes the chroot and all its contents. +-- Anything mounted under the filesystem is first unmounted. +-- +-- Note that reverting this property does not stop any processes +-- currently running in the chroot. +debootstrapped :: FilePath -> System -> [CommandParam] -> RevertableProperty +debootstrapped target system@(System _ arch) extraparams = + RevertableProperty setup teardown where + setup = check (unpopulated target) setupprop + `requires` unrevertable installed + + teardown = check (not <$> unpopulated target) teardownprop + unpopulated d = null <$> catchDefaultIO [] (dirContents d) - prop = property ("debootstrapped " ++ target) $ liftIO $ do + setupprop = property ("debootstrapped " ++ target) $ liftIO $ do createDirectoryIfMissing True target let suite = case extractSuite system of Nothing -> error $ "don't know how to debootstrap " ++ show system @@ -47,6 +57,19 @@ debootstrapped target system@(System _ arch) extraparams = , return FailedChange ) + teardownprop = property ("removed debootstrapped " ++ target) $ liftIO $ do + submnts <- filter (\p -> simplifyPath p /= simplifyPath target) + . filter (dirContains target) + <$> mountPoints + forM_ submnts $ \mnt -> + unlessM (boolSystem "umount" [ Param "-l", Param mnt ]) $ do + error $ "failed unmounting " ++ mnt + removeDirectoryRecursive target + return MadeChange + +mountPoints :: IO [FilePath] +mountPoints = lines <$> readProcess "findmnt" ["-rn", "--output", "target"] + extractSuite :: System -> Maybe String extractSuite (System (Debian s) _) = Just $ Apt.showSuite s extractSuite (System (Ubuntu r) _) = Just r -- cgit v1.2.3