diff options
-rw-r--r-- | fsmgr.hs | 42 | ||||
-rw-r--r-- | src/ConfigFile.hs | 9 |
2 files changed, 50 insertions, 1 deletions
@@ -34,6 +34,7 @@ import System.Posix.User (getEffectiveUserID) | |||
34 | noParent :: BaseImageSpecification -> Bool | 34 | noParent :: BaseImageSpecification -> Bool |
35 | noParent (EmptyImageOfBytes _) = True | 35 | noParent (EmptyImageOfBytes _) = True |
36 | noParent (ParentImageConfigFile _) = False | 36 | noParent (ParentImageConfigFile _) = False |
37 | noParent (SeededImage _ _) = False | ||
37 | 38 | ||
38 | dynamicNames :: FilePath -> FilePath | 39 | dynamicNames :: FilePath -> FilePath |
39 | dynamicNames = replace "$(karch)" uname . replace "$(debarch)" debarch | 40 | dynamicNames = replace "$(karch)" uname . replace "$(debarch)" debarch |
@@ -135,6 +136,20 @@ buildInitialImage DiskImageConfig{..} mountpoint out = do | |||
135 | cmd_ "btrfstune -f -S0" [out] | 136 | cmd_ "btrfstune -f -S0" [out] |
136 | cmd_ "mkdir -p" [mountpoint] | 137 | cmd_ "mkdir -p" [mountpoint] |
137 | cmd_ "mount -t btrfs" [out] mountpoint | 138 | cmd_ "mount -t btrfs" [out] mountpoint |
139 | |||
140 | SeededImage n f -> do | ||
141 | let parent = "_build" </> f -<.> "btrfs" | ||
142 | need [parent] | ||
143 | |||
144 | -- allocate new image file | ||
145 | cmd_ "rm -f" [out] | ||
146 | cmd_ "truncate -s" [show n, out] | ||
147 | cmd_ "fallocate -l" [show n, out] | ||
148 | |||
149 | idempotentMountImage parent mountpoint | ||
150 | |||
151 | addImageToBtrfs out mountpoint | ||
152 | |||
138 | EmptyImageOfBytes n -> do | 153 | EmptyImageOfBytes n -> do |
139 | cmd_ "truncate -s" [show n] [out] | 154 | cmd_ "truncate -s" [show n] [out] |
140 | cmd_ "mkfs.btrfs" [out] | 155 | cmd_ "mkfs.btrfs" [out] |
@@ -150,6 +165,33 @@ buildInitialImage DiskImageConfig{..} mountpoint out = do | |||
150 | cmd_ (Cwd mountpoint) "mkdir -p var/cache/debconf" | 165 | cmd_ (Cwd mountpoint) "mkdir -p var/cache/debconf" |
151 | cmd_ (Cwd mountpoint) "btrfs subvolume create var/cache/apt/archives" | 166 | cmd_ (Cwd mountpoint) "btrfs subvolume create var/cache/apt/archives" |
152 | 167 | ||
168 | idempotentSetupLoopDev :: FilePath -> Action (Maybe String) | ||
169 | idempotentSetupLoopDev imageFile = do | ||
170 | deleteLoopDev imageFile | ||
171 | cmd_ "losetup -f" imageFile | ||
172 | getLoopDev imageFile | ||
173 | where | ||
174 | deleteLoopDev = getLoopDev >=> mapM_ (cmd_ "losetup -d") | ||
175 | |||
176 | getLoopDev :: FilePath -> Action (Maybe String) | ||
177 | getLoopDev x = do | ||
178 | Stdout r <- cmd "losetup -n -O name -j" x | ||
179 | return $ guard (r /= "") >> Just r | ||
180 | |||
181 | idempotentMountImage :: FilePath -> FilePath -> Action () | ||
182 | idempotentMountImage imageFile mountPoint = do | ||
183 | cmd_ "mkdir -p" [mountPoint] | ||
184 | mounted <- cmd "mountpoint -q" [mountPoint] <&> (== ExitSuccess) | ||
185 | when mounted $ cmd_ "umount" [mountPoint] | ||
186 | cmd_ "mount -o compress,ro -t btrfs" [imageFile, mountPoint] | ||
187 | |||
188 | addImageToBtrfs :: FilePath -> FilePath -> Action () | ||
189 | addImageToBtrfs imageFile mountPoint = do | ||
190 | blockDevice <- idempotentSetupLoopDev imageFile <&> | ||
191 | fromMaybe (error "failed to set up loop device for " ++ imageFile) | ||
192 | cmd_ "btrfs device add" blockDevice mountPoint | ||
193 | cmd_ "mount -o remount,rw,compress" mountPoint | ||
194 | |||
153 | ignoreErrors' :: IO () -> IO () | 195 | ignoreErrors' :: IO () -> IO () |
154 | ignoreErrors' = flip catch (\(SomeException _) -> return ()) | 196 | ignoreErrors' = flip catch (\(SomeException _) -> return ()) |
155 | 197 | ||
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) | |||
48 | data BaseImageSpecification | 48 | data BaseImageSpecification |
49 | = EmptyImageOfBytes Int64 | 49 | = EmptyImageOfBytes Int64 |
50 | | ParentImageConfigFile FilePath | 50 | | ParentImageConfigFile FilePath |
51 | | SeededImage Int64 FilePath | ||
51 | deriving (Show, Read) | 52 | deriving (Show, Read) |
52 | 53 | ||
53 | data DiskImageConfig = DiskImageConfig { | 54 | data DiskImageConfig = DiskImageConfig { |
@@ -60,6 +61,7 @@ data DiskImageConfig = DiskImageConfig { | |||
60 | , chrootCommands :: Vector Text | 61 | , chrootCommands :: Vector Text |
61 | , skelFiles :: Vector Text | 62 | , skelFiles :: Vector Text |
62 | , optionalSkelFiles :: Vector Text | 63 | , optionalSkelFiles :: Vector Text |
64 | , newSeededImgSize :: Maybe Int64 | ||
63 | } deriving (Show, Read) | 65 | } deriving (Show, Read) |
64 | 66 | ||
65 | parsePackageName :: Text -> Package | 67 | parsePackageName :: Text -> Package |
@@ -77,7 +79,12 @@ diskImageConfigParser = object $ | |||
77 | <*> defaultField "chroot-commands" Vector.empty (array string) | 79 | <*> defaultField "chroot-commands" Vector.empty (array string) |
78 | <*> defaultField "skel-files" Vector.empty (array string) | 80 | <*> defaultField "skel-files" Vector.empty (array string) |
79 | <*> defaultField "skel-files-optional" Vector.empty (array string) | 81 | <*> defaultField "skel-files-optional" Vector.empty (array string) |
82 | <*> optField "seedme" integer | ||
83 | |||
84 | convSeeded :: DiskImageConfig -> DiskImageConfig | ||
85 | convSeeded x@(DiskImageConfig (ParentImageConfigFile f) _ _ _ _ _ _ _ _ (Just size)) = x { initialImage = SeededImage size f } | ||
86 | convSeeded x = x | ||
80 | 87 | ||
81 | readCfg :: FilePath -> Action DiskImageConfig | 88 | readCfg :: FilePath -> Action DiskImageConfig |
82 | readCfg yaml = either error id . parse diskImageConfigParser . encodeUtf8 . pack <$> readFile' yaml | 89 | readCfg yaml = either error convSeeded . parse diskImageConfigParser . encodeUtf8 . pack <$> readFile' yaml |
83 | 90 | ||