ghcup-hs/lib/GHCup/Utils/File.hs

247 lines
8.7 KiB
Haskell
Raw Normal View History

2020-02-22 18:21:10 +00:00
{-# LANGUAGE QuasiQuotes #-}
2020-01-17 22:29:16 +00:00
{-# LANGUAGE TemplateHaskell #-}
2020-03-03 00:59:19 +00:00
module GHCup.Utils.File where
2020-03-05 17:02:59 +00:00
import GHCup.Utils.Dirs
2020-03-03 00:59:19 +00:00
import GHCup.Utils.Prelude
2020-01-14 21:55:34 +00:00
2020-03-01 00:05:02 +00:00
import Control.Exception.Safe
import Control.Monad
2020-01-16 22:27:38 +00:00
import Data.ByteString
2020-03-01 00:05:02 +00:00
import Data.ByteString.Unsafe ( unsafeUseAsCStringLen )
2020-01-14 21:55:34 +00:00
import Data.Char
2020-03-01 00:05:02 +00:00
import Data.Foldable
import Data.Functor
2020-01-14 21:55:34 +00:00
import Data.Maybe
2020-03-01 00:05:02 +00:00
import GHC.Foreign ( peekCStringLen )
import GHC.IO.Encoding ( getLocaleEncoding )
2020-03-03 00:59:19 +00:00
import GHC.IO.Exception
2020-01-14 21:55:34 +00:00
import HPath
import HPath.IO
2020-01-17 22:29:16 +00:00
import Optics
2020-03-01 00:05:02 +00:00
import Streamly
2020-02-18 08:40:01 +00:00
import Streamly.External.ByteString
import Streamly.External.ByteString.Lazy
2020-03-01 00:05:02 +00:00
import System.IO
import System.Posix.Directory.ByteString
import System.Posix.FD as FD
2020-01-14 21:55:34 +00:00
import System.Posix.FilePath hiding ( (</>) )
2020-02-16 21:06:07 +00:00
import System.Posix.Foreign ( oExcl )
2020-01-17 22:29:16 +00:00
import "unix" System.Posix.IO.ByteString
2020-01-16 22:27:38 +00:00
hiding ( openFd )
2020-02-19 12:30:18 +00:00
import System.Posix.Process ( ProcessStatus(..) )
2020-01-14 21:55:34 +00:00
import System.Posix.Types
2020-03-01 00:05:02 +00:00
import qualified System.Posix.Process.ByteString
as SPPB
2020-03-03 00:59:19 +00:00
import Streamly.External.Posix.DirStream
2020-01-14 21:55:34 +00:00
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
2020-03-01 00:05:02 +00:00
import qualified Data.ByteString.Lazy as L
2020-01-17 22:29:16 +00:00
2020-02-22 18:21:10 +00:00
data ProcessError = NonZeroExit Int ByteString [ByteString]
| PTerminated ByteString [ByteString]
| PStopped ByteString [ByteString]
| NoSuchPid ByteString [ByteString]
2020-02-19 12:30:18 +00:00
deriving Show
2020-02-29 23:07:39 +00:00
data CapturedProcess = CapturedProcess
{ _exitCode :: ExitCode
2020-02-19 12:30:18 +00:00
, _stdOut :: ByteString
, _stdErr :: ByteString
2020-02-29 23:07:39 +00:00
}
deriving (Eq, Show)
2020-01-17 22:29:16 +00:00
makeLenses ''CapturedProcess
2020-01-14 21:55:34 +00:00
readFd :: Fd -> IO L.ByteString
readFd fd = do
handle' <- fdToHandle fd
2020-02-18 08:40:01 +00:00
fromChunksIO $ (S.unfold (SU.finallyIO hClose FH.readChunks) handle')
2020-01-14 21:55:34 +00:00
-- | 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
2020-01-16 22:27:38 +00:00
stream <- readFileStream p
2020-01-14 21:55:34 +00:00
pure
2020-02-18 08:40:01 +00:00
. (fmap fromArray)
2020-01-14 21:55:34 +00:00
. AS.splitOn (fromIntegral $ ord '\n')
2020-02-18 08:40:01 +00:00
. (fmap toArray)
2020-01-14 21:55:34 +00:00
$ 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.
2020-01-24 22:43:11 +00:00
findExecutable :: Path Rel -> IO (Maybe (Path Abs))
2020-01-14 21:55:34 +00:00
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.
2020-01-16 22:27:38 +00:00
asum $ fmap (handleIO (\_ -> pure Nothing)) $ fmap
2020-01-14 21:55:34 +00:00
-- asum for short-circuiting behavior
2020-02-29 23:07:39 +00:00
(\s' -> (isExecutable (s' </> ex) >>= guard) $> (Just (s' </> ex)))
2020-01-14 21:55:34 +00:00
sPaths
2020-01-17 22:29:16 +00:00
-- | Execute the given command and collect the stdout, stderr and the exit code.
-- The command is run in a subprocess.
2020-02-24 13:56:13 +00:00
executeOut :: Path b -- ^ command as filename, e.g. 'ls'
2020-02-18 08:40:01 +00:00
-> [ByteString] -- ^ arguments to the command
-> Maybe (Path Abs) -- ^ chdir to this path
2020-02-24 13:56:13 +00:00
-> IO CapturedProcess
2020-02-29 23:07:39 +00:00
executeOut path args chdir = captureOutStreams $ do
maybe (pure ()) (changeWorkingDirectory . toFilePath) chdir
SPPB.executeFile (toFilePath path) True args Nothing
2020-01-17 22:29:16 +00:00
2020-03-05 17:02:59 +00:00
execLogged :: ByteString -- ^ thing to execute
-> Bool -- ^ whether to search PATH for the thing
-> [ByteString] -- ^ args for the thing
-> Path Rel -- ^ log filename
-> Maybe (Path Abs) -- ^ optionally chdir into this
-> Maybe [(ByteString, ByteString)] -- ^ optional environment
-> IO (Either ProcessError ())
execLogged exe spath args lfile chdir env = do
ldir <- ghcupLogsDir
let logfile = ldir </> lfile
bracket (createFile (toFilePath logfile) newFilePerms) closeFd action
where
action fd = do
pid <- SPPB.forkProcess $ do
-- dup stdout
void $ dupTo fd stdOutput
-- dup stderr
void $ dupTo fd stdError
-- execute the action
maybe (pure ()) (changeWorkingDirectory . toFilePath) chdir
SPPB.executeFile exe spath args env
SPPB.getProcessStatus True True pid >>= \case
2020-03-08 17:30:08 +00:00
i@(Just (SPPB.Exited _)) -> pure $ toProcessError exe args i
2020-03-05 17:02:59 +00:00
i -> pure $ toProcessError exe args i
2020-01-17 22:29:16 +00:00
-- | 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
2020-02-24 13:56:13 +00:00
-> IO CapturedProcess
2020-01-17 22:29:16 +00:00
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
2020-02-19 12:30:18 +00:00
stdout' <- L.toStrict <$> readFd parentStdoutRead
stderr' <- L.toStrict <$> readFd parentStderrRead
2020-02-24 13:56:13 +00:00
pure $ CapturedProcess { _exitCode = es
2020-02-29 23:07:39 +00:00
, _stdOut = stdout'
, _stdErr = stderr'
}
2020-02-24 13:56:13 +00:00
_ -> throwIO $ userError $ ("No such PID " ++ show pid)
2020-01-17 22:29:16 +00:00
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
2020-02-16 21:06:07 +00:00
createRegularFileFd fm dest =
FD.openFd (toFilePath dest) WriteOnly [oExcl] (Just fm)
2020-02-19 12:30:18 +00:00
2020-03-03 00:59:19 +00:00
-- | Thin wrapper around `executeFile`.
exec :: ByteString -- ^ thing to execute
2020-02-19 19:54:23 +00:00
-> Bool -- ^ whether to search PATH for the thing
2020-03-03 00:59:19 +00:00
-> [ByteString] -- ^ args for the thing
2020-02-19 19:54:23 +00:00
-> Maybe (Path Abs) -- ^ optionally chdir into this
2020-03-03 00:59:19 +00:00
-> Maybe [(ByteString, ByteString)] -- ^ optional environment
2020-02-19 19:54:23 +00:00
-> IO (Either ProcessError ())
2020-03-03 00:59:19 +00:00
exec exe spath args chdir env = do
2020-02-19 12:30:18 +00:00
pid <- SPPB.forkProcess $ do
maybe (pure ()) (changeWorkingDirectory . toFilePath) chdir
2020-03-03 00:59:19 +00:00
SPPB.executeFile exe spath args env
2020-02-19 12:30:18 +00:00
2020-02-22 18:21:10 +00:00
fmap (toProcessError exe args) $ SPPB.getProcessStatus True True pid
2020-02-19 12:30:18 +00:00
2020-02-22 18:21:10 +00:00
toProcessError :: ByteString
-> [ByteString]
-> Maybe ProcessStatus
-> Either ProcessError ()
toProcessError exe args mps = case mps of
Just (SPPB.Exited (ExitFailure i)) -> Left $ NonZeroExit i exe args
2020-02-19 12:30:18 +00:00
Just (SPPB.Exited ExitSuccess ) -> Right ()
2020-02-22 18:21:10 +00:00
Just (Terminated _ _ ) -> Left $ PTerminated exe args
Just (Stopped _ ) -> Left $ PStopped exe args
Nothing -> Left $ NoSuchPid exe args
-- | Convert the String to a ByteString with the current
-- system encoding.
unsafePathToString :: Path b -> IO FilePath
2020-03-08 22:54:41 +00:00
unsafePathToString p = do
2020-02-22 18:21:10 +00:00
enc <- getLocaleEncoding
2020-03-08 22:54:41 +00:00
unsafeUseAsCStringLen (toFilePath p) (peekCStringLen enc)
2020-03-03 00:59:19 +00:00
-- | Search for a file in the search paths.
--
-- Catches `PermissionDenied` and `NoSuchThing` and returns `Nothing`.
searchPath :: [Path Abs] -> Path Rel -> IO (Maybe (Path Abs))
searchPath paths needle = go paths
where
go [] = pure Nothing
go (x : xs) =
hideErrorDefM PermissionDenied (go xs)
$ hideErrorDefM NoSuchThing (go xs)
$ do
dirStream <- openDirStream (toFilePath x)
S.findM (\(_, p) -> isMatch x p) (dirContentsStream dirStream)
>>= \case
Just _ -> pure $ Just (x </> needle)
Nothing -> go xs
isMatch basedir p = do
if p == toFilePath needle
then isExecutable (basedir </> needle)
else pure False