summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorJoey Hess2015-08-27 12:21:55 -0700
committerJoey Hess2015-08-31 13:55:14 -0700
commit60950b159a2b800938929f8ae12823d5ec674667 (patch)
tree4f925a87e9b69ab4d62da014e69b8d088f4213fa
parent94d6f453e7441749a83f0ea69d0e7c12737565a1 (diff)
implement dirsizes
Used Data.Map.Strict, so bumped versions. Don't want to support the ghc in debian oldstable.. (cherry picked from commit e413bed2c1cb15dcb8ce721a2801021e39f3ba86)
-rw-r--r--debian/changelog1
-rw-r--r--debian/control2
-rw-r--r--propellor.cabal6
-rw-r--r--src/Propellor/Property/DiskImage.hs31
4 files changed, 32 insertions, 8 deletions
diff --git a/debian/changelog b/debian/changelog
index d56ac606..2431969e 100644
--- a/debian/changelog
+++ b/debian/changelog
@@ -5,6 +5,7 @@ propellor (2.7.3) UNRELEASED; urgency=medium
* Added Propellor.Property.DiskImage, for bootable disk image creation.
(Not yet complete.)
* Update for Debian systemd-container package split.
+ * Dropped support for ghc 7.4.
-- Joey Hess <id@joeyh.name> Tue, 25 Aug 2015 13:45:39 -0700
diff --git a/debian/control b/debian/control
index 25c3d474..05101be0 100644
--- a/debian/control
+++ b/debian/control
@@ -4,7 +4,7 @@ Priority: optional
Build-Depends:
debhelper (>= 9),
git,
- ghc (>= 7.4),
+ ghc (>= 7.6),
cabal-install,
libghc-async-dev,
libghc-missingh-dev,
diff --git a/propellor.cabal b/propellor.cabal
index 329739be..e455d1a7 100644
--- a/propellor.cabal
+++ b/propellor.cabal
@@ -38,7 +38,7 @@ Executable propellor
Hs-Source-Dirs: src
Build-Depends: MissingH, directory, filepath, base >= 4.5, base < 5,
IfElse, process, bytestring, hslogger, unix-compat, ansi-terminal,
- containers, network, async, time, QuickCheck, mtl, transformers,
+ containers (>= 0.5), network, async, time, QuickCheck, mtl, transformers,
exceptions (>= 0.6)
if (! os(windows))
@@ -50,7 +50,7 @@ Executable propellor-config
Hs-Source-Dirs: src
Build-Depends: MissingH, directory, filepath, base >= 4.5, base < 5,
IfElse, process, bytestring, hslogger, unix-compat, ansi-terminal,
- containers, network, async, time, QuickCheck, mtl, transformers,
+ containers (>= 0.5), network, async, time, QuickCheck, mtl, transformers,
exceptions
if (! os(windows))
@@ -61,7 +61,7 @@ Library
Hs-Source-Dirs: src
Build-Depends: MissingH, directory, filepath, base >= 4.5, base < 5,
IfElse, process, bytestring, hslogger, unix-compat, ansi-terminal,
- containers, network, async, time, QuickCheck, mtl, transformers,
+ containers (>= 0.5), network, async, time, QuickCheck, mtl, transformers,
exceptions
if (! os(windows))
diff --git a/src/Propellor/Property/DiskImage.hs b/src/Propellor/Property/DiskImage.hs
index 691f79bc..5bdd8f1a 100644
--- a/src/Propellor/Property/DiskImage.hs
+++ b/src/Propellor/Property/DiskImage.hs
@@ -17,6 +17,9 @@ import Propellor.Property.Chroot
import Propellor.Property.Parted
import qualified Propellor.Property.Grub as Grub
+import qualified Data.Map.Strict as M
+import System.Posix.Files
+
-- | Creates a bootable disk image.
--
-- First the specified Chroot is set up, and its properties are satisfied.
@@ -48,6 +51,30 @@ rebuilt = built' True
built' :: Bool -> (FilePath -> Chroot) -> MkPartTable -> DiskImageFinalization -> RevertableProperty
built' rebuild mkparttable mkchroot final = undefined
+-- TODO tie the knot
+-- let f = fitChrootSize MSDOS [(Just "/", mkPartition EXT2)]
+-- let (mnts, t) = f (map (MegaBytes . fromIntegral . length . show) mnts)
+
+-- | Generates a map of the sizes of the contents of
+-- every directory in a filesystem tree.
+--
+-- Should be same values as du -b
+dirSizes :: FilePath -> IO (M.Map FilePath Integer)
+dirSizes top = go M.empty top [top]
+ where
+ go m _ [] = return m
+ go m dir (i:is) = do
+ s <- getSymbolicLinkStatus i
+ let sz = fromIntegral (fileSize s)
+ if isDirectory s
+ then do
+ subm <- go M.empty i =<< dirContents i
+ let sz' = M.foldr' (+) sz
+ (M.filterWithKey (const . subdirof i) subm)
+ go (M.insertWith (+) i sz' (M.union m subm)) dir is
+ else go (M.insertWith (+) dir sz m) dir is
+ subdirof parent i = not (i `equalFilePath` parent) && takeDirectory i `equalFilePath` parent
+
-- | Where a partition is mounted. Use Nothing for eg, LinuxSwap.
type MountPoint = Maybe FilePath
@@ -60,10 +87,6 @@ type MountPoint = Maybe FilePath
-- provided as a default size.)
type MkPartTable = [PartSize] -> ([MountPoint], PartTable)
--- TODO tie the knot
--- let f = fitChrootSize MSDOS [(Just "/", mkPartition EXT2)]
--- let (mnts, t) = f (map (MegaBytes . fromIntegral . length . show) mnts)
-
-- | The constructor for each Partition is passed the size of the files
-- from the chroot that will be put in that partition.
--