shake things up

1 files changed, 90 insertions, 13 deletions

diff --git a/fsmgr.hs b/fsmgr.hs
index 71c38e0..f18a951 100644
--- a/fsmgr.hs
+++ b/fsmgr.hs
@@ -1,17 +1,27 @@
-{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# OPTIONS_GHC -fno-warn-type-defaults #-}
+{-# LANGUAGE ExtendedDefaultRules  #-}
 {-# LANGUAGE InstanceSigs          #-}
+{-# LANGUAGE NamedFieldPuns        #-}
 {-# LANGUAGE NoImplicitPrelude     #-}
 {-# LANGUAGE OverloadedStrings     #-}
 {-# LANGUAGE PartialTypeSignatures #-}
+{-# LANGUAGE RecordWildCards       #-}
+{-# LANGUAGE TypeApplications      #-}
 module Main where
-import           Rebase.Prelude                hiding (hash, bool)
+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 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.FilePath
+import Rebase.Data.Text           (pack, unpack)
+import Rebase.Data.Text.Encoding
 {-
 
 Basic idea is to have a fs.yaml that specifies the build procedure. Analogous to
@@ -29,6 +39,10 @@ the zeroeth step is to generate the empty (or just initial) filesystem image.
 The initial filesystem image, if nonempty, is specified by filename (otherwise,
 by size), while the hash of the configuration determines the output filename.
 
+--
+
+'Parent' param should be a config file, not hash. The hash will only be used to
+determine whether we need to build it.
 
 -}
 
@@ -36,9 +50,6 @@ newtype DebconfConfig = DebconfConfig Text deriving (Show, Read, Eq, Ord)
 newtype Package       = Package Text deriving (Show, Read, Eq, Ord)
 data Patch            = Patch deriving (Show, Read)
 
-sha1 :: ByteString -> Digest SHA1
-sha1 = hash
-
 data DiskImageConfig = DiskImageConfig {
   initialImage  :: Either Int Text -- :: Either Integer (Digest SHA1)
 , unpacked      :: Set Package
@@ -50,7 +61,7 @@ data DiskImageConfig = DiskImageConfig {
 diskImageConfigParser :: Parser DiskImageConfig
 diskImageConfigParser = object $
   DiskImageConfig
-  <$> field "initial-image" ((Left <$> integer) <> (Right <$> string))
+  <$> field "parent" ((Left <$> integer) <> (Right <$> string))
   <*> (Set.fromList . toList . fmap f <$> (field "packages" (array string)))
   <*> pure (DebconfConfig "")
   <*> defaultField "configure" True bool
@@ -58,7 +69,73 @@ diskImageConfigParser = object $
 
   where
     f :: Text -> Package
-    f = undefined
+    f = Package
+
+diskImageFilename :: DiskImageConfig -> FilePath
+diskImageFilename = (++ ".btrfs") . show . sha1 . show
+  where
+    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"
+  case initialImage of
+    Right x -> do
+      let parent = unpack x -<.> "yaml" <.> "btrfs"
+      need [parent]
+      cmd_ "cp --reflink" [parent, out]
+      cmd_ "mount -t btrfs" [out] mountpoint
+    Left size -> do
+      cmd_ "truncate -s" [show size] [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)
+
+createDefaultSubvolume :: FilePath -> Action ()
+createDefaultSubvolume mountpoint = do
+  cmd_ (Cwd mountpoint) "btrfs subvolume create root"
+  Stdout (subvolId::String) <- cmd (Cwd mountpoint) "sh -c"
+    ["btrfs subvolume show root | sed -n -e 's/^[ \t]*Subvolume ID:[ \t]*//p; s/.*is toplevel subvolume/5/p'"]
+  when (null subvolId) $ fail "could not obtain btrfs Subvolume ID"
+  cmd_ "btrfs subvolume set-default" [subvolId, mountpoint]
+
 
 main :: IO ()
-main = return ()
+main = shake shakeOptions {shakeFiles = "_build"} $ do
+  want ["_build/" ++ targetFilename]
+  "_build/*.yaml.canon" %> \out -> do
+    let yaml = dropDirectory1 (out -<.> "canon")
+    need [yaml]
+    cfg <- readCfg yaml
+    writeFileChanged out (show cfg)
+  "_build/*.btrfs" %> \out -> do
+    let cfgFile = "_build/" ++ (out -<.> "btrfs") <.> "yaml.canon"
+    need [cfgFile]
+    cfg <- read <$> readFile' cfgFile
+    buildRoot cfg out
+
+  "*.btrfs" %> \out -> do
+    orderOnly ["_build/" ++ out]
+    cmd_ "cp --reflink=always -i" ["_build/" ++ out, out]
+
+
+  -- "_build/" ++ targetFilename %> \out -> do
+  --   needParent targetConfig
+  --   return ()