added config directive "chroot-commands"

1 files changed, 16 insertions, 14 deletions

diff --git a/fsmgr.hs b/fsmgr.hs
index f144e0f..0434832 100644
--- a/fsmgr.hs
+++ b/fsmgr.hs
@@ -9,8 +9,6 @@
 module Main where
 import Rebase.Prelude hiding (bool, hash, (<.>))
 
-import Crypto.Hash
-import Crypto.Hash.Types.Digest.Read ()
 import Data.Yaml.Combinators
 import Development.Shake
 import Development.Shake.Command     ()
@@ -54,11 +52,12 @@ data BaseImageSpecification
   deriving (Show, Read)
 
 data DiskImageConfig = DiskImageConfig {
-  initialImage :: BaseImageSpecification
-, packages     :: Set Package
+  initialImage     :: BaseImageSpecification
+, packages         :: Set Package
 -- , debconfConfig :: DebconfConfig
-, unpackOnly   :: Bool
-, binaries     :: Vector Text -- :: [Patch]
+, unpackOnly       :: Bool
+, binaries         :: Vector Text
+, chrootCommands   :: Vector Text
 } deriving (Show, Read)
 
 parsePackageName :: Text -> Package
@@ -72,12 +71,7 @@ diskImageConfigParser = object $
   -- <*> pure (DebconfConfig "")
   <*> defaultField "unpack-only" False bool
   <*> defaultField "binaries" Vector.empty (array string)
-
-diskImageFilename :: DiskImageConfig -> FilePath
-diskImageFilename = (++ ".btrfs") . show . sha1 . show
-  where
-    sha1 :: String -> Digest SHA1
-    sha1 = hash . encodeUtf8 . pack
+  <*> defaultField "chroot-commands" Vector.empty (array string)
 
 readCfg :: FilePath -> Action DiskImageConfig
 readCfg yaml = either error id . parse diskImageConfigParser . encodeUtf8 . pack <$> readFile' yaml
@@ -92,6 +86,7 @@ buildRoot DiskImageConfig{..} finalOut = do
       let parent = "_build" </> f -<.> "btrfs"
       need [parent]
       cmd_ "cp --reflink" [parent, out]
+      cmd_ "btrfstune -f -S0" [out]
       cmd_ "mkdir -p" [mountpoint]
       cmd_ "mount -t btrfs" [out] mountpoint
     EmptyImageOfBytes n -> do
@@ -110,10 +105,16 @@ buildRoot DiskImageConfig{..} finalOut = do
 
   -- TODO: catch errors and umount, rmdir mountpoint
   let (debs, packageNames) = partitionPackages $ unpack . coerce <$> toList packages
+  -- TODO: don't even run seflstrap when packageNames is null and a parent image exists
   cmd_ "selfstrap --skip-update"
     (("--unpack" `consWhen` unpackOnly) ["-t", mountpoint]) packageNames
   forM_ debs $ \pkg -> do
     cmd_ "dpkg -i --root" [mountpoint, pkg]
+  forM_ chrootCommands $ \c -> do
+    cmd_ "chroot" [mountpoint] "/bin/sh -c" [unpack c]
+  cmd_ "umount" [mountpoint]
+  cmd_ "rmdir" [mountpoint]
+  cmd_ "btrfstune -S1" [out]
   cmd_ "mv" [out, finalOut]
 
 partitionPackages :: [String] -> ([String], [String])
@@ -171,5 +172,6 @@ shakeRules = do
     buildRoot cfg out
 
   "*.btrfs" %> \out -> do
-    orderOnly ["_build" </> out]
-    cmd_ "cp --reflink=always -i" ["_build" </> out, out]
+    need ["_build" </> out]
+    -- WithStderr False needed for `cp` to interact with the tty
+    cmd_ (WithStderr False) "cp --reflink=always -i" ["_build" </> out, out]