{-# LANGUAGE ForeignFunctionInterface #-}
-- | This module, except for useEnv, is copied from the build-env package.
module System.Unix.Chroot
    ( fchroot
    , useEnv
    -- , forceList  -- moved to progress
    -- , forceList'
    ) 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 changes the root directory to filepath
-- NOTE: it does not change the working directory, just the root directory
-- NOTE: will throw IOError if chroot fails
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 runs an IO action inside a chroot
-- fchroot performs a chroot, runs the action, and then restores the
-- original root and working directory. This probably affects the
-- chroot and working directory of all the threads in the process,
-- so...
-- NOTE: will throw IOError if internal chroot fails
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

-- |The ssh inside of the chroot needs to be able to talk to the
-- running ssh-agent.  Therefore we mount --bind the ssh agent socket
-- dir inside the chroot (and umount it when we exit the chroot.
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 -- In order to minimize confusion, this QIO message is output
       -- at default quietness.  If you want to suppress it while seeing
       -- the output from your action, you need to say something like
       -- quieter (+ 1) (useEnv (quieter (\x->x-1) action))
       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
       -- We need to force the output before we exit the changeroot.
       -- Otherwise we lose our ability to communicate with the ssh
       -- agent and we get errors.
       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) =
          -- Do NOT preserve ownership, files must be owned by root.
          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   -- FIXME - Path arguments should be escaped

      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))

{-
printDots :: Int -> [Output] -> IO [Output]
printDots cpd output =
    foldM f 0 output >> return output
    where
      print rem (Stdout s) =
          let (dots, rem') = quotRem (rem + length s) in
          hPutStr stderr (replicate dots '.')
          return rem'
      print rem (Stderr s) = print rem (Stdout s)
-}