{-# LANGUAGE ForeignFunctionInterface #-}
module System.Unix.Chroot
( fchroot
, useEnv
) where
import Control.Exception (evaluate)
import Control.Monad.Catch (MonadMask, finally)
import Control.Monad.Trans (MonadIO, liftIO)
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
{-# DEPRECATED forceList "If you need forceList enable it in progress-System.Unix.Process." #-}
forceList :: a
forceList = a
forall a. HasCallStack => a
undefined
{-# DEPRECATED forceList' "If you need forceList' enable it in progress-System.Unix.Process." #-}
forceList' :: a
forceList' = a
forall a. HasCallStack => a
undefined
chroot :: FilePath -> IO ()
chroot :: FilePath -> IO ()
chroot FilePath
fp = FilePath -> (CString -> IO ()) -> IO ()
forall a. FilePath -> (CString -> IO a) -> IO a
withCString FilePath
fp ((CString -> IO ()) -> IO ()) -> (CString -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \CString
cfp -> FilePath -> IO Int -> IO ()
forall a. (Eq a, Num a) => FilePath -> IO a -> IO ()
throwErrnoIfMinus1_ FilePath
"chroot" (CString -> IO Int
c_chroot CString
cfp)
fchroot :: (MonadIO m, MonadMask m) => FilePath -> m a -> m a
fchroot :: FilePath -> m a -> m a
fchroot FilePath
path m a
action =
do FilePath
origWd <- IO FilePath -> m FilePath
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO FilePath -> m FilePath) -> IO FilePath -> m FilePath
forall a b. (a -> b) -> a -> b
$ IO FilePath
getWorkingDirectory
Fd
rootFd <- IO Fd -> m Fd
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Fd -> m Fd) -> IO Fd -> m Fd
forall a b. (a -> b) -> a -> b
$ FilePath -> OpenMode -> Maybe FileMode -> OpenFileFlags -> IO Fd
openFd FilePath
"/" OpenMode
ReadOnly Maybe FileMode
forall a. Maybe a
Nothing OpenFileFlags
defaultFileFlags
IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ FilePath -> IO ()
chroot FilePath
path
IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ FilePath -> IO ()
changeWorkingDirectory FilePath
"/"
m a
action m a -> m () -> m a
forall (m :: * -> *) a b. MonadMask m => m a -> m b -> m a
`finally` (IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ FilePath -> Fd -> IO ()
breakFree FilePath
origWd Fd
rootFd)
where
breakFree :: FilePath -> Fd -> IO ()
breakFree FilePath
origWd Fd
rootFd =
do Fd -> IO ()
changeWorkingDirectoryFd Fd
rootFd
Fd -> IO ()
closeFd Fd
rootFd
FilePath -> IO ()
chroot FilePath
"."
FilePath -> IO ()
changeWorkingDirectory FilePath
origWd
useEnv :: (MonadIO m, MonadMask m) => FilePath -> (a -> m a) -> m a -> m a
useEnv :: FilePath -> (a -> m a) -> m a -> m a
useEnv FilePath
rootPath a -> m a
force m a
action =
do
Maybe FilePath
sockPath <- IO (Maybe FilePath) -> m (Maybe FilePath)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe FilePath) -> m (Maybe FilePath))
-> IO (Maybe FilePath) -> m (Maybe FilePath)
forall a b. (a -> b) -> a -> b
$ FilePath -> IO (Maybe FilePath)
getEnv FilePath
"SSH_AUTH_SOCK"
Maybe FilePath
home <- IO (Maybe FilePath) -> m (Maybe FilePath)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe FilePath) -> m (Maybe FilePath))
-> IO (Maybe FilePath) -> m (Maybe FilePath)
forall a b. (a -> b) -> a -> b
$ FilePath -> IO (Maybe FilePath)
getEnv FilePath
"HOME"
IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Maybe FilePath -> IO ()
copySSH Maybe FilePath
home
Maybe FilePath -> m a -> m a
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
Maybe FilePath -> m a -> m a
withSock Maybe FilePath
sockPath (m a -> m a) -> (m a -> m a) -> m a -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> m a -> m a
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
FilePath -> m a -> m a
fchroot FilePath
rootPath (m a -> m a) -> m a -> m a
forall a b. (a -> b) -> a -> b
$ (m a
action m a -> (a -> m a) -> m a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= a -> m a
force)
where
copySSH :: Maybe FilePath -> IO ()
copySSH Maybe FilePath
Nothing = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
copySSH (Just FilePath
home) =
Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
True (FilePath
rootPath FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"/root") IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
FilePath -> [FilePath] -> IO ()
run FilePath
"/usr/bin/rsync" [FilePath
"-rlptgDHxS", FilePath
"--delete", FilePath
home FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"/.ssh/", FilePath
rootPath FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"/root/.ssh"]
withSock :: (MonadIO m, MonadMask m) => Maybe FilePath -> m a -> m a
withSock :: Maybe FilePath -> m a -> m a
withSock Maybe FilePath
Nothing m a
action = m a
action
withSock (Just FilePath
sockPath) m a
action =
FilePath -> FilePath -> m a -> m a
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
FilePath -> FilePath -> m a -> m a
withMountBind FilePath
dir (FilePath
rootPath FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
dir) m a
action
where dir :: FilePath
dir = FilePath -> FilePath
dropTrailingPathSeparator (FilePath -> FilePath
dropFileName FilePath
sockPath)
withMountBind :: (MonadIO m, MonadMask m) => FilePath -> FilePath -> m a -> m a
withMountBind :: FilePath -> FilePath -> m a -> m a
withMountBind FilePath
toMount FilePath
mountPoint m a
action =
(do IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
True FilePath
mountPoint
IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ FilePath -> [FilePath] -> IO ()
run FilePath
"/bin/mount" [FilePath
"--bind", FilePath -> FilePath
forall a. a -> a
escapePathForMount FilePath
toMount, FilePath -> FilePath
forall a. a -> a
escapePathForMount FilePath
mountPoint]
m a
action) m a -> m () -> m a
forall (m :: * -> *) a b. MonadMask m => m a -> m b -> m a
`finally` (IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ FilePath -> [FilePath] -> IO ()
run FilePath
"/bin/umount" [FilePath -> FilePath
forall a. a -> a
escapePathForMount FilePath
mountPoint])
escapePathForMount :: a -> a
escapePathForMount = a -> a
forall a. a -> a
id
run :: FilePath -> [FilePath] -> IO ()
run FilePath
cmd [FilePath]
args =
do (ExitCode
code, FilePath
out, FilePath
err) <- FilePath
-> [FilePath] -> FilePath -> IO (ExitCode, FilePath, FilePath)
readProcessWithExitCode FilePath
cmd [FilePath]
args FilePath
""
case ExitCode
code of
ExitCode
ExitSuccess -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
ExitCode
_ -> FilePath -> IO ()
forall a. HasCallStack => FilePath -> a
error (FilePath
"Exception in System.Unix.Chroot.useEnv: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath -> [FilePath] -> FilePath
showCommandForUser FilePath
cmd [FilePath]
args FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" -> " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ ExitCode -> FilePath
forall a. Show a => a -> FilePath
show ExitCode
code FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++
FilePath
"\n\nstdout:\n " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath -> FilePath -> FilePath
prefix FilePath
"> " FilePath
out FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"\n\nstderr:\n" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath -> FilePath -> FilePath
prefix FilePath
"> " FilePath
err)
prefix :: FilePath -> FilePath -> FilePath
prefix FilePath
pre FilePath
s = [FilePath] -> FilePath
unlines ((FilePath -> FilePath) -> [FilePath] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map (FilePath
pre FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++) (FilePath -> [FilePath]
lines FilePath
s))