werks purty good

1 files changed, 37 insertions, 29 deletions

diff --git a/fsmgr.hs b/fsmgr.hs
index 47ce03f..0c4bfe2 100644
--- a/fsmgr.hs
+++ b/fsmgr.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE ScopedTypeVariables   #-}
 {-# OPTIONS_GHC -fno-warn-type-defaults #-}
 {-# LANGUAGE ExtendedDefaultRules  #-}
 {-# LANGUAGE InstanceSigs          #-}
@@ -14,14 +14,14 @@ import Rebase.Prelude hiding (bool, hash, (<.>))
 import Crypto.Hash
 import Crypto.Hash.Types.Digest.Read ()
 import Data.Yaml.Combinators
-import qualified Rebase.Data.Set     as Set
-import qualified Rebase.Data.Vector  as Vector
-
 import Development.Shake
-import Development.Shake.Command()
+import Development.Shake.Command     ()
 import Development.Shake.FilePath
-import Rebase.Data.Text           (pack, unpack)
+import qualified Rebase.Data.Set     as Set
+import qualified Rebase.Data.Text    as Text
+         ;import Rebase.Data.Text    (pack, unpack)
 import Rebase.Data.Text.Encoding
+import qualified Rebase.Data.Vector  as Vector
 {-
 
 Basic idea is to have a fs.yaml that specifies the build procedure. Analogous to
@@ -56,11 +56,11 @@ data BaseImageSpecification
   deriving (Show, Read)
 
 data DiskImageConfig = DiskImageConfig {
-  initialImage  :: BaseImageSpecification
-, packages      :: Set Package
+  initialImage :: BaseImageSpecification
+, packages     :: Set Package
 -- , debconfConfig :: DebconfConfig
-, unpackOnly    :: Bool
--- , patched       :: Vector Text -- :: [Patch]
+, unpackOnly   :: Bool
+, binaries     :: Vector Text -- :: [Patch]
 } deriving (Show, Read)
 
 parsePackageName :: Text -> Package
@@ -70,10 +70,10 @@ diskImageConfigParser :: Parser DiskImageConfig
 diskImageConfigParser = object $
   DiskImageConfig
   <$> field "parent" ((EmptyImageOfBytes <$> integer) <> (ParentImageConfigFile . unpack <$> string))
-  <*> (Set.fromList . toList . fmap parsePackageName <$> (field "packages" (array string)))
+  <*> (Set.fromList . toList . fmap parsePackageName <$> defaultField "packages" Vector.empty (array string))
   -- <*> pure (DebconfConfig "")
-  <*> defaultField "configure" True bool
-  -- <*> ((fromMaybe Vector.empty) <$> (optField "patches" (array string)))
+  <*> defaultField "unpack-only" False bool
+  <*> defaultField "binaries" Vector.empty (array string)
 
 diskImageFilename :: DiskImageConfig -> FilePath
 diskImageFilename = (++ ".btrfs") . show . sha1 . show
@@ -81,27 +81,20 @@ diskImageFilename = (++ ".btrfs") . show . sha1 . show
     sha1 :: String -> Digest SHA1
     sha1 = hash . encodeUtf8 . pack
 
-targetConfig :: DiskImageConfig
-targetConfig = undefined
-
-targetFilename :: FilePath
-targetFilename = diskImageFilename targetConfig
-
 readCfg :: FilePath -> Action DiskImageConfig
 readCfg yaml = either error id . parse diskImageConfigParser . encodeUtf8 . pack <$> readFile' yaml
 
-s :: String -> String
-s = id
-
 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 = f -<.> "yaml" <.> "btrfs"
+      let parent = "_build" </> f -<.> "btrfs"
       need [parent]
       cmd_ "cp --reflink" [parent, out]
+      cmd_ "mkdir -p" [mountpoint]
       cmd_ "mount -t btrfs" [out] mountpoint
     EmptyImageOfBytes n -> do
       cmd_ "truncate -s" [show n] [out]
@@ -109,29 +102,44 @@ buildRoot DiskImageConfig{..} finalOut = do
       cmd_ "mkdir -p" [mountpoint]
       cmd_ "mount -t btrfs" [out] mountpoint
       createDefaultSubvolume mountpoint
+      cmd_ (Cwd mountpoint) "mkdir -p root/var/cache/apt"
       cmd_ (Cwd mountpoint) "btrfs subvolume create root/var/cache/apt/archives"
-  cmd_ "selfstrap" (("--unpack" `consWhen` unpackOnly) ["-t", mountpoint]) (unpack . coerce <$> toList packages)
+  -- TODO: catch errors and umount, rmdir mountpoint
+  cmd_ "selfstrap --skip-update"
+    (("--unpack" `consWhen` unpackOnly) ["-t", mountpoint]) (unpack . coerce <$> toList packages)
+  cmd_ "mv" [out, finalOut]
 
 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 (subvolId::String) <- cmd (Cwd mountpoint) "sh -c"
+  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" [subvolId, mountpoint]
+  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 target
-    [] -> shakeBuildOneImage "image"
-    _ -> error "usage"
+    [target] -> shakeBuildOneImage (stripSuffix ".yaml" target)
+    []       -> shakeBuildOneImage defaultImageName
+    _        -> error "usage"
 
 shakeBuildOneImage :: FilePath -> IO ()
 shakeBuildOneImage target =