improvements & fixes

1 files changed, 43 insertions, 22 deletions

diff --git a/fsmgr.hs b/fsmgr.hs
index f18a951..47ce03f 100644
--- a/fsmgr.hs
+++ b/fsmgr.hs
@@ -50,26 +50,30 @@ newtype DebconfConfig = DebconfConfig Text deriving (Show, Read, Eq, Ord)
 newtype Package       = Package Text deriving (Show, Read, Eq, Ord)
 data Patch            = Patch deriving (Show, Read)
 
+data BaseImageSpecification
+  = EmptyImageOfBytes Int
+  | ParentImageConfigFile FilePath
+  deriving (Show, Read)
+
 data DiskImageConfig = DiskImageConfig {
-  initialImage  :: Either Int Text -- :: Either Integer (Digest SHA1)
-, unpacked      :: Set Package
-, debconfConfig :: DebconfConfig
-, configured    :: Bool
-, patched       :: Vector Text -- :: [Patch]
+  initialImage  :: BaseImageSpecification
+, packages      :: Set Package
+-- , debconfConfig :: DebconfConfig
+, unpackOnly    :: Bool
+-- , patched       :: Vector Text -- :: [Patch]
 } deriving (Show, Read)
 
+parsePackageName :: Text -> Package
+parsePackageName = Package -- TODO
+
 diskImageConfigParser :: Parser DiskImageConfig
 diskImageConfigParser = object $
   DiskImageConfig
-  <$> field "parent" ((Left <$> integer) <> (Right <$> string))
-  <*> (Set.fromList . toList . fmap f <$> (field "packages" (array string)))
-  <*> pure (DebconfConfig "")
+  <$> field "parent" ((EmptyImageOfBytes <$> integer) <> (ParentImageConfigFile . unpack <$> string))
+  <*> (Set.fromList . toList . fmap parsePackageName <$> (field "packages" (array string)))
+  -- <*> pure (DebconfConfig "")
   <*> defaultField "configure" True bool
-  <*> ((fromMaybe Vector.empty) <$> (optField "patches" (array string)))
-
-  where
-    f :: Text -> Package
-    f = Package
+  -- <*> ((fromMaybe Vector.empty) <$> (optField "patches" (array string)))
 
 diskImageFilename :: DiskImageConfig -> FilePath
 diskImageFilename = (++ ".btrfs") . show . sha1 . show
@@ -94,19 +98,22 @@ buildRoot DiskImageConfig{..} finalOut = do
   let out        = finalOut <.> "tmp"
       mountpoint = finalOut <.> "mnt"
   case initialImage of
-    Right x -> do
-      let parent = unpack x -<.> "yaml" <.> "btrfs"
+    ParentImageConfigFile f -> do
+      let parent = f -<.> "yaml" <.> "btrfs"
       need [parent]
       cmd_ "cp --reflink" [parent, out]
       cmd_ "mount -t btrfs" [out] mountpoint
-    Left size -> do
-      cmd_ "truncate -s" [show size] [out]
+    EmptyImageOfBytes n -> do
+      cmd_ "truncate -s" [show n] [out]
       cmd_ "mkfs.btrfs" [out]
       cmd_ "mkdir -p" [mountpoint]
       cmd_ "mount -t btrfs" [out] mountpoint
       createDefaultSubvolume mountpoint
       cmd_ (Cwd mountpoint) "btrfs subvolume create root/var/cache/apt/archives"
-  cmd_ "selfstrap -t" [mountpoint] (unpack . coerce <$> toList unpacked)
+  cmd_ "selfstrap" (("--unpack" `consWhen` unpackOnly) ["-t", mountpoint]) (unpack . coerce <$> toList packages)
+
+consWhen :: a -> Bool -> [a] -> [a]
+a `consWhen` c = if c then (a:) else id
 
 createDefaultSubvolume :: FilePath -> Action ()
 createDefaultSubvolume mountpoint = do
@@ -117,16 +124,30 @@ createDefaultSubvolume mountpoint = do
   cmd_ "btrfs subvolume set-default" [subvolId, mountpoint]
 
 
+
 main :: IO ()
-main = shake shakeOptions {shakeFiles = "_build"} $ do
-  want ["_build/" ++ targetFilename]
+main = do
+  args <- getArgs
+  case args of
+    [target] -> shakeBuildOneImage target
+    [] -> shakeBuildOneImage "image"
+    _ -> error "usage"
+
+shakeBuildOneImage :: FilePath -> IO ()
+shakeBuildOneImage target =
+  shake shakeOptions {shakeFiles = "_build"} $ do
+    want [target <.> "btrfs"]
+    shakeRules
+
+shakeRules :: Rules ()
+shakeRules = do
   "_build/*.yaml.canon" %> \out -> do
-    let yaml = dropDirectory1 (out -<.> "canon")
+    let yaml = dropDirectory1 $ dropExtension out
     need [yaml]
     cfg <- readCfg yaml
     writeFileChanged out (show cfg)
   "_build/*.btrfs" %> \out -> do
-    let cfgFile = "_build/" ++ (out -<.> "btrfs") <.> "yaml.canon"
+    let cfgFile = (out -<.> "yaml.canon")
     need [cfgFile]
     cfg <- read <$> readFile' cfgFile
     buildRoot cfg out