-- | Support for running propellor, as built outside a container,
-- inside the container, without needing to install anything into the
-- container.
--
-- Note: This is currently Debian specific, due to glibcLibs.

module Propellor.Shim (setup, cleanEnv, file) where

import Propellor.Base
import Utility.LinuxMkLibs

import Data.List
import System.Posix.Files

-- | Sets up a shimmed version of the program, in a directory, and
-- returns its path.
--
-- If the shim was already set up, it's refreshed, in case newer
-- versions of libraries are needed.
--
-- Propellor may be running from an existing shim, in which case it's
-- simply reused.
setup :: FilePath -> Maybe FilePath -> FilePath -> IO FilePath
setup :: FilePath -> Maybe FilePath -> FilePath -> IO FilePath
setup propellorbin :: FilePath
propellorbin propellorbinpath :: Maybe FilePath
propellorbinpath dest :: FilePath
dest = FilePath -> IO FilePath -> IO FilePath
checkAlreadyShimmed FilePath
propellorbin (IO FilePath -> IO FilePath) -> IO FilePath -> IO FilePath
forall a b. (a -> b) -> a -> b
$ do
	Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
True FilePath
dest

	-- Remove all old libraries inside dest, but do not delete the
	-- directory itself, since it may be bind-mounted inside a chroot.
	(FilePath -> IO ()) -> [FilePath] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ FilePath -> IO ()
nukeFile ([FilePath] -> IO ()) -> IO [FilePath] -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< FilePath -> IO [FilePath]
dirContentsRecursive FilePath
dest

	[FilePath]
libs <- FilePath -> [FilePath]
parseLdd (FilePath -> [FilePath]) -> IO FilePath -> IO [FilePath]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> [FilePath] -> IO FilePath
readProcess "ldd" [FilePath
propellorbin]
	[FilePath]
glibclibs <- IO [FilePath]
glibcLibs
	let libs' :: [FilePath]
libs' = [FilePath] -> [FilePath]
forall a. Eq a => [a] -> [a]
nub ([FilePath] -> [FilePath]) -> [FilePath] -> [FilePath]
forall a b. (a -> b) -> a -> b
$ [FilePath]
libs [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ [FilePath]
glibclibs
	[FilePath]
libdirs <- (FilePath -> FilePath) -> [FilePath] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map (FilePath
dest FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++) ([FilePath] -> [FilePath])
-> ([Maybe FilePath] -> [FilePath])
-> [Maybe FilePath]
-> [FilePath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [FilePath] -> [FilePath]
forall a. Eq a => [a] -> [a]
nub ([FilePath] -> [FilePath])
-> ([Maybe FilePath] -> [FilePath])
-> [Maybe FilePath]
-> [FilePath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Maybe FilePath] -> [FilePath]
forall a. [Maybe a] -> [a]
catMaybes
		([Maybe FilePath] -> [FilePath])
-> IO [Maybe FilePath] -> IO [FilePath]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (FilePath -> IO (Maybe FilePath))
-> [FilePath] -> IO [Maybe FilePath]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((FilePath -> FilePath -> IO ())
-> FilePath -> FilePath -> IO (Maybe FilePath)
installLib FilePath -> FilePath -> IO ()
installFile FilePath
dest) [FilePath]
libs'
	
	let linker :: FilePath
linker = (FilePath
dest FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++) (FilePath -> FilePath) -> FilePath -> FilePath
forall a b. (a -> b) -> a -> b
$ 
		FilePath -> Maybe FilePath -> FilePath
forall a. a -> Maybe a -> a
fromMaybe (FilePath -> FilePath
forall a. HasCallStack => FilePath -> a
error "cannot find ld-linux linker") (Maybe FilePath -> FilePath) -> Maybe FilePath -> FilePath
forall a b. (a -> b) -> a -> b
$
			[FilePath] -> Maybe FilePath
forall a. [a] -> Maybe a
headMaybe ([FilePath] -> Maybe FilePath) -> [FilePath] -> Maybe FilePath
forall a b. (a -> b) -> a -> b
$ (FilePath -> Bool) -> [FilePath] -> [FilePath]
forall a. (a -> Bool) -> [a] -> [a]
filter ("ld-linux" FilePath -> FilePath -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isInfixOf`) [FilePath]
libs'
	let linkersym :: FilePath
linkersym = FilePath -> FilePath
takeDirectory FilePath
linker FilePath -> FilePath -> FilePath
</> FilePath -> FilePath
takeFileName FilePath
propellorbin
	FilePath -> FilePath -> IO ()
createSymbolicLink (FilePath -> FilePath
takeFileName FilePath
linker) FilePath
linkersym

	let gconvdir :: FilePath
gconvdir = (FilePath
dest FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++) (FilePath -> FilePath) -> FilePath -> FilePath
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath
takeDirectory (FilePath -> FilePath) -> FilePath -> FilePath
forall a b. (a -> b) -> a -> b
$
		FilePath -> Maybe FilePath -> FilePath
forall a. a -> Maybe a -> a
fromMaybe (FilePath -> FilePath
forall a. HasCallStack => FilePath -> a
error "cannot find gconv directory") (Maybe FilePath -> FilePath) -> Maybe FilePath -> FilePath
forall a b. (a -> b) -> a -> b
$
			[FilePath] -> Maybe FilePath
forall a. [a] -> Maybe a
headMaybe ([FilePath] -> Maybe FilePath) -> [FilePath] -> Maybe FilePath
forall a b. (a -> b) -> a -> b
$ (FilePath -> Bool) -> [FilePath] -> [FilePath]
forall a. (a -> Bool) -> [a] -> [a]
filter ("/gconv/" FilePath -> FilePath -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isInfixOf`) [FilePath]
glibclibs
	let linkerparams :: [FilePath]
linkerparams = ["--library-path", FilePath -> [FilePath] -> FilePath
forall a. [a] -> [[a]] -> [a]
intercalate ":" [FilePath]
libdirs ]
	FilePath -> FilePath -> IO ()
writeFile FilePath
shim (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ [FilePath] -> FilePath
unlines
		[ FilePath
shebang
		, "GCONV_PATH=" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath -> FilePath
shellEscape FilePath
gconvdir
		, "export GCONV_PATH"
		, "exec " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ [FilePath] -> FilePath
unwords ((FilePath -> FilePath) -> [FilePath] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map FilePath -> FilePath
shellEscape ([FilePath] -> [FilePath]) -> [FilePath] -> [FilePath]
forall a b. (a -> b) -> a -> b
$ FilePath
linkersym FilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
: [FilePath]
linkerparams) FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ 
			" " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath -> FilePath
shellEscape (FilePath -> Maybe FilePath -> FilePath
forall a. a -> Maybe a -> a
fromMaybe FilePath
propellorbin Maybe FilePath
propellorbinpath) FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ " \"$@\""
		]
	FilePath -> (FileMode -> FileMode) -> IO ()
modifyFileMode FilePath
shim ([FileMode] -> FileMode -> FileMode
addModes [FileMode]
executeModes)
	FilePath -> IO FilePath
forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
shim
  where
	shim :: FilePath
shim = FilePath -> FilePath -> FilePath
file FilePath
propellorbin FilePath
dest

shebang :: String
shebang :: FilePath
shebang = "#!/bin/sh"

checkAlreadyShimmed :: FilePath -> IO FilePath -> IO FilePath
checkAlreadyShimmed :: FilePath -> IO FilePath -> IO FilePath
checkAlreadyShimmed f :: FilePath
f nope :: IO FilePath
nope = IO Bool -> (IO FilePath, IO FilePath) -> IO FilePath
forall (m :: * -> *) a. Monad m => m Bool -> (m a, m a) -> m a
ifM (FilePath -> IO Bool
doesFileExist FilePath
f)
	( FilePath -> IOMode -> (Handle -> IO FilePath) -> IO FilePath
forall r. FilePath -> IOMode -> (Handle -> IO r) -> IO r
withFile FilePath
f IOMode
ReadMode ((Handle -> IO FilePath) -> IO FilePath)
-> (Handle -> IO FilePath) -> IO FilePath
forall a b. (a -> b) -> a -> b
$ \h :: Handle
h -> do
		FilePath
s <- Handle -> IO FilePath
hGetLine Handle
h
		if FilePath
s FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
shebang
			then FilePath -> IO FilePath
forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
f
			else IO FilePath
nope
	, IO FilePath
nope
	)

-- Called when the shimmed propellor is running, so that commands it runs
-- don't see it.
cleanEnv :: IO ()
cleanEnv :: IO ()
cleanEnv = IO () -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> IO ()
unsetEnv "GCONV_PATH"

file :: FilePath -> FilePath -> FilePath
file :: FilePath -> FilePath -> FilePath
file propellorbin :: FilePath
propellorbin dest :: FilePath
dest = FilePath
dest FilePath -> FilePath -> FilePath
</> FilePath -> FilePath
takeFileName FilePath
propellorbin

installFile :: FilePath -> FilePath -> IO ()
installFile :: FilePath -> FilePath -> IO ()
installFile top :: FilePath
top f :: FilePath
f = do
	Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
True FilePath
destdir
	FilePath -> IO ()
nukeFile FilePath
dest
	FilePath -> FilePath -> IO ()
createLink FilePath
f FilePath
dest IO () -> (IOException -> IO ()) -> IO ()
forall (m :: * -> *) a.
MonadCatch m =>
m a -> (IOException -> m a) -> m a
`catchIO` IO () -> IOException -> IO ()
forall a b. a -> b -> a
const IO ()
copy
  where
	copy :: IO ()
copy = IO Bool -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Bool -> IO ()) -> IO Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> [CommandParam] -> IO Bool
boolSystem "cp" [FilePath -> CommandParam
Param "-a", FilePath -> CommandParam
Param FilePath
f, FilePath -> CommandParam
Param FilePath
dest]
	destdir :: FilePath
destdir = FilePath -> FilePath -> FilePath
inTop FilePath
top (FilePath -> FilePath) -> FilePath -> FilePath
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath
takeDirectory FilePath
f
	dest :: FilePath
dest = FilePath -> FilePath -> FilePath
inTop FilePath
top FilePath
f