{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE CPP #-}
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 = forall a. HasCallStack => a
undefined
{-# DEPRECATED forceList' "If you need forceList' enable it in progress-System.Unix.Process." #-}
forceList' :: a
forceList' = forall a. HasCallStack => a
undefined
chroot :: FilePath -> IO ()
chroot :: FilePath -> IO ()
chroot FilePath
fp = forall a. FilePath -> (CString -> IO a) -> IO a
withCString FilePath
fp forall a b. (a -> b) -> a -> b
$ \CString
cfp -> 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 :: forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
FilePath -> m a -> m a
fchroot FilePath
path m a
action =
do FilePath
origWd <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ IO FilePath
getWorkingDirectory
#if MIN_VERSION_unix(2,8,0)
rootFd <- liftIO $ openFd "/" ReadOnly defaultFileFlags
#else
Fd
rootFd <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ FilePath -> OpenMode -> Maybe FileMode -> OpenFileFlags -> IO Fd
openFd FilePath
"/" OpenMode
ReadOnly forall a. Maybe a
Nothing OpenFileFlags
defaultFileFlags
#endif
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ FilePath -> IO ()
chroot FilePath
path
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ FilePath -> IO ()
changeWorkingDirectory FilePath
"/"
m a
action forall (m :: * -> *) a b. MonadMask m => m a -> m b -> m a
`finally` (forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO 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 :: forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
FilePath -> (a -> m a) -> m a -> m a
useEnv FilePath
rootPath a -> m a
force m a
action =
do
Maybe FilePath
sockPath <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ FilePath -> IO (Maybe FilePath)
getEnv FilePath
"SSH_AUTH_SOCK"
Maybe FilePath
home <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ FilePath -> IO (Maybe FilePath)
getEnv FilePath
"HOME"
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Maybe FilePath -> IO ()
copySSH Maybe FilePath
home
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
Maybe FilePath -> m a -> m a
withSock Maybe FilePath
sockPath forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
FilePath -> m a -> m a
fchroot FilePath
rootPath forall a b. (a -> b) -> a -> b
$ (m a
action 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 = forall (m :: * -> *) a. Monad m => a -> m a
return ()
copySSH (Just FilePath
home) =
Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
True (FilePath
rootPath forall a. [a] -> [a] -> [a]
++ FilePath
"/root") 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 forall a. [a] -> [a] -> [a]
++ FilePath
"/.ssh/", FilePath
rootPath forall a. [a] -> [a] -> [a]
++ FilePath
"/root/.ssh"]
withSock :: (MonadIO m, MonadMask m) => Maybe FilePath -> m a -> m a
withSock :: forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
Maybe FilePath -> m a -> m a
withSock Maybe FilePath
Nothing m a
action = m a
action
withSock (Just FilePath
sockPath) m a
action =
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
FilePath -> FilePath -> m a -> m a
withMountBind FilePath
dir (FilePath
rootPath 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 :: forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
FilePath -> FilePath -> m a -> m a
withMountBind FilePath
toMount FilePath
mountPoint m a
action =
(do forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
True FilePath
mountPoint
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ FilePath -> [FilePath] -> IO ()
run FilePath
"/bin/mount" [FilePath
"--bind", forall {a}. a -> a
escapePathForMount FilePath
toMount, forall {a}. a -> a
escapePathForMount FilePath
mountPoint]
m a
action) forall (m :: * -> *) a b. MonadMask m => m a -> m b -> m a
`finally` (forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ FilePath -> [FilePath] -> IO ()
run FilePath
"/bin/umount" [forall {a}. a -> a
escapePathForMount FilePath
mountPoint])
escapePathForMount :: a -> a
escapePathForMount = 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 -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
ExitCode
_ -> forall a. HasCallStack => FilePath -> a
error (FilePath
"Exception in System.Unix.Chroot.useEnv: " forall a. [a] -> [a] -> [a]
++ FilePath -> [FilePath] -> FilePath
showCommandForUser FilePath
cmd [FilePath]
args forall a. [a] -> [a] -> [a]
++ FilePath
" -> " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> FilePath
show ExitCode
code forall a. [a] -> [a] -> [a]
++
FilePath
"\n\nstdout:\n " forall a. [a] -> [a] -> [a]
++ FilePath -> FilePath -> FilePath
prefix FilePath
"> " FilePath
out forall a. [a] -> [a] -> [a]
++ FilePath
"\n\nstderr:\n" forall a. [a] -> [a] -> [a]
++ FilePath -> FilePath -> FilePath
prefix FilePath
"> " FilePath
err)
prefix :: FilePath -> FilePath -> FilePath
prefix FilePath
pre FilePath
s = [FilePath] -> FilePath
unlines (forall a b. (a -> b) -> [a] -> [b]
map (FilePath
pre forall a. [a] -> [a] -> [a]
++) (FilePath -> [FilePath]
lines FilePath
s))