diff options
Diffstat (limited to 'fsmgr.hs')
-rw-r--r-- | fsmgr.hs | 103 |
1 files changed, 90 insertions, 13 deletions
@@ -1,17 +1,27 @@ | |||
1 | {-# LANGUAGE TypeApplications #-} | 1 | {-# LANGUAGE ScopedTypeVariables #-} |
2 | {-# OPTIONS_GHC -fno-warn-type-defaults #-} | ||
3 | {-# LANGUAGE ExtendedDefaultRules #-} | ||
2 | {-# LANGUAGE InstanceSigs #-} | 4 | {-# LANGUAGE InstanceSigs #-} |
5 | {-# LANGUAGE NamedFieldPuns #-} | ||
3 | {-# LANGUAGE NoImplicitPrelude #-} | 6 | {-# LANGUAGE NoImplicitPrelude #-} |
4 | {-# LANGUAGE OverloadedStrings #-} | 7 | {-# LANGUAGE OverloadedStrings #-} |
5 | {-# LANGUAGE PartialTypeSignatures #-} | 8 | {-# LANGUAGE PartialTypeSignatures #-} |
9 | {-# LANGUAGE RecordWildCards #-} | ||
10 | {-# LANGUAGE TypeApplications #-} | ||
6 | module Main where | 11 | module Main where |
7 | import Rebase.Prelude hiding (hash, bool) | 12 | import Rebase.Prelude hiding (bool, hash, (<.>)) |
8 | 13 | ||
9 | import Crypto.Hash | 14 | import Crypto.Hash |
10 | import Crypto.Hash.Types.Digest.Read () | 15 | import Crypto.Hash.Types.Digest.Read () |
11 | import Data.Yaml.Combinators | 16 | import Data.Yaml.Combinators |
12 | import qualified Rebase.Data.Set as Set | 17 | import qualified Rebase.Data.Set as Set |
13 | import qualified Rebase.Data.Vector as Vector | 18 | import qualified Rebase.Data.Vector as Vector |
14 | 19 | ||
20 | import Development.Shake | ||
21 | import Development.Shake.Command() | ||
22 | import Development.Shake.FilePath | ||
23 | import Rebase.Data.Text (pack, unpack) | ||
24 | import Rebase.Data.Text.Encoding | ||
15 | {- | 25 | {- |
16 | 26 | ||
17 | Basic idea is to have a fs.yaml that specifies the build procedure. Analogous to | 27 | 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. | |||
29 | The initial filesystem image, if nonempty, is specified by filename (otherwise, | 39 | The initial filesystem image, if nonempty, is specified by filename (otherwise, |
30 | by size), while the hash of the configuration determines the output filename. | 40 | by size), while the hash of the configuration determines the output filename. |
31 | 41 | ||
42 | -- | ||
43 | |||
44 | 'Parent' param should be a config file, not hash. The hash will only be used to | ||
45 | determine whether we need to build it. | ||
32 | 46 | ||
33 | -} | 47 | -} |
34 | 48 | ||
@@ -36,9 +50,6 @@ newtype DebconfConfig = DebconfConfig Text deriving (Show, Read, Eq, Ord) | |||
36 | newtype Package = Package Text deriving (Show, Read, Eq, Ord) | 50 | newtype Package = Package Text deriving (Show, Read, Eq, Ord) |
37 | data Patch = Patch deriving (Show, Read) | 51 | data Patch = Patch deriving (Show, Read) |
38 | 52 | ||
39 | sha1 :: ByteString -> Digest SHA1 | ||
40 | sha1 = hash | ||
41 | |||
42 | data DiskImageConfig = DiskImageConfig { | 53 | data DiskImageConfig = DiskImageConfig { |
43 | initialImage :: Either Int Text -- :: Either Integer (Digest SHA1) | 54 | initialImage :: Either Int Text -- :: Either Integer (Digest SHA1) |
44 | , unpacked :: Set Package | 55 | , unpacked :: Set Package |
@@ -50,7 +61,7 @@ data DiskImageConfig = DiskImageConfig { | |||
50 | diskImageConfigParser :: Parser DiskImageConfig | 61 | diskImageConfigParser :: Parser DiskImageConfig |
51 | diskImageConfigParser = object $ | 62 | diskImageConfigParser = object $ |
52 | DiskImageConfig | 63 | DiskImageConfig |
53 | <$> field "initial-image" ((Left <$> integer) <> (Right <$> string)) | 64 | <$> field "parent" ((Left <$> integer) <> (Right <$> string)) |
54 | <*> (Set.fromList . toList . fmap f <$> (field "packages" (array string))) | 65 | <*> (Set.fromList . toList . fmap f <$> (field "packages" (array string))) |
55 | <*> pure (DebconfConfig "") | 66 | <*> pure (DebconfConfig "") |
56 | <*> defaultField "configure" True bool | 67 | <*> defaultField "configure" True bool |
@@ -58,7 +69,73 @@ diskImageConfigParser = object $ | |||
58 | 69 | ||
59 | where | 70 | where |
60 | f :: Text -> Package | 71 | f :: Text -> Package |
61 | f = undefined | 72 | f = Package |
73 | |||
74 | diskImageFilename :: DiskImageConfig -> FilePath | ||
75 | diskImageFilename = (++ ".btrfs") . show . sha1 . show | ||
76 | where | ||
77 | sha1 :: String -> Digest SHA1 | ||
78 | sha1 = hash . encodeUtf8 . pack | ||
79 | |||
80 | targetConfig :: DiskImageConfig | ||
81 | targetConfig = undefined | ||
82 | |||
83 | targetFilename :: FilePath | ||
84 | targetFilename = diskImageFilename targetConfig | ||
85 | |||
86 | readCfg :: FilePath -> Action DiskImageConfig | ||
87 | readCfg yaml = either error id . parse diskImageConfigParser . encodeUtf8 . pack <$> readFile' yaml | ||
88 | |||
89 | s :: String -> String | ||
90 | s = id | ||
91 | |||
92 | buildRoot :: DiskImageConfig -> FilePath -> Action () | ||
93 | buildRoot DiskImageConfig{..} finalOut = do | ||
94 | let out = finalOut <.> "tmp" | ||
95 | mountpoint = finalOut <.> "mnt" | ||
96 | case initialImage of | ||
97 | Right x -> do | ||
98 | let parent = unpack x -<.> "yaml" <.> "btrfs" | ||
99 | need [parent] | ||
100 | cmd_ "cp --reflink" [parent, out] | ||
101 | cmd_ "mount -t btrfs" [out] mountpoint | ||
102 | Left size -> do | ||
103 | cmd_ "truncate -s" [show size] [out] | ||
104 | cmd_ "mkfs.btrfs" [out] | ||
105 | cmd_ "mkdir -p" [mountpoint] | ||
106 | cmd_ "mount -t btrfs" [out] mountpoint | ||
107 | createDefaultSubvolume mountpoint | ||
108 | cmd_ (Cwd mountpoint) "btrfs subvolume create root/var/cache/apt/archives" | ||
109 | cmd_ "selfstrap -t" [mountpoint] (unpack . coerce <$> toList unpacked) | ||
110 | |||
111 | createDefaultSubvolume :: FilePath -> Action () | ||
112 | createDefaultSubvolume mountpoint = do | ||
113 | cmd_ (Cwd mountpoint) "btrfs subvolume create root" | ||
114 | Stdout (subvolId::String) <- cmd (Cwd mountpoint) "sh -c" | ||
115 | ["btrfs subvolume show root | sed -n -e 's/^[ \t]*Subvolume ID:[ \t]*//p; s/.*is toplevel subvolume/5/p'"] | ||
116 | when (null subvolId) $ fail "could not obtain btrfs Subvolume ID" | ||
117 | cmd_ "btrfs subvolume set-default" [subvolId, mountpoint] | ||
118 | |||
62 | 119 | ||
63 | main :: IO () | 120 | main :: IO () |
64 | main = return () | 121 | main = shake shakeOptions {shakeFiles = "_build"} $ do |
122 | want ["_build/" ++ targetFilename] | ||
123 | "_build/*.yaml.canon" %> \out -> do | ||
124 | let yaml = dropDirectory1 (out -<.> "canon") | ||
125 | need [yaml] | ||
126 | cfg <- readCfg yaml | ||
127 | writeFileChanged out (show cfg) | ||
128 | "_build/*.btrfs" %> \out -> do | ||
129 | let cfgFile = "_build/" ++ (out -<.> "btrfs") <.> "yaml.canon" | ||
130 | need [cfgFile] | ||
131 | cfg <- read <$> readFile' cfgFile | ||
132 | buildRoot cfg out | ||
133 | |||
134 | "*.btrfs" %> \out -> do | ||
135 | orderOnly ["_build/" ++ out] | ||
136 | cmd_ "cp --reflink=always -i" ["_build/" ++ out, out] | ||
137 | |||
138 | |||
139 | -- "_build/" ++ targetFilename %> \out -> do | ||
140 | -- needParent targetConfig | ||
141 | -- return () | ||