support for adding binaries from $PATH

1 files changed, 30 insertions, 11 deletions

diff --git a/fsmgr.hs b/fsmgr.hs
index 0434832..68def93 100644
--- a/fsmgr.hs
+++ b/fsmgr.hs
@@ -1,5 +1,6 @@
 {-# OPTIONS_GHC -fno-warn-type-defaults #-}
 {-# LANGUAGE ExtendedDefaultRules #-}
+{-# LANGUAGE LambdaCase           #-}
 {-# LANGUAGE NamedFieldPuns       #-}
 {-# LANGUAGE NoImplicitPrelude    #-}
 {-# LANGUAGE OverloadedStrings    #-}
@@ -10,14 +11,14 @@ module Main where
 import Rebase.Prelude hiding (bool, hash, (<.>))
 
 import Data.Yaml.Combinators
-import Development.Shake
-import Development.Shake.Command     ()
+import Development.Shake            hiding (getEnv)
+import Development.Shake.Command    ()
 import Development.Shake.FilePath
-import qualified Rebase.Data.Set     as Set
-import qualified Rebase.Data.Text    as Text
-         ;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
+import qualified Rebase.Data.Vector as Vector
 {-
 
 Basic idea is to have a fs.yaml that specifies the build procedure. Analogous to
@@ -52,12 +53,12 @@ data BaseImageSpecification
   deriving (Show, Read)
 
 data DiskImageConfig = DiskImageConfig {
-  initialImage     :: BaseImageSpecification
-, packages         :: Set Package
+  initialImage   :: BaseImageSpecification
+, packages       :: Set Package
 -- , debconfConfig :: DebconfConfig
-, unpackOnly       :: Bool
-, binaries         :: Vector Text
-, chrootCommands   :: Vector Text
+, unpackOnly     :: Bool
+, binaries       :: Vector Text
+, chrootCommands :: Vector Text
 } deriving (Show, Read)
 
 parsePackageName :: Text -> Package
@@ -108,6 +109,9 @@ buildRoot DiskImageConfig{..} finalOut = do
   -- TODO: don't even run seflstrap when packageNames is null and a parent image exists
   cmd_ "selfstrap --skip-update"
     (("--unpack" `consWhen` unpackOnly) ["-t", mountpoint]) packageNames
+  forM_ (unpack <$> binaries) $ \b -> do
+    p <- fromMaybe (fail $ "not found in ${PATH}: " ++ b) <$> liftIO (pathLocate b)
+    cmd_ "cp -L" [p] [mountpoint </> "usr/local/bin" </> b]
   forM_ debs $ \pkg -> do
     cmd_ "dpkg -i --root" [mountpoint, pkg]
   forM_ chrootCommands $ \c -> do
@@ -158,6 +162,21 @@ shakeBuildOneImage target =
     want [target <.> "btrfs"]
     shakeRules
 
+head1 :: String -> String
+head1 = lines >>> \case
+  []  -> ""
+  x:_ -> x
+
+pathLocate :: String -> IO (Maybe FilePath)
+pathLocate c = (getEnv "SUDO_USER" >>=) $ fmap (validatePath . head1 . fromStdout) <$> \case
+  "" -> cmd "which" [c]
+  u  -> do
+    path <- fromStdout <$> cmd "su -" [u] "-c" ["printf %s \"$PATH\""]
+    cmd (AddEnv "PATH" path) "which" [c]
+  where
+    validatePath "" = Nothing
+    validatePath x  = Just x
+
 shakeRules :: Rules ()
 shakeRules = do
   "_build/*.yaml.canon" %> \out -> do