diff options
author | Andrew Cady <d@jerkface.net> | 2018-07-09 23:48:41 -0400 |
---|---|---|
committer | Andrew Cady <d@jerkface.net> | 2018-07-10 05:44:48 -0400 |
commit | ca5de8fc5e6fd55a73ac58f939961818e31d3dbf (patch) | |
tree | 9501826324718d3f5f0584e683b8d3cbb4280e06 /fsmgr.hs | |
parent | 67994be688ab65d9f135e920410f546b84de200d (diff) |
support for adding binaries from $PATH
Diffstat (limited to 'fsmgr.hs')
-rw-r--r-- | fsmgr.hs | 41 |
1 files changed, 30 insertions, 11 deletions
@@ -1,5 +1,6 @@ | |||
1 | {-# OPTIONS_GHC -fno-warn-type-defaults #-} | 1 | {-# OPTIONS_GHC -fno-warn-type-defaults #-} |
2 | {-# LANGUAGE ExtendedDefaultRules #-} | 2 | {-# LANGUAGE ExtendedDefaultRules #-} |
3 | {-# LANGUAGE LambdaCase #-} | ||
3 | {-# LANGUAGE NamedFieldPuns #-} | 4 | {-# LANGUAGE NamedFieldPuns #-} |
4 | {-# LANGUAGE NoImplicitPrelude #-} | 5 | {-# LANGUAGE NoImplicitPrelude #-} |
5 | {-# LANGUAGE OverloadedStrings #-} | 6 | {-# LANGUAGE OverloadedStrings #-} |
@@ -10,14 +11,14 @@ module Main where | |||
10 | import Rebase.Prelude hiding (bool, hash, (<.>)) | 11 | import Rebase.Prelude hiding (bool, hash, (<.>)) |
11 | 12 | ||
12 | import Data.Yaml.Combinators | 13 | import Data.Yaml.Combinators |
13 | import Development.Shake | 14 | import Development.Shake hiding (getEnv) |
14 | import Development.Shake.Command () | 15 | import Development.Shake.Command () |
15 | import Development.Shake.FilePath | 16 | import Development.Shake.FilePath |
16 | import qualified Rebase.Data.Set as Set | 17 | import qualified Rebase.Data.Set as Set |
17 | import qualified Rebase.Data.Text as Text | 18 | import qualified Rebase.Data.Text as Text |
18 | ;import Rebase.Data.Text (pack, unpack) | 19 | ;import Rebase.Data.Text (pack, unpack) |
19 | import Rebase.Data.Text.Encoding | 20 | import Rebase.Data.Text.Encoding |
20 | import qualified Rebase.Data.Vector as Vector | 21 | import qualified Rebase.Data.Vector as Vector |
21 | {- | 22 | {- |
22 | 23 | ||
23 | Basic idea is to have a fs.yaml that specifies the build procedure. Analogous to | 24 | Basic idea is to have a fs.yaml that specifies the build procedure. Analogous to |
@@ -52,12 +53,12 @@ data BaseImageSpecification | |||
52 | deriving (Show, Read) | 53 | deriving (Show, Read) |
53 | 54 | ||
54 | data DiskImageConfig = DiskImageConfig { | 55 | data DiskImageConfig = DiskImageConfig { |
55 | initialImage :: BaseImageSpecification | 56 | initialImage :: BaseImageSpecification |
56 | , packages :: Set Package | 57 | , packages :: Set Package |
57 | -- , debconfConfig :: DebconfConfig | 58 | -- , debconfConfig :: DebconfConfig |
58 | , unpackOnly :: Bool | 59 | , unpackOnly :: Bool |
59 | , binaries :: Vector Text | 60 | , binaries :: Vector Text |
60 | , chrootCommands :: Vector Text | 61 | , chrootCommands :: Vector Text |
61 | } deriving (Show, Read) | 62 | } deriving (Show, Read) |
62 | 63 | ||
63 | parsePackageName :: Text -> Package | 64 | parsePackageName :: Text -> Package |
@@ -108,6 +109,9 @@ buildRoot DiskImageConfig{..} finalOut = do | |||
108 | -- TODO: don't even run seflstrap when packageNames is null and a parent image exists | 109 | -- TODO: don't even run seflstrap when packageNames is null and a parent image exists |
109 | cmd_ "selfstrap --skip-update" | 110 | cmd_ "selfstrap --skip-update" |
110 | (("--unpack" `consWhen` unpackOnly) ["-t", mountpoint]) packageNames | 111 | (("--unpack" `consWhen` unpackOnly) ["-t", mountpoint]) packageNames |
112 | forM_ (unpack <$> binaries) $ \b -> do | ||
113 | p <- fromMaybe (fail $ "not found in ${PATH}: " ++ b) <$> liftIO (pathLocate b) | ||
114 | cmd_ "cp -L" [p] [mountpoint </> "usr/local/bin" </> b] | ||
111 | forM_ debs $ \pkg -> do | 115 | forM_ debs $ \pkg -> do |
112 | cmd_ "dpkg -i --root" [mountpoint, pkg] | 116 | cmd_ "dpkg -i --root" [mountpoint, pkg] |
113 | forM_ chrootCommands $ \c -> do | 117 | forM_ chrootCommands $ \c -> do |
@@ -158,6 +162,21 @@ shakeBuildOneImage target = | |||
158 | want [target <.> "btrfs"] | 162 | want [target <.> "btrfs"] |
159 | shakeRules | 163 | shakeRules |
160 | 164 | ||
165 | head1 :: String -> String | ||
166 | head1 = lines >>> \case | ||
167 | [] -> "" | ||
168 | x:_ -> x | ||
169 | |||
170 | pathLocate :: String -> IO (Maybe FilePath) | ||
171 | pathLocate c = (getEnv "SUDO_USER" >>=) $ fmap (validatePath . head1 . fromStdout) <$> \case | ||
172 | "" -> cmd "which" [c] | ||
173 | u -> do | ||
174 | path <- fromStdout <$> cmd "su -" [u] "-c" ["printf %s \"$PATH\""] | ||
175 | cmd (AddEnv "PATH" path) "which" [c] | ||
176 | where | ||
177 | validatePath "" = Nothing | ||
178 | validatePath x = Just x | ||
179 | |||
161 | shakeRules :: Rules () | 180 | shakeRules :: Rules () |
162 | shakeRules = do | 181 | shakeRules = do |
163 | "_build/*.yaml.canon" %> \out -> do | 182 | "_build/*.yaml.canon" %> \out -> do |