module System.Unix.Chroot
( fchroot
, useEnv
) 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.Exit (ExitCode(ExitSuccess))
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.Process (readProcessWithExitCode, showCommandForUser)
foreign import ccall unsafe "chroot" c_chroot :: CString -> IO Int
forceList = undefined
forceList' = undefined
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
sockPath <- getEnv "SSH_AUTH_SOCK"
home <- getEnv "HOME"
copySSH home
withSock sockPath . fchroot rootPath $ (action >>= force)
where
copySSH Nothing = return ()
copySSH (Just home) =
run "/usr/bin/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 =
do createDirectoryIfMissing True mountPoint
run "/bin/mount" ["--bind", escapePathForMount toMount, escapePathForMount mountPoint]
result <- action
run "/bin/umount" [escapePathForMount mountPoint]
return result
escapePathForMount = id
run cmd args =
do (code, out, err) <- readProcessWithExitCode cmd args ""
case code of
ExitSuccess -> return ()
_ -> error ("Exception in System.Unix.Chroot.useEnv: " ++ showCommandForUser cmd args ++ " -> " ++ show code ++
"\n\nstdout:\n " ++ prefix "> " out ++ "\n\nstderr:\n" ++ prefix "> " err)
prefix pre s = unlines (map (pre ++) (lines s))