1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
|
{-# OPTIONS_GHC -fno-warn-type-defaults #-}
{-# LANGUAGE ExtendedDefaultRules #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Main where
import Rebase.Prelude hiding (bool, hash, (<.>))
import Development.Shake hiding (getEnv)
import Development.Shake.Command ()
import Development.Shake.FilePath
import qualified Rebase.Data.Text as Text
;import Rebase.Data.Text (pack, unpack)
import ConfigFile
noParent :: BaseImageSpecification -> Bool
noParent (EmptyImageOfBytes _) = True
noParent (ParentImageConfigFile _) = False
buildRoot :: DiskImageConfig -> FilePath -> Action ()
buildRoot DiskImageConfig{..} finalOut = do
let out = finalOut <.> "tmp"
mountpoint = finalOut <.> "mnt"
cmd_ "sh -c" ["! mountpoint -q \"$0\" || umount \"$0\" ", mountpoint]
case initialImage of
ParentImageConfigFile f -> 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
cmd_ "truncate -s" [show n] [out]
cmd_ "mkfs.btrfs" [out]
cmd_ "mkdir -p" [mountpoint]
cmd_ "mount -t btrfs" [out] mountpoint
-- create new default subvolume, and then remount with it
createDefaultSubvolume mountpoint
cmd_ "umount" [mountpoint]
cmd_ "mount -t btrfs" [out, mountpoint]
cmd_ (Cwd mountpoint) "mkdir -p var/cache/apt"
cmd_ (Cwd mountpoint) "mkdir -p var/cache/debconf"
cmd_ (Cwd mountpoint) "btrfs subvolume create var/cache/apt/archives"
-- TODO: catch errors and umount, rmdir mountpoint
{- 1. debconf -}
forM_ debconfConfig $
readFile' >=> liftIO . appendFile (mountpoint </> "var/cache/debconf/config.dat")
{- 2. dpkg installs -}
let (debs, packageNames) = partitionPackages $ unpack . coerce <$> toList packages
when (noParent initialImage || not (null packageNames)) $
-- When there is no parent, selfstrap should install packages marked
-- "Required" even if no packages are specified. When there is a parent,
-- 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]
{- 3. binaries -}
forM_ (unpack <$> binaries) $ \b -> do
p <- fromMaybe (fail $ "not found in ${PATH}: " ++ b) <$> liftIO (pathLocate b)
cmd_ "cp -L" [p] [mountpoint </> "usr/local/bin" </> b]
{- 4. custom setup commands -}
forM_ chrootCommands $ \c -> do
cmd_ "chroot" [mountpoint] "/bin/sh -c" [unpack c]
-- cleanup
cmd_ "umount" [mountpoint]
cmd_ "rmdir" [mountpoint]
cmd_ "btrfstune -S1" [out]
cmd_ "mv" [out, finalOut]
partitionPackages :: [String] -> ([String], [String])
partitionPackages = partition (elem '/')
consWhen :: a -> Bool -> [a] -> [a]
a `consWhen` c = if c then (a:) else id
strip :: String -> String
strip = unpack . Text.strip . pack
createDefaultSubvolume :: FilePath -> Action ()
createDefaultSubvolume mountpoint = do
cmd_ (Cwd mountpoint) "btrfs subvolume create root"
Stdout subvolIdLine <- cmd (Cwd mountpoint) "sh -c"
["btrfs subvolume show root | sed -n -e 's/^[ \t]*Subvolume ID:[ \t]*//p; s/.*is toplevel subvolume/5/p'"]
let subvolId = strip subvolIdLine
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
main :: IO ()
main = do
-- TODO: Fail early on:
-- 1. not running as root
-- 2. no "selfstrap" in PATH
args <- getArgs
case args of
[target] -> shakeBuildOneImage (stripSuffix ".yaml" target)
[] -> shakeBuildOneImage defaultImageName
_ -> error "usage"
shakeBuildOneImage :: FilePath -> IO ()
shakeBuildOneImage target =
shake shakeOptions {shakeFiles = "_build"} $ do
want [target <.> "btrfs"]
shakeRules
head1 :: String -> String
head1 = lines >>> \case
[] -> ""
x:_ -> x
pathLocate :: String -> IO (Maybe FilePath)
pathLocate c = (getEnv "SUDO_USER" >>=) $ fmap (validatePath . head1 . fromStdout) <$> \case
"" -> cmd "which" [c]
u -> do
path <- fromStdout <$> cmd "su -" [u] "-c" ["printf %s \"$PATH\""]
cmd (AddEnv "PATH" path) "which" [c]
where
validatePath "" = Nothing
validatePath x = Just x
shakeRules :: Rules ()
shakeRules = do
"_build/*.yaml.canon" %> \out -> do
let yaml = dropDirectory1 $ dropExtension out
need [yaml]
cfg <- readCfg yaml
writeFileChanged out (show cfg)
"_build/*.btrfs" %> \out -> do
let cfgFile = (out -<.> "yaml.canon")
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
cmd_ (WithStderr False) "cp --reflink=always -i" ["_build" </> out, out]
|