From a35b2f7ba9d18ac7fb89111e55924218042cbc4a Mon Sep 17 00:00:00 2001
From: Andrew Cady <d@jerkface.net>
Date: Wed, 27 May 2020 17:00:16 -0400
Subject: Begin support for "seeded images."

A seeded image keeps its parent image as a read-only "seed" device that
joins the seeded image in a multi-device btrfs filesystem.  That means
that to mount such an image, the parent image must be made available as
a block device (e.g. using losetup, or dd to an existing block device
and run btfrs device scan).

Such support had been added to the Samizdat Makefile, but more
properly belongs here.

This is the sequence of commands used by sami.git's Makefile to
accomplish the effect:

  rm -f $@~tmp
  touch $@~tmp
  fallocate -l $(samizdat_btrfs_patch_size) $@~tmp
  test -d $@.mnt || mkdir $@.mnt
  ! mountpoint -q $@.mnt || umount $@.mnt
  mount -o compress,ro -t btrfs $< $@.mnt
  a=$(get_loop_dev); [ -z "$$a" ] || losetup -d $$a
  losetup -f $@~tmp
  btrfs device add $(get_loop_dev) $@.mnt
  mount -o compress,rw,remount $@.mnt

The Makefile also defines:

  get_loop_dev="$$(sudo losetup -n -O name -j $@~tmp)"

The same basic sequence is carried out here.

The config file format is modified so that to get a seeded image you
specify "seedme: <bytes>" where <bytes> is the size of the seeded image.

This feature is complete enough to create a seeded image (i.e., to
replace the Makefile), but children of a seeded image seem impossible
to work because there is no code yet to run losetup on seed images of
parents.  Thus it can be expected that deriving from a parent with a
seed will fail when fsmgr tries to mount the parent.
---
 fsmgr.hs          | 42 ++++++++++++++++++++++++++++++++++++++++++
 src/ConfigFile.hs |  9 ++++++++-
 2 files changed, 50 insertions(+), 1 deletion(-)

diff --git a/fsmgr.hs b/fsmgr.hs
index ca80f8a..a2ee87d 100644
--- a/fsmgr.hs
+++ b/fsmgr.hs
@@ -34,6 +34,7 @@ import           System.Posix.User          (getEffectiveUserID)
 noParent :: BaseImageSpecification -> Bool
 noParent (EmptyImageOfBytes _)     = True
 noParent (ParentImageConfigFile _) = False
+noParent (SeededImage _ _) = False
 
 dynamicNames :: FilePath -> FilePath
 dynamicNames = replace "$(karch)" uname . replace "$(debarch)" debarch
@@ -135,6 +136,20 @@ buildInitialImage DiskImageConfig{..} mountpoint out = do
       cmd_ "btrfstune -f -S0" [out]
       cmd_ "mkdir -p" [mountpoint]
       cmd_ "mount -t btrfs" [out] mountpoint
+
+    SeededImage n f -> do
+      let parent = "_build" </> f -<.> "btrfs"
+      need [parent]
+
+      -- allocate new image file
+      cmd_ "rm -f" [out]
+      cmd_ "truncate -s" [show n, out]
+      cmd_ "fallocate -l" [show n, out]
+
+      idempotentMountImage parent mountpoint
+
+      addImageToBtrfs out mountpoint
+
     EmptyImageOfBytes n -> do
       cmd_ "truncate -s" [show n] [out]
       cmd_ "mkfs.btrfs" [out]
@@ -150,6 +165,33 @@ buildInitialImage DiskImageConfig{..} mountpoint out = do
       cmd_ (Cwd mountpoint) "mkdir -p var/cache/debconf"
       cmd_ (Cwd mountpoint) "btrfs subvolume create var/cache/apt/archives"
 
+idempotentSetupLoopDev :: FilePath -> Action (Maybe String)
+idempotentSetupLoopDev imageFile = do
+  deleteLoopDev imageFile
+  cmd_ "losetup -f" imageFile
+  getLoopDev imageFile
+  where
+    deleteLoopDev = getLoopDev >=> mapM_ (cmd_ "losetup -d")
+
+    getLoopDev :: FilePath -> Action (Maybe String)
+    getLoopDev x = do
+      Stdout r <- cmd "losetup -n -O name -j" x
+      return $ guard (r /= "") >> Just r
+
+idempotentMountImage :: FilePath -> FilePath -> Action ()
+idempotentMountImage imageFile mountPoint = do
+  cmd_ "mkdir -p" [mountPoint]
+  mounted <- cmd "mountpoint -q" [mountPoint] <&> (== ExitSuccess)
+  when mounted $ cmd_ "umount" [mountPoint]
+  cmd_ "mount -o compress,ro -t btrfs" [imageFile, mountPoint]
+
+addImageToBtrfs :: FilePath -> FilePath -> Action ()
+addImageToBtrfs imageFile mountPoint = do
+  blockDevice <- idempotentSetupLoopDev imageFile <&>
+    fromMaybe (error "failed to set up loop device for " ++ imageFile)
+  cmd_ "btrfs device add" blockDevice mountPoint
+  cmd_ "mount -o remount,rw,compress" mountPoint
+
 ignoreErrors' :: IO () -> IO ()
 ignoreErrors' = flip catch (\(SomeException _) -> return ())
 
diff --git a/src/ConfigFile.hs b/src/ConfigFile.hs
index bc5e254..08aa914 100644
--- a/src/ConfigFile.hs
+++ b/src/ConfigFile.hs
@@ -48,6 +48,7 @@ data Patch            = Patch deriving (Show, Read)
 data BaseImageSpecification
   = EmptyImageOfBytes Int64
   | ParentImageConfigFile FilePath
+  | SeededImage Int64 FilePath
   deriving (Show, Read)
 
 data DiskImageConfig = DiskImageConfig {
@@ -60,6 +61,7 @@ data DiskImageConfig = DiskImageConfig {
 , chrootCommands    :: Vector Text
 , skelFiles         :: Vector Text
 , optionalSkelFiles :: Vector Text
+, newSeededImgSize  :: Maybe Int64
 } deriving (Show, Read)
 
 parsePackageName :: Text -> Package
@@ -77,7 +79,12 @@ diskImageConfigParser = object $
   <*> defaultField "chroot-commands" Vector.empty (array string)
   <*> defaultField "skel-files" Vector.empty (array string)
   <*> defaultField "skel-files-optional" Vector.empty (array string)
+  <*> optField "seedme" integer
+
+convSeeded :: DiskImageConfig -> DiskImageConfig
+convSeeded x@(DiskImageConfig (ParentImageConfigFile f) _ _ _ _ _ _ _ _ (Just size)) = x { initialImage = SeededImage size f }
+convSeeded x = x
 
 readCfg :: FilePath -> Action DiskImageConfig
-readCfg yaml = either error id . parse diskImageConfigParser . encodeUtf8 . pack <$> readFile' yaml
+readCfg yaml = either error convSeeded . parse diskImageConfigParser . encodeUtf8 . pack <$> readFile' yaml
 
-- 
cgit v1.2.3