diff options
-rw-r--r-- | fsmgr.hs | 65 |
1 files changed, 43 insertions, 22 deletions
@@ -50,26 +50,30 @@ newtype DebconfConfig = DebconfConfig Text deriving (Show, Read, Eq, Ord) | |||
50 | newtype Package = Package Text deriving (Show, Read, Eq, Ord) | 50 | newtype Package = Package Text deriving (Show, Read, Eq, Ord) |
51 | data Patch = Patch deriving (Show, Read) | 51 | data Patch = Patch deriving (Show, Read) |
52 | 52 | ||
53 | data BaseImageSpecification | ||
54 | = EmptyImageOfBytes Int | ||
55 | | ParentImageConfigFile FilePath | ||
56 | deriving (Show, Read) | ||
57 | |||
53 | data DiskImageConfig = DiskImageConfig { | 58 | data DiskImageConfig = DiskImageConfig { |
54 | initialImage :: Either Int Text -- :: Either Integer (Digest SHA1) | 59 | initialImage :: BaseImageSpecification |
55 | , unpacked :: Set Package | 60 | , packages :: Set Package |
56 | , debconfConfig :: DebconfConfig | 61 | -- , debconfConfig :: DebconfConfig |
57 | , configured :: Bool | 62 | , unpackOnly :: Bool |
58 | , patched :: Vector Text -- :: [Patch] | 63 | -- , patched :: Vector Text -- :: [Patch] |
59 | } deriving (Show, Read) | 64 | } deriving (Show, Read) |
60 | 65 | ||
66 | parsePackageName :: Text -> Package | ||
67 | parsePackageName = Package -- TODO | ||
68 | |||
61 | diskImageConfigParser :: Parser DiskImageConfig | 69 | diskImageConfigParser :: Parser DiskImageConfig |
62 | diskImageConfigParser = object $ | 70 | diskImageConfigParser = object $ |
63 | DiskImageConfig | 71 | DiskImageConfig |
64 | <$> field "parent" ((Left <$> integer) <> (Right <$> string)) | 72 | <$> field "parent" ((EmptyImageOfBytes <$> integer) <> (ParentImageConfigFile . unpack <$> string)) |
65 | <*> (Set.fromList . toList . fmap f <$> (field "packages" (array string))) | 73 | <*> (Set.fromList . toList . fmap parsePackageName <$> (field "packages" (array string))) |
66 | <*> pure (DebconfConfig "") | 74 | -- <*> pure (DebconfConfig "") |
67 | <*> defaultField "configure" True bool | 75 | <*> defaultField "configure" True bool |
68 | <*> ((fromMaybe Vector.empty) <$> (optField "patches" (array string))) | 76 | -- <*> ((fromMaybe Vector.empty) <$> (optField "patches" (array string))) |
69 | |||
70 | where | ||
71 | f :: Text -> Package | ||
72 | f = Package | ||
73 | 77 | ||
74 | diskImageFilename :: DiskImageConfig -> FilePath | 78 | diskImageFilename :: DiskImageConfig -> FilePath |
75 | diskImageFilename = (++ ".btrfs") . show . sha1 . show | 79 | diskImageFilename = (++ ".btrfs") . show . sha1 . show |
@@ -94,19 +98,22 @@ buildRoot DiskImageConfig{..} finalOut = do | |||
94 | let out = finalOut <.> "tmp" | 98 | let out = finalOut <.> "tmp" |
95 | mountpoint = finalOut <.> "mnt" | 99 | mountpoint = finalOut <.> "mnt" |
96 | case initialImage of | 100 | case initialImage of |
97 | Right x -> do | 101 | ParentImageConfigFile f -> do |
98 | let parent = unpack x -<.> "yaml" <.> "btrfs" | 102 | let parent = f -<.> "yaml" <.> "btrfs" |
99 | need [parent] | 103 | need [parent] |
100 | cmd_ "cp --reflink" [parent, out] | 104 | cmd_ "cp --reflink" [parent, out] |
101 | cmd_ "mount -t btrfs" [out] mountpoint | 105 | cmd_ "mount -t btrfs" [out] mountpoint |
102 | Left size -> do | 106 | EmptyImageOfBytes n -> do |
103 | cmd_ "truncate -s" [show size] [out] | 107 | cmd_ "truncate -s" [show n] [out] |
104 | cmd_ "mkfs.btrfs" [out] | 108 | cmd_ "mkfs.btrfs" [out] |
105 | cmd_ "mkdir -p" [mountpoint] | 109 | cmd_ "mkdir -p" [mountpoint] |
106 | cmd_ "mount -t btrfs" [out] mountpoint | 110 | cmd_ "mount -t btrfs" [out] mountpoint |
107 | createDefaultSubvolume mountpoint | 111 | createDefaultSubvolume mountpoint |
108 | cmd_ (Cwd mountpoint) "btrfs subvolume create root/var/cache/apt/archives" | 112 | cmd_ (Cwd mountpoint) "btrfs subvolume create root/var/cache/apt/archives" |
109 | cmd_ "selfstrap -t" [mountpoint] (unpack . coerce <$> toList unpacked) | 113 | cmd_ "selfstrap" (("--unpack" `consWhen` unpackOnly) ["-t", mountpoint]) (unpack . coerce <$> toList packages) |
114 | |||
115 | consWhen :: a -> Bool -> [a] -> [a] | ||
116 | a `consWhen` c = if c then (a:) else id | ||
110 | 117 | ||
111 | createDefaultSubvolume :: FilePath -> Action () | 118 | createDefaultSubvolume :: FilePath -> Action () |
112 | createDefaultSubvolume mountpoint = do | 119 | createDefaultSubvolume mountpoint = do |
@@ -117,16 +124,30 @@ createDefaultSubvolume mountpoint = do | |||
117 | cmd_ "btrfs subvolume set-default" [subvolId, mountpoint] | 124 | cmd_ "btrfs subvolume set-default" [subvolId, mountpoint] |
118 | 125 | ||
119 | 126 | ||
127 | |||
120 | main :: IO () | 128 | main :: IO () |
121 | main = shake shakeOptions {shakeFiles = "_build"} $ do | 129 | main = do |
122 | want ["_build/" ++ targetFilename] | 130 | args <- getArgs |
131 | case args of | ||
132 | [target] -> shakeBuildOneImage target | ||
133 | [] -> shakeBuildOneImage "image" | ||
134 | _ -> error "usage" | ||
135 | |||
136 | shakeBuildOneImage :: FilePath -> IO () | ||
137 | shakeBuildOneImage target = | ||
138 | shake shakeOptions {shakeFiles = "_build"} $ do | ||
139 | want [target <.> "btrfs"] | ||
140 | shakeRules | ||
141 | |||
142 | shakeRules :: Rules () | ||
143 | shakeRules = do | ||
123 | "_build/*.yaml.canon" %> \out -> do | 144 | "_build/*.yaml.canon" %> \out -> do |
124 | let yaml = dropDirectory1 (out -<.> "canon") | 145 | let yaml = dropDirectory1 $ dropExtension out |
125 | need [yaml] | 146 | need [yaml] |
126 | cfg <- readCfg yaml | 147 | cfg <- readCfg yaml |
127 | writeFileChanged out (show cfg) | 148 | writeFileChanged out (show cfg) |
128 | "_build/*.btrfs" %> \out -> do | 149 | "_build/*.btrfs" %> \out -> do |
129 | let cfgFile = "_build/" ++ (out -<.> "btrfs") <.> "yaml.canon" | 150 | let cfgFile = (out -<.> "yaml.canon") |
130 | need [cfgFile] | 151 | need [cfgFile] |
131 | cfg <- read <$> readFile' cfgFile | 152 | cfg <- read <$> readFile' cfgFile |
132 | buildRoot cfg out | 153 | buildRoot cfg out |