diff options
| author | Joey Hess <joeyh@joeyh.name> | 2015-01-25 14:45:14 -0400 |
|---|---|---|
| committer | Joey Hess <joeyh@joeyh.name> | 2015-01-25 14:47:57 -0400 |
| commit | e9d5d9aff1cc2046149d3e5dcd9f4ef0f2a334a1 (patch) | |
| tree | 24b5bc62ac3851c317023d79080eb0ed8176cdba /src/Propellor/Property/Debootstrap.hs | |
| parent | 334abae31277b9f47b85813d7b2fd783e5b3b12d (diff) | |
remove toSimpleProp
It didn't do what I thought it did with a RevertableProperty; it always
returned Nothing because even if the input properties to <!> are NoInfo, it
casts them to HasInfo.
Even if it had worked, it lost type safety. Better to export the
Property NoInfo that is used in a RevertableProperty, so it can be used
directly.
Diffstat (limited to 'src/Propellor/Property/Debootstrap.hs')
| -rw-r--r-- | src/Propellor/Property/Debootstrap.hs | 41 |
1 files changed, 22 insertions, 19 deletions
diff --git a/src/Propellor/Property/Debootstrap.hs b/src/Propellor/Property/Debootstrap.hs index 3feb280c..d4947ab7 100644 --- a/src/Propellor/Property/Debootstrap.hs +++ b/src/Propellor/Property/Debootstrap.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE FlexibleContexts #-} + module Propellor.Property.Debootstrap ( Url, DebootstrapConfig(..), @@ -56,18 +58,18 @@ toParams (c1 :+ c2) = toParams c1 <> toParams c2 -- Note that reverting this property does not stop any processes -- currently running in the chroot. built :: FilePath -> System -> DebootstrapConfig -> RevertableProperty -built = built' (toProp installed) - -built' :: Property HasInfo -> FilePath -> System -> DebootstrapConfig -> RevertableProperty -built' installprop target system@(System _ arch) config = setup <!> teardown +built target system config = built' (toProp installed) target system config <!> teardown where - setup = check (unpopulated target <||> ispartial) setupprop - `requires` installprop - teardown = check (not <$> unpopulated target) teardownprop - unpopulated d = null <$> catchDefaultIO [] (dirContents d) + teardownprop = property ("removed debootstrapped " ++ target) $ + makeChange (removetarget target) +built' :: (Combines (Property NoInfo) (Property i)) => Property i -> FilePath -> System -> DebootstrapConfig -> Property (CInfo NoInfo i) +built' installprop target system@(System _ arch) config = + check (unpopulated target <||> ispartial) setupprop + `requires` installprop + where setupprop = property ("debootstrapped " ++ target) $ liftIO $ do createDirectoryIfMissing True target -- Don't allow non-root users to see inside the chroot, @@ -92,24 +94,25 @@ built' installprop target system@(System _ arch) config = setup <!> teardown , return FailedChange ) - teardownprop = property ("removed debootstrapped " ++ target) $ - makeChange removetarget - - removetarget = do - submnts <- filter (\p -> simplifyPath p /= simplifyPath target) - . filter (dirContains target) - <$> mountPoints - forM_ submnts umountLazy - removeDirectoryRecursive target - -- A failed debootstrap run will leave a debootstrap directory; -- recover by deleting it and trying again. ispartial = ifM (doesDirectoryExist (target </> "debootstrap")) ( do - removetarget + removetarget target return True , return False ) + +unpopulated :: FilePath -> IO Bool +unpopulated d = null <$> catchDefaultIO [] (dirContents d) + +removetarget :: FilePath -> IO () +removetarget target = do + submnts <- filter (\p -> simplifyPath p /= simplifyPath target) + . filter (dirContains target) + <$> mountPoints + forM_ submnts umountLazy + removeDirectoryRecursive target extractSuite :: System -> Maybe String extractSuite (System (Debian s) _) = Just $ Apt.showSuite s |
