{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE CPP #-}
-- | 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 = 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 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 = 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 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 :: 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

-- |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 :: 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 -- 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 <- 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
       -- 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.
       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) =
          -- Do NOT preserve ownership, files must be owned by root.
          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   -- 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 -> 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))

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