From 60f8cbcdd073854e6ea804b3129010dffbf0cdef Mon Sep 17 00:00:00 2001
From: Andrew Cady <d@jerkface.net>
Date: Sun, 25 Jun 2023 09:52:27 -0400
Subject: Store all btrfs images in local subvolumes

Most btrfs images were stored in `_build`, but some were stored in the
yaml source directory.  Those in the yaml source directory are moved to
the yaml source directory subdirectory `_filesystem`.

The code that creates `_filesystem` creates a btrfs subvolume.  The code
to create the `_build` directory has been changed to create a subvolume
as well.

Using subvolumes for image file directories allows them to be excluded
from backup snapshots, which is highly desirable for these very large
files.
---
 fsmgr.hs | 46 +++++++++++++++++++++++++++++++++-------------
 1 file changed, 33 insertions(+), 13 deletions(-)

diff --git a/fsmgr.hs b/fsmgr.hs
index 2ee7c7c..8036734 100644
--- a/fsmgr.hs
+++ b/fsmgr.hs
@@ -127,12 +127,11 @@ aptListFiles AptListCfg{..} =
       [ "httpredir.debian.org_debian_dists_bullseye_InRelease"
       , "httpredir.debian.org_debian_dists_bullseye_main_binary-amd64_Packages"
       , "httpredir.debian.org_debian_dists_bullseye_main_i18n_Translation-en"
-      -- , "httpredir.debian.org_debian_dists_sid_InRelease"
-      -- , "httpredir.debian.org_debian_dists_sid_main_binary-amd64_Packages"
-      -- , "httpredir.debian.org_debian_dists_sid_main_i18n_Translation-en"
-      , "security.debian.org_dists_bullseye-security_InRelease"
-      , "security.debian.org_dists_bullseye-security_main_binary-amd64_Packages"
-      , "security.debian.org_dists_bullseye-security_main_i18n_Translation-en"
+      , "security.debian.org_debian-security_dists_bullseye-security_InRelease"
+      , "security.debian.org_debian-security_dists_bullseye-security_main_binary-amd64_Packages"
+      , "security.debian.org_debian-security_dists_bullseye-security_main_i18n_Translation-en"
+      , "security.debian.org_debian-security_dists_bullseye-security_non-free_binary-amd64_Packages"
+      , "security.debian.org_debian-security_dists_bullseye-security_non-free_i18n_Translation-en"
       ]
 
 buildRoot :: DiskImageConfig -> FilePath -> Action ()
@@ -165,8 +164,11 @@ buildRoot config@DiskImageConfig{..} finalOut = do
       cmd_ "selfstrap" (("--unpack" `consWhen` unpackOnly) ["-t", mountpoint, "--release", releaseCodename aptListCfg]) (dynamicNames <$> packageNames)
     when (not $ null debs) $ do
       need debs
-      cmd_ (AddEnv "DEBIAN_FRONTEND" "noninteractive")
-           ["dpkg"] [if unpackOnly then "--unpack" else "--install"] ["--root", mountpoint] debs
+      ignoreErrors $
+        cmd_ (AddEnv "DEBIAN_FRONTEND" "noninteractive")
+             ["dpkg"] [if unpackOnly then "--unpack" else "--install"] ["--root", mountpoint] debs
+      cmd_ "chroot" [mountpoint] "/bin/sh -c" ["DEBIAN_FRONTEND=noninteractive apt -f install"]
+
     {- 3. binaries -}
     let go b = do
           p <- fromMaybe (fail $ "not found in ${PATH}: " ++ b) <$> liftIO (pathLocate b)
@@ -472,29 +474,47 @@ earlyFail = do
   Stdout () <- cmd (Traced []) "which selfstrap"
   return ()
 
+ioUnless :: MonadIO m => IO Bool -> m () -> m ()
+ioUnless test act = liftIO test >>= (`unless` act)
+
+needSubvolume :: FilePath -> Action ()
+needSubvolume path = ioUnless (IO.doesDirectoryExist path) $ cmd_ "btrfs subvolume create" [path]
+
 shakeRules :: Rules ()
 shakeRules = do
   "_build/*.yaml.canon" %> \out -> do
+    needSubvolume "_build"
     let yaml = dropDirectory1 $ dropExtension out
     need [yaml]
     cfg <- readCfg yaml
     writeFileChanged out (show cfg)
   "_build/*.btrfs" %> \out -> do
+    needSubvolume "_build"
     let cfgFile = (out -<.> "yaml.canon")
     need [cfgFile]
     cfg <- readEither <$> readFile' cfgFile
     either (error . (("Error parsing file: " ++ cfgFile ++ ": ") ++)) (flip buildRoot out) cfg
+
   priority 2 $ "*.seed.btrfs" %> \out -> do
-    let tmp = out <.> "tmp"
-        inp = dropExtension out -<.> ".btrfs"
+    needSubvolume "_build"
+    needSubvolume "_filesystem"
+    let inp = dropExtension out -<.> ".btrfs"
+        fso = "_filesystem" </> out
+        tmp = fso <.> "tmp"
     need [inp]
     cmd_ "cp --reflink=always" [inp, tmp]
     setupLoopDevices ("_build" </> inp <.> "btrfs")
     cmd_ "btrfs-shrink" [tmp]
     cmd_ "btrfstune -f -S1" [tmp]
-    cmd_ (WithStderr False) "mv -i" [tmp, out]
+    cmd_ (WithStderr False) "mv -i" [tmp, fso]
+    cmd_ (WithStderr False) "ln -s -i" [fso, out]
 
   priority 1 $ "*.btrfs" %> \out -> do
-    need ["_build" </> out]
+    needSubvolume "_build"
+    needSubvolume "_filesystem"
+    let b = "_build" </> out
+        f = "_filesystem" </> out
+    need [b]
     -- WithStderr False needed for `cp` to interact with the tty
-    cmd_ (WithStderr False) "cp --reflink=always -i" ["_build" </> out, out]
+    cmd_ (WithStderr False) "cp --reflink=always -i" [b, f]
+    cmd_ (WithStderr False) "ln -s -i" [f, out]
-- 
cgit v1.2.3