basic chroot support

1 files changed, 53 insertions, 16 deletions

diff --git a/fsmgr.hs b/fsmgr.hs
index a72e510..e715b3b 100644
--- a/fsmgr.hs
+++ b/fsmgr.hs
@@ -1,11 +1,13 @@
+{-# LANGUAGE ViewPatterns          #-}
 {-# OPTIONS_GHC -fno-warn-type-defaults #-}
-{-# LANGUAGE ExtendedDefaultRules #-}
-{-# LANGUAGE LambdaCase           #-}
-{-# LANGUAGE NamedFieldPuns       #-}
-{-# LANGUAGE NoImplicitPrelude    #-}
-{-# LANGUAGE OverloadedStrings    #-}
-{-# LANGUAGE RecordWildCards      #-}
-{-# LANGUAGE ScopedTypeVariables  #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE ExtendedDefaultRules  #-}
+{-# LANGUAGE LambdaCase            #-}
+{-# LANGUAGE NamedFieldPuns        #-}
+{-# LANGUAGE NoImplicitPrelude     #-}
+{-# LANGUAGE OverloadedStrings     #-}
+{-# LANGUAGE RecordWildCards       #-}
+{-# LANGUAGE ScopedTypeVariables   #-}
 
 module Main where
 import Rebase.Prelude hiding (bool, hash, o, (<.>))
@@ -17,9 +19,11 @@ import Development.Shake          hiding (getEnv)
 import Development.Shake.Command  ()
 import Development.Shake.FilePath
 
-import Options.Applicative as Opt
+import qualified Options.Applicative as Opt
+         ;import Options.Applicative hiding (action)
 
 import ConfigFile
+import System.Posix.Process (getProcessID)
 
 noParent :: BaseImageSpecification -> Bool
 noParent (EmptyImageOfBytes _)     = True
@@ -64,6 +68,8 @@ buildRoot DiskImageConfig{..} finalOut = do
     -- assume that this has already happened.
     cmd_ "selfstrap --skip-update" (("--unpack" `consWhen` unpackOnly) ["-t", mountpoint]) packageNames
   forM_ debs $ \pkg -> do cmd_ "dpkg -i --root" [mountpoint, pkg]
+  {- 2.5. install apt package cache -}
+  -- TODO
   {- 3. binaries -}
   forM_ (unpack <$> binaries) $ \b -> do
     p <- fromMaybe (fail $ "not found in ${PATH}: " ++ b) <$> liftIO (pathLocate b)
@@ -95,19 +101,20 @@ createDefaultSubvolume mountpoint = do
   when (null subvolId) $ fail "could not obtain btrfs Subvolume ID"
   cmd_ "btrfs subvolume set-default" [strip subvolId, mountpoint]
 
-defaultImageName :: String
-defaultImageName = "minbase"
-
 stripSuffix :: Text -> String -> String
 stripSuffix s t = fromMaybe t $ fmap unpack $ Text.stripSuffix s $ pack t
 
 data Options = Options { optCommand :: Command }
-data Command = Build BuildOpts
+data Command = Build BuildOpts | Chroot ChrootOpts
 data BuildOpts = BuildOpts { optTarget :: String }
+data ChrootOpts = ChrootOpts { optTarget :: String, optChrootCommand :: [String] }
 
 buildOpts :: Parser Command
 buildOpts = Build . BuildOpts <$> argument str idm
 
+chrootOpts :: Parser Command
+chrootOpts = fmap Chroot $ ChrootOpts <$> argument str idm <*> many (argument str idm)
+
 -- TODO: Fail early on:
 -- 1. not running as root
 -- 2. no "selfstrap" in PATH
@@ -121,16 +128,40 @@ main = customExecParser (prefs showHelpOnEmpty) (info opts desc) >>= run
                         "which, much like 'debootstrap', creates new installations of Debian."]
     parseCommand :: Parser Command
     parseCommand = subparser $ Opt.command "build" (info' buildOpts buildDesc)
-    buildDesc = ["build the image specified by the YAML config file"]
+                             <> Opt.command "chroot" (info' chrootOpts chrootDesc)
+    buildDesc  = ["build the image specified by the YAML config file"]
+    chrootDesc = ["chroot into the mounted image.  ",
+                  "Iff the chroot exits with a success value, filesystem changes will persist"]
+
     info' o d = info (helper <*> o) (progDesc $ unwords d)
 
 run :: Options -> IO ()
-run (Options (Build (BuildOpts target)))= shakeBuildOneImage (stripSuffix ".yaml" target)
+run (Options (Build (BuildOpts target)))        = shakeBuildOneImage target
+run (Options (Chroot (ChrootOpts target args))) = chrootImage target args
+
+chrootImage :: FilePath -> [String] -> IO ()
+chrootImage target args =
+  shake shakeOptions {shakeFiles = "_build"} $ do
+    shakeRules
+    action $ do
+      pid <- show <$> liftIO getProcessID
+      let inp = target -<.> "btrfs"
+      let tmp = inp <.> "tmp" <.> pid
+      let mnt = tmp <.> "mnt"
+      orderOnly [inp]
+      cmd_ "cp --reflink=always" [inp, tmp]
+      cmd_ "btrfstune -S0 -f" tmp
+      cmd_ "mkdir" [mnt]
+      cmd_ "mount -t btrfs" [tmp, mnt]
+      cmd_ (WithStderr False) (WithStdout False) "chroot" (mnt:args) -- TODO: cgroup
+      cmd_ "umount" [mnt] -- TODO: recursive umount
+      cmd_ "btrfstune -S1" tmp
+      cmd_ "mv" [tmp, inp]
 
 shakeBuildOneImage :: FilePath -> IO ()
 shakeBuildOneImage target =
   shake shakeOptions {shakeFiles = "_build"} $ do
-    want [target <.> "btrfs"]
+    want [target -<.> "btrfs"]
     shakeRules
 
 head1 :: String -> String
@@ -148,6 +179,13 @@ pathLocate c = (getEnv "SUDO_USER" >>=) $ fmap (validatePath . head1 . fromStdou
     validatePath "" = Nothing
     validatePath x  = Just x
 
+infix 1 ~%>
+(~%>) :: FilePattern -> (FilePath -> Action ()) -> Rules ()
+filepat ~%> act = phonys f
+  where
+    f file | (filepat ?== file) = Just (act file)
+    f _    = Nothing
+
 shakeRules :: Rules ()
 shakeRules = do
   "_build/*.yaml.canon" %> \out -> do
@@ -160,7 +198,6 @@ shakeRules = do
     need [cfgFile]
     cfg <- read <$> readFile' cfgFile
     buildRoot cfg out
-
   "*.btrfs" %> \out -> do
     need ["_build" </> out]
     -- WithStderr False needed for `cp` to interact with the tty