-- | 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 :: String -> Maybe String -> String -> IO String
setup String
propellorbin Maybe String
propellorbinpath String
dest = String -> IO String -> IO String
checkAlreadyShimmed String
propellorbin (IO String -> IO String) -> IO String -> IO String
forall a b. (a -> b) -> a -> b
$ do
	Bool -> String -> IO ()
createDirectoryIfMissing Bool
True String
dest

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

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

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

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

checkAlreadyShimmed :: FilePath -> IO FilePath -> IO FilePath
checkAlreadyShimmed :: String -> IO String -> IO String
checkAlreadyShimmed String
f IO String
nope = IO Bool -> (IO String, IO String) -> IO String
forall (m :: * -> *) a. Monad m => m Bool -> (m a, m a) -> m a
ifM (String -> IO Bool
doesFileExist String
f)
	( String -> IOMode -> (Handle -> IO String) -> IO String
forall r. String -> IOMode -> (Handle -> IO r) -> IO r
withFile String
f IOMode
ReadMode ((Handle -> IO String) -> IO String)
-> (Handle -> IO String) -> IO String
forall a b. (a -> b) -> a -> b
$ \Handle
h -> do
		s <- Handle -> IO String
hGetLine Handle
h
		if s == shebang
			then return f
			else nope
	, IO String
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
$ String -> IO ()
unsetEnv String
"GCONV_PATH"

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

installFile :: FilePath -> FilePath -> IO ()
installFile :: String -> String -> IO ()
installFile String
top String
f = do
	Bool -> String -> IO ()
createDirectoryIfMissing Bool
True String
destdir
	String -> IO ()
nukeFile String
dest
	String -> String -> IO ()
createLink String
f String
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
$ String -> [CommandParam] -> IO Bool
boolSystem String
"cp" [String -> CommandParam
Param String
"-a", String -> CommandParam
Param String
f, String -> CommandParam
Param String
dest]
	destdir :: String
destdir = String -> String -> String
inTop String
top (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String -> String
takeDirectory String
f
	dest :: String
dest = String -> String -> String
inTop String
top String
f