    {-# 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 = 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 :: forall (m :: * -> *) a.
    (MonadIO m, MonadMask m) =>
    FilePath -> m a -> m a
    fchroot FilePath
    path m a
    action =
        do origWd <- IO FilePath -> m FilePath
    forall a. IO a -> m a
    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
    #if MIN_VERSION_unix(2,8,0)
           rootFd <- liftIO $ openFd "/" ReadOnly defaultFileFlags
    #else
           rootFd <- liftIO $ openFd "/" ReadOnly Nothing defaultFileFlags
    #endif
           liftIO $ chroot path
           liftIO $ changeWorkingDirectory "/"
           action `finally` (liftIO $ breakFree origWd 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))
           sockPath <- IO (Maybe FilePath) -> m (Maybe FilePath)
    forall a. IO a -> m a
    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"
           home <- liftIO $ getEnv "HOME"
           liftIO $ copySSH 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.
           withSock sockPath . fchroot rootPath $ (action >>= force)
        where
          copySSH :: Maybe FilePath -> IO ()
    copySSH Maybe FilePath
    Nothing = () -> IO ()
    forall a. a -> IO a
    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 a b. IO a -> IO b -> IO b
    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 :: 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 =
              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 :: forall (m :: * -> *) a.
    (MonadIO m, MonadMask m) =>
    FilePath -> FilePath -> m a -> m a
    withMountBind FilePath
    toMount FilePath
    mountPoint m a
    action =
              (do IO () -> m ()
    forall a. IO a -> m a
    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 a. IO a -> m a
    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.
    (HasCallStack, MonadMask m) =>
    m a -> m b -> m a
    `finally` (IO () -> m ()
    forall a. IO a -> m a
    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 (code, out, err) <- FilePath
    -> [FilePath] -> FilePath -> IO (ExitCode, FilePath, FilePath)
    readProcessWithExitCode FilePath
    cmd [FilePath]
    args FilePath
    ""
                 case code of
                   ExitCode
    ExitSuccess -> () -> IO ()
    forall a. a -> IO a
    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)
    -}