{-# 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 fp :: 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
$ \cfp :: CString
cfp -> FilePath -> IO Int -> IO ()
forall a. (Eq a, Num a) => FilePath -> IO a -> IO ()
throwErrnoIfMinus1_ "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 path :: FilePath
path action :: 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 "/" 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 "/"
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 origWd :: FilePath
origWd rootFd :: Fd
rootFd =
do Fd -> IO ()
changeWorkingDirectoryFd Fd
rootFd
Fd -> IO ()
closeFd Fd
rootFd
FilePath -> IO ()
chroot "."
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 rootPath :: FilePath
rootPath force :: a -> m a
force action :: 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 "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 "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 Nothing = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
copySSH (Just home :: FilePath
home) =
Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
True (FilePath
rootPath FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ "/root") IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
FilePath -> [FilePath] -> IO ()
run "/usr/bin/rsync" ["-rlptgDHxS", "--delete", FilePath
home FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ "/.ssh/", FilePath
rootPath FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ "/root/.ssh"]
withSock :: (MonadIO m, MonadMask m) => Maybe FilePath -> m a -> m a
withSock :: Maybe FilePath -> m a -> m a
withSock Nothing action :: m a
action = m a
action
withSock (Just sockPath :: FilePath
sockPath) action :: 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 toMount :: FilePath
toMount mountPoint :: FilePath
mountPoint action :: 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 "/bin/mount" ["--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 "/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 cmd :: FilePath
cmd args :: [FilePath]
args =
do (code :: ExitCode
code, out :: FilePath
out, err :: FilePath
err) <- FilePath
-> [FilePath] -> FilePath -> IO (ExitCode, FilePath, FilePath)
readProcessWithExitCode FilePath
cmd [FilePath]
args ""
case ExitCode
code of
ExitSuccess -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
_ -> FilePath -> IO ()
forall a. HasCallStack => FilePath -> a
error ("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
forall a. [a] -> [a] -> [a]
++ ExitCode -> FilePath
forall a. Show a => a -> FilePath
show ExitCode
code FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++
"\n\nstdout:\n " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath -> FilePath -> FilePath
prefix "> " FilePath
out FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ "\n\nstderr:\n" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath -> FilePath -> FilePath
prefix "> " FilePath
err)
prefix :: FilePath -> FilePath -> FilePath
prefix pre :: FilePath
pre s :: 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))