diff options
Diffstat (limited to 'fsmgr.hs')
-rw-r--r-- | fsmgr.hs | 46 |
1 files changed, 32 insertions, 14 deletions
@@ -8,13 +8,16 @@ | |||
8 | {-# LANGUAGE ScopedTypeVariables #-} | 8 | {-# LANGUAGE ScopedTypeVariables #-} |
9 | 9 | ||
10 | module Main where | 10 | module Main where |
11 | import Rebase.Prelude hiding (bool, hash, (<.>)) | 11 | import Rebase.Prelude hiding (bool, hash, o, (<.>)) |
12 | 12 | ||
13 | import Development.Shake hiding (getEnv) | 13 | import qualified Rebase.Data.Text as Text |
14 | import Development.Shake.Command () | 14 | ;import Rebase.Data.Text (pack, unpack) |
15 | |||
16 | import Development.Shake hiding (getEnv) | ||
17 | import Development.Shake.Command () | ||
15 | import Development.Shake.FilePath | 18 | import Development.Shake.FilePath |
16 | import qualified Rebase.Data.Text as Text | 19 | |
17 | ;import Rebase.Data.Text (pack, unpack) | 20 | import Options.Applicative as Opt |
18 | 21 | ||
19 | import ConfigFile | 22 | import ConfigFile |
20 | 23 | ||
@@ -98,16 +101,31 @@ defaultImageName = "minbase" | |||
98 | stripSuffix :: Text -> String -> String | 101 | stripSuffix :: Text -> String -> String |
99 | stripSuffix s t = fromMaybe t $ fmap unpack $ Text.stripSuffix s $ pack t | 102 | stripSuffix s t = fromMaybe t $ fmap unpack $ Text.stripSuffix s $ pack t |
100 | 103 | ||
104 | data Options = Options { optCommand :: Command } | ||
105 | data Command = Build BuildOpts | ||
106 | data BuildOpts = BuildOpts { optTarget :: String } | ||
107 | |||
108 | buildOpts :: Parser Command | ||
109 | buildOpts = Build . BuildOpts <$> argument str idm | ||
110 | |||
111 | -- TODO: Fail early on: | ||
112 | -- 1. not running as root | ||
113 | -- 2. no "selfstrap" in PATH | ||
101 | main :: IO () | 114 | main :: IO () |
102 | main = do | 115 | main = customExecParser (prefs showHelpOnEmpty) (info opts desc) >>= run |
103 | -- TODO: Fail early on: | 116 | where |
104 | -- 1. not running as root | 117 | opts :: Parser Options |
105 | -- 2. no "selfstrap" in PATH | 118 | opts = Options <$> parseCommand |
106 | args <- getArgs | 119 | desc = fullDesc <> progDesc detailed <> header "fsmgr - Debian rootfs image manager" |
107 | case args of | 120 | detailed = unwords ["This program generates btrfs filesystem images using 'selfstrap'", |
108 | [target] -> shakeBuildOneImage (stripSuffix ".yaml" target) | 121 | "which, much like 'debootstrap', creates new installations of Debian."] |
109 | [] -> shakeBuildOneImage defaultImageName | 122 | parseCommand :: Parser Command |
110 | _ -> error "usage" | 123 | parseCommand = subparser $ Opt.command "build" (info' buildOpts buildDesc) |
124 | buildDesc = ["build the image specified by the YAML config file"] | ||
125 | info' o d = info (helper <*> o) (progDesc $ unwords d) | ||
126 | |||
127 | run :: Options -> IO () | ||
128 | run (Options (Build (BuildOpts target)))= shakeBuildOneImage (stripSuffix ".yaml" target) | ||
111 | 129 | ||
112 | shakeBuildOneImage :: FilePath -> IO () | 130 | shakeBuildOneImage :: FilePath -> IO () |
113 | shakeBuildOneImage target = | 131 | shakeBuildOneImage target = |