ghcup-hs/lib/GHCup/File.hs
2020-02-22 19:21:10 +01:00

221 lines
7.8 KiB
Haskell

{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
module GHCup.File where
import Data.ByteString
import qualified Data.ByteString.Lazy as L
import Data.Char
import Data.Maybe
import Data.String.QQ
import HPath
import HPath.IO
import Optics
import Streamly.External.ByteString
import Streamly.External.ByteString.Lazy
import Streamly
import System.Posix.FilePath hiding ( (</>) )
import Data.Foldable
import Control.Monad
import Control.Exception.Safe
import Data.Functor
import System.Posix.Files.ByteString
import System.Posix.Foreign ( oExcl )
import System.Posix.Env.ByteString
import System.IO
import qualified System.Posix.FilePath as FP
import "unix" System.Posix.IO.ByteString
hiding ( openFd )
import qualified System.Posix.Process.ByteString
as SPPB
import System.Posix.Directory.ByteString
import System.Posix.Process ( ProcessStatus(..) )
import System.Posix.Temp.ByteString
import System.Posix.Types
import qualified System.Posix.User as PU
import qualified Streamly.Internal.Memory.ArrayStream
as AS
import qualified Streamly.FileSystem.Handle as FH
import qualified Streamly.Internal.Data.Unfold as SU
import qualified Streamly.Prelude as S
import System.Exit
import qualified Streamly.Data.Fold as FL
import Data.ByteString.Builder
import Foreign.C.Error
import GHCup.Prelude
import Control.Concurrent.Async
import Control.Concurrent
import System.Posix.FD as FD
import qualified Data.ByteString.UTF8 as UTF8
import Data.ByteString.Unsafe ( unsafeUseAsCStringLen )
import GHC.IO.Encoding ( getLocaleEncoding )
import GHC.Foreign ( peekCStringLen )
data ProcessError = NonZeroExit Int ByteString [ByteString]
| PTerminated ByteString [ByteString]
| PStopped ByteString [ByteString]
| NoSuchPid ByteString [ByteString]
deriving Show
data CapturedProcess = CapturedProcess {
_exitCode :: ExitCode
, _stdOut :: ByteString
, _stdErr :: ByteString
} deriving (Eq, Show)
makeLenses ''CapturedProcess
readFd :: Fd -> IO L.ByteString
readFd fd = do
handle' <- fdToHandle fd
fromChunksIO $ (S.unfold (SU.finallyIO hClose FH.readChunks) handle')
-- | Read the lines of a file into a stream. The stream holds
-- a file handle as a resource and will close it once the stream
-- terminates (either through exception or because it's drained).
readFileLines :: Path b -> IO (SerialT IO ByteString)
readFileLines p = do
stream <- readFileStream p
pure
. (fmap fromArray)
. AS.splitOn (fromIntegral $ ord '\n')
. (fmap toArray)
$ stream
-- | Find the given executable by searching all *absolute* PATH components.
-- Relative paths in PATH are ignored.
--
-- This shouldn't throw IO exceptions, unless getting the environment variable
-- PATH does.
findExecutable :: Path Rel -> IO (Maybe (Path Abs))
findExecutable ex = do
sPaths <- fmap catMaybes . (fmap . fmap) parseAbs $ getSearchPath
-- We don't want exceptions to mess up our result. If we can't
-- figure out if a file exists, then treat it as a negative result.
asum $ fmap (handleIO (\_ -> pure Nothing)) $ fmap
-- asum for short-circuiting behavior
(\s -> (isExecutable (s </> ex) >>= guard) $> (Just (s </> ex)))
sPaths
-- | Execute the given command and collect the stdout, stderr and the exit code.
-- The command is run in a subprocess.
executeOut :: Path Rel -- ^ command as filename, e.g. 'ls'
-> [ByteString] -- ^ arguments to the command
-> Maybe (Path Abs) -- ^ chdir to this path
-> IO (Maybe CapturedProcess)
executeOut path args chdir = withRelPath path $ \fp -> captureOutStreams $ do
maybe (pure ()) (changeWorkingDirectory . toFilePath) chdir
SPPB.executeFile fp True args Nothing
-- | Capture the stdout and stderr of the given action, which
-- is run in a subprocess. Stdin is closed. You might want to
-- 'race' this to make sure it terminates.
captureOutStreams :: IO a
-- ^ the action to execute in a subprocess
-> IO (Maybe CapturedProcess) -- TODO: shouldn't be maybe
captureOutStreams action =
actionWithPipes $ \(parentStdoutRead, childStdoutWrite) ->
actionWithPipes $ \(parentStderrRead, childStderrWrite) -> do
pid <- SPPB.forkProcess $ do
-- dup stdout
void $ dupTo childStdoutWrite stdOutput
closeFd childStdoutWrite
closeFd parentStdoutRead
-- dup stderr
void $ dupTo childStderrWrite stdError
closeFd childStderrWrite
closeFd parentStderrRead
-- execute the action
void $ action
-- close everything we don't need
closeFd childStdoutWrite
closeFd childStderrWrite
SPPB.getProcessStatus True True pid >>= \case
-- readFd will take care of closing the fd
Just (SPPB.Exited es) -> do
stdout' <- L.toStrict <$> readFd parentStdoutRead
stderr' <- L.toStrict <$> readFd parentStderrRead
pure $ Just $ CapturedProcess { _exitCode = es
, _stdOut = stdout'
, _stdErr = stderr'
}
_ -> do
closeFd parentStdoutRead
closeFd parentStderrRead
pure $ Nothing
where
actionWithPipes a =
createPipe >>= \(p1, p2) -> (flip finally) (cleanup [p1, p2]) $ a (p1, p2)
cleanup fds = for_ fds $ \fd -> handleIO (\_ -> pure ()) $ closeFd fd
-- | Create a new regular file in write-only mode. The file must not exist.
createRegularFileFd :: FileMode -> Path b -> IO Fd
createRegularFileFd fm dest =
FD.openFd (toFilePath dest) WriteOnly [oExcl] (Just fm)
exec :: ByteString -- ^ thing to execute
-> [ByteString] -- ^ args for the thing
-> Bool -- ^ whether to search PATH for the thing
-> Maybe (Path Abs) -- ^ optionally chdir into this
-> IO (Either ProcessError ())
exec exe args spath chdir = do
pid <- SPPB.forkProcess $ do
maybe (pure ()) (changeWorkingDirectory . toFilePath) chdir
SPPB.executeFile exe spath args Nothing
fmap (toProcessError exe args) $ SPPB.getProcessStatus True True pid
toProcessError :: ByteString
-> [ByteString]
-> Maybe ProcessStatus
-> Either ProcessError ()
toProcessError exe args mps = case mps of
Just (SPPB.Exited (ExitFailure i)) -> Left $ NonZeroExit i exe args
Just (SPPB.Exited ExitSuccess ) -> Right ()
Just (Terminated _ _ ) -> Left $ PTerminated exe args
Just (Stopped _ ) -> Left $ PStopped exe args
Nothing -> Left $ NoSuchPid exe args
mkGhcupTmpDir :: IO (Path Abs)
mkGhcupTmpDir = do
tmpdir <- getEnvDefault [s|TMPDIR|] [s|/tmp|]
tmp <- mkdtemp $ (tmpdir FP.</> [s|ghcup-|])
parseAbs tmp
getHomeDirectory :: IO (Path Abs)
getHomeDirectory = do
e <- getEnv [s|HOME|]
case e of
Just fp -> parseAbs fp
Nothing -> do
h <- PU.homeDirectory <$> (PU.getEffectiveUserID >>= PU.getUserEntryForID)
parseAbs $ UTF8.fromString h -- this is a guess
-- | Convert the String to a ByteString with the current
-- system encoding.
unsafePathToString :: Path b -> IO FilePath
unsafePathToString (Path p) = do
enc <- getLocaleEncoding
unsafeUseAsCStringLen p (peekCStringLen enc)