module System.Unix.Chroot
( fchroot
, useEnv
, forceList
, forceList'
) where
import Control.Exception (finally, evaluate)
import qualified Data.ByteString.Char8 as B
import qualified Data.ByteString.Lazy.Char8 as L
import Foreign.C.Error
import Foreign.C.String
import System.Directory (createDirectoryIfMissing)
import System.FilePath (dropTrailingPathSeparator, dropFileName)
import System.IO (hPutStr, stderr)
import System.Posix.Env (getEnv)
import System.Posix.IO
import System.Posix.Directory
import System.Unix.Process (Output(..))
import System.Unix.Progress (lazyCommandF)
import System.Unix.QIO (quieter, qPutStrLn)
foreign import ccall unsafe "chroot" c_chroot :: CString -> IO Int
chroot :: FilePath -> IO ()
chroot fp = withCString fp $ \cfp -> throwErrnoIfMinus1_ "chroot" (c_chroot cfp)
fchroot :: FilePath -> IO a -> IO a
fchroot path action =
do origWd <- getWorkingDirectory
rootFd <- openFd "/" ReadOnly Nothing defaultFileFlags
chroot path
changeWorkingDirectory "/"
action `finally` (breakFree origWd rootFd)
where
breakFree origWd rootFd =
do changeWorkingDirectoryFd rootFd
closeFd rootFd
chroot "."
changeWorkingDirectory origWd
useEnv :: FilePath -> (a -> IO a) -> IO a -> IO a
useEnv rootPath force action =
do
qPutStrLn $ "Entering environment at " ++ rootPath
sockPath <- getEnv "SSH_AUTH_SOCK"
home <- getEnv "HOME"
copySSH home
withSock sockPath . fchroot rootPath $ (action >>= force)
where
copySSH Nothing = return ()
copySSH (Just home) =
system' ("rsync -rlptgDHxS --delete " ++ home ++ "/.ssh/ " ++ rootPath ++ "/root/.ssh")
withSock Nothing action = action
withSock (Just sockPath) action =
withMountBind dir (rootPath ++ dir) action
where dir = dropTrailingPathSeparator (dropFileName sockPath)
withMountBind toMount mountPoint action =
doMount
where
doMount =
do createDirectoryIfMissing True mountPoint
system' $ "mount --bind " ++ escapePathForMount toMount ++ " " ++ escapePathForMount mountPoint
result <- action
system' $ "umount " ++ escapePathForMount mountPoint
return result
escapePathForMount = id
system' s = lazyCommandF s L.empty >> return ()
forceList :: [a] -> IO [a]
forceList output = evaluate (length output) >> return output
forceList' :: [Output] -> IO [Output]
forceList' output = printOutput output >>= forceList
printOutput :: [Output] -> IO [Output]
printOutput output =
mapM print output
where
print x@(Stdout s) = putStr (B.unpack s) >> return x
print x@(Stderr s) = hPutStr stderr (B.unpack s) >> return x
print x = return x