    -- | 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