553 lines
19 KiB
Haskell
553 lines
19 KiB
Haskell
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE FlexibleContexts #-}
|
|
{-# LANGUAGE DataKinds #-}
|
|
{-# LANGUAGE MultiWayIf #-}
|
|
|
|
{-|
|
|
Module : GHCup.Utils.File.Posix
|
|
Description : File and unix APIs
|
|
Copyright : (c) Julian Ospald, 2020
|
|
License : LGPL-3.0
|
|
Maintainer : hasufell@hasufell.de
|
|
Stability : experimental
|
|
Portability : POSIX
|
|
|
|
This module handles file and executable handling.
|
|
Some of these functions use sophisticated logging.
|
|
-}
|
|
module GHCup.Utils.File.Posix where
|
|
|
|
import GHCup.Utils.File.Common
|
|
import GHCup.Utils.Prelude
|
|
import GHCup.Utils.Logger
|
|
import GHCup.Types
|
|
import GHCup.Types.Optics
|
|
|
|
import Control.Concurrent
|
|
import Control.Concurrent.Async
|
|
import Control.Exception ( evaluate )
|
|
import Control.Exception.Safe
|
|
import Control.Monad
|
|
import Control.Monad.Reader
|
|
import Control.Monad.Trans.State.Strict
|
|
import Data.ByteString ( ByteString )
|
|
import Data.Foldable
|
|
import Data.IORef
|
|
import Data.Sequence ( Seq, (|>) )
|
|
import Data.List
|
|
import Data.Word8
|
|
import Foreign.C.String
|
|
import Foreign.C.Types
|
|
import GHC.IO.Exception
|
|
import System.IO ( stderr, hClose, hSetBinaryMode )
|
|
import System.IO.Error
|
|
import System.FilePath
|
|
import System.Directory hiding ( copyFile )
|
|
import System.Posix.Directory
|
|
import System.Posix.Error ( throwErrnoPathIfMinus1Retry )
|
|
import System.Posix.Internals ( withFilePath )
|
|
import System.Posix.Files
|
|
import System.Posix.IO
|
|
import System.Posix.Process ( ProcessStatus(..) )
|
|
import System.Posix.Types
|
|
|
|
|
|
import qualified Control.Exception as EX
|
|
import qualified Data.Sequence as Sq
|
|
import qualified Data.Text as T
|
|
import qualified Data.Text.Encoding as E
|
|
import qualified System.Posix.Files as PF
|
|
import qualified System.Posix.Process as SPP
|
|
import qualified System.Posix.IO as SPI
|
|
import qualified System.Console.Terminal.Size as TP
|
|
import qualified System.Posix as Posix
|
|
import qualified Data.ByteString as BS
|
|
import qualified Data.ByteString.Lazy as BL
|
|
import qualified "unix-bytestring" System.Posix.IO.ByteString
|
|
as SPIB
|
|
import qualified Streamly.FileSystem.Handle as FH
|
|
import qualified Streamly.Internal.FileSystem.Handle
|
|
as IFH
|
|
import qualified Streamly.Prelude as S
|
|
import qualified GHCup.Utils.File.Posix.Foreign as FD
|
|
|
|
|
|
|
|
-- | Execute the given command and collect the stdout, stderr and the exit code.
|
|
-- The command is run in a subprocess.
|
|
executeOut :: MonadIO m
|
|
=> FilePath -- ^ command as filename, e.g. 'ls'
|
|
-> [String] -- ^ arguments to the command
|
|
-> Maybe FilePath -- ^ chdir to this path
|
|
-> m CapturedProcess
|
|
executeOut path args chdir = liftIO $ captureOutStreams $ do
|
|
maybe (pure ()) changeWorkingDirectory chdir
|
|
SPP.executeFile path True args Nothing
|
|
|
|
|
|
execLogged :: ( MonadReader env m
|
|
, HasSettings env
|
|
, HasLog env
|
|
, HasDirs env
|
|
, MonadIO m
|
|
, MonadThrow m)
|
|
=> FilePath -- ^ thing to execute
|
|
-> [String] -- ^ args for the thing
|
|
-> Maybe FilePath -- ^ optionally chdir into this
|
|
-> FilePath -- ^ log filename (opened in append mode)
|
|
-> Maybe [(String, String)] -- ^ optional environment
|
|
-> m (Either ProcessError ())
|
|
execLogged exe args chdir lfile env = do
|
|
Settings {..} <- getSettings
|
|
Dirs {..} <- getDirs
|
|
logDebug $ T.pack $ "Running " <> exe <> " with arguments " <> show args
|
|
let logfile = logsDir </> lfile <> ".log"
|
|
liftIO $ bracket (openFd logfile WriteOnly (Just newFilePerms) defaultFileFlags{ append = True })
|
|
closeFd
|
|
(action verbose noColor)
|
|
where
|
|
action verbose no_color fd = do
|
|
actionWithPipes $ \(stdoutRead, stdoutWrite) -> do
|
|
-- start the thread that logs to stdout
|
|
pState <- newEmptyMVar
|
|
done <- newEmptyMVar
|
|
void
|
|
$ forkIO
|
|
$ EX.handle (\(_ :: IOException) -> pure ())
|
|
$ EX.finally
|
|
(if verbose
|
|
then tee fd stdoutRead
|
|
else printToRegion fd stdoutRead 6 pState no_color
|
|
)
|
|
(putMVar done ())
|
|
|
|
-- fork the subprocess
|
|
pid <- SPP.forkProcess $ do
|
|
void $ dupTo stdoutWrite stdOutput
|
|
void $ dupTo stdoutWrite stdError
|
|
closeFd stdoutRead
|
|
closeFd stdoutWrite
|
|
|
|
-- execute the action
|
|
maybe (pure ()) changeWorkingDirectory chdir
|
|
void $ SPP.executeFile exe (not ("./" `isPrefixOf` exe)) args env
|
|
|
|
closeFd stdoutWrite
|
|
|
|
-- wait for the subprocess to finish
|
|
e <- toProcessError exe args <$!> SPP.getProcessStatus True True pid
|
|
putMVar pState (either (const False) (const True) e)
|
|
|
|
void $ race (takeMVar done) (threadDelay (1000000 * 3))
|
|
closeFd stdoutRead
|
|
|
|
pure e
|
|
|
|
tee :: Fd -> Fd -> IO ()
|
|
tee fileFd = readTilEOF lineAction
|
|
|
|
where
|
|
lineAction :: ByteString -> IO ()
|
|
lineAction bs' = do
|
|
void $ SPIB.fdWrite fileFd (bs' <> "\n")
|
|
void $ SPIB.fdWrite stdOutput (bs' <> "\n")
|
|
|
|
-- Reads fdIn and logs the output in a continous scrolling area
|
|
-- of 'size' terminal lines. Also writes to a log file.
|
|
printToRegion :: Fd -> Fd -> Int -> MVar Bool -> Bool -> IO ()
|
|
printToRegion fileFd fdIn size pState no_color = do
|
|
-- init region
|
|
forM_ [1..size] $ \_ -> BS.hPut stderr "\n"
|
|
|
|
void $ flip runStateT mempty
|
|
$ do
|
|
handle
|
|
(\(ex :: SomeException) -> do
|
|
ps <- liftIO $ takeMVar pState
|
|
when ps (liftIO $ BS.hPut stderr (pos1 <> moveLineUp size <> clearScreen))
|
|
throw ex
|
|
) $ readTilEOF lineAction fdIn
|
|
|
|
where
|
|
clearScreen :: ByteString
|
|
clearScreen = "\x1b[0J"
|
|
clearLine :: ByteString
|
|
clearLine = "\x1b[2K"
|
|
moveLineUp :: Int -> ByteString
|
|
moveLineUp n = "\x1b[" <> E.encodeUtf8 (T.pack (show n)) <> "A"
|
|
moveLineDown :: Int -> ByteString
|
|
moveLineDown n = "\x1b[" <> E.encodeUtf8 (T.pack (show n)) <> "B"
|
|
pos1 :: ByteString
|
|
pos1 = "\r"
|
|
overwriteNthLine :: Int -> ByteString -> ByteString
|
|
overwriteNthLine n str = pos1 <> moveLineUp n <> clearLine <> str <> moveLineDown n <> pos1
|
|
|
|
blue :: ByteString -> ByteString
|
|
blue bs
|
|
| no_color = bs
|
|
| otherwise = "\x1b[0;34m" <> bs <> "\x1b[0m"
|
|
|
|
-- action to perform line by line
|
|
lineAction :: (MonadMask m, MonadIO m)
|
|
=> ByteString
|
|
-> StateT (Seq ByteString) m ()
|
|
lineAction = \bs' -> do
|
|
void $ liftIO $ SPIB.fdWrite fileFd (bs' <> "\n")
|
|
modify (swapRegs bs')
|
|
liftIO TP.size >>= \case
|
|
Nothing -> pure ()
|
|
Just (TP.Window _ w) -> do
|
|
regs <- get
|
|
liftIO $ forM_ (Sq.zip regs (Sq.fromList [0..(Sq.length regs - 1)])) $ \(bs, i) -> do
|
|
BS.hPut stderr
|
|
. overwriteNthLine (size - i)
|
|
. trim w
|
|
. blue
|
|
. (\b -> "[ " <> E.encodeUtf8 (T.pack lfile) <> " ] " <> b)
|
|
$ bs
|
|
|
|
swapRegs :: a -> Seq a -> Seq a
|
|
swapRegs bs = \regs -> if
|
|
| Sq.length regs < size -> regs |> bs
|
|
| otherwise -> Sq.drop 1 regs |> bs
|
|
|
|
-- trim output line to terminal width
|
|
trim :: Int -> ByteString -> ByteString
|
|
trim w = \bs -> if
|
|
| BS.length bs > w && w > 5 -> BS.take (w - 4) bs <> "..."
|
|
| otherwise -> bs
|
|
|
|
-- Consecutively read from Fd in 512 chunks until we hit
|
|
-- newline or EOF.
|
|
readLine :: MonadIO m
|
|
=> Fd -- ^ input file descriptor
|
|
-> ByteString -- ^ rest buffer (read across newline)
|
|
-> m (ByteString, ByteString, Bool) -- ^ (full line, rest, eof)
|
|
readLine fd = go
|
|
where
|
|
go inBs = do
|
|
-- if buffer is not empty, process it first
|
|
mbs <- if BS.length inBs == 0
|
|
-- otherwise attempt read
|
|
then liftIO
|
|
$ handleIO (\e -> if isEOFError e then pure Nothing else ioError e)
|
|
$ fmap Just
|
|
$ SPIB.fdRead fd 512
|
|
else pure $ Just inBs
|
|
case mbs of
|
|
Nothing -> pure ("", "", True)
|
|
Just bs -> do
|
|
-- split on newline
|
|
let (line, rest) = BS.span (/= _lf) bs
|
|
if
|
|
| BS.length rest /= 0 -> pure (line, BS.tail rest, False)
|
|
-- if rest is empty, then there was no newline, process further
|
|
| otherwise -> (\(l, r, b) -> (line <> l, r, b)) <$!> go mempty
|
|
|
|
readTilEOF :: MonadIO m => (ByteString -> m a) -> Fd -> m ()
|
|
readTilEOF ~action' fd' = go mempty
|
|
where
|
|
go bs' = do
|
|
(bs, rest, eof) <- readLine fd' bs'
|
|
if eof
|
|
then liftIO $ ioError (mkIOError eofErrorType "" Nothing Nothing)
|
|
else void (action' bs) >> go rest
|
|
|
|
|
|
-- | 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 CapturedProcess
|
|
captureOutStreams action = do
|
|
actionWithPipes $ \(parentStdoutRead, childStdoutWrite) ->
|
|
actionWithPipes $ \(parentStderrRead, childStderrWrite) -> do
|
|
pid <- SPP.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
|
|
a <- action
|
|
void $ evaluate a
|
|
|
|
-- close everything we don't need
|
|
closeFd childStdoutWrite
|
|
closeFd childStderrWrite
|
|
|
|
-- start thread that writes the output
|
|
refOut <- newIORef BL.empty
|
|
refErr <- newIORef BL.empty
|
|
done <- newEmptyMVar
|
|
_ <-
|
|
forkIO
|
|
$ EX.handle (\(_ :: IOException) -> pure ())
|
|
$ flip EX.finally (putMVar done ())
|
|
$ writeStds parentStdoutRead parentStderrRead refOut refErr
|
|
|
|
status <- SPP.getProcessStatus True True pid
|
|
void $ race (takeMVar done) (threadDelay (1000000 * 3))
|
|
|
|
case status of
|
|
-- readFd will take care of closing the fd
|
|
Just (SPP.Exited es) -> do
|
|
stdout' <- readIORef refOut
|
|
stderr' <- readIORef refErr
|
|
pure $ CapturedProcess { _exitCode = es
|
|
, _stdOut = stdout'
|
|
, _stdErr = stderr'
|
|
}
|
|
|
|
_ -> throwIO $ userError ("No such PID " ++ show pid)
|
|
|
|
where
|
|
writeStds :: Fd -> Fd -> IORef BL.ByteString -> IORef BL.ByteString -> IO ()
|
|
writeStds pout perr rout rerr = do
|
|
doneOut <- newEmptyMVar
|
|
void
|
|
$ forkIO
|
|
$ hideError eofErrorType
|
|
$ flip EX.finally (putMVar doneOut ())
|
|
$ readTilEOF (\x -> modifyIORef' rout (<> BL.fromStrict x)) pout
|
|
doneErr <- newEmptyMVar
|
|
void
|
|
$ forkIO
|
|
$ hideError eofErrorType
|
|
$ flip EX.finally (putMVar doneErr ())
|
|
$ readTilEOF (\x -> modifyIORef' rerr (<> BL.fromStrict x)) perr
|
|
takeMVar doneOut
|
|
takeMVar doneErr
|
|
|
|
readTilEOF ~action' fd' = do
|
|
bs <- SPIB.fdRead fd' 512
|
|
void $ action' bs
|
|
readTilEOF action' fd'
|
|
|
|
|
|
actionWithPipes :: ((Fd, Fd) -> IO b) -> IO b
|
|
actionWithPipes a =
|
|
createPipe >>= \(p1, p2) -> flip finally (cleanup [p1, p2]) $ a (p1, p2)
|
|
|
|
cleanup :: [Fd] -> IO ()
|
|
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 -> FilePath -> IO Fd
|
|
createRegularFileFd fm dest =
|
|
openFd dest WriteOnly (Just fm) defaultFileFlags{ exclusive = True }
|
|
|
|
|
|
-- | Thin wrapper around `executeFile`.
|
|
exec :: MonadIO m
|
|
=> String -- ^ thing to execute
|
|
-> [String] -- ^ args for the thing
|
|
-> Maybe FilePath -- ^ optionally chdir into this
|
|
-> Maybe [(String, String)] -- ^ optional environment
|
|
-> m (Either ProcessError ())
|
|
exec exe args chdir env = liftIO $ do
|
|
pid <- SPP.forkProcess $ do
|
|
maybe (pure ()) changeWorkingDirectory chdir
|
|
SPP.executeFile exe (not ("./" `isPrefixOf` exe)) args env
|
|
|
|
fmap (toProcessError exe args) $ SPP.getProcessStatus True True pid
|
|
|
|
|
|
toProcessError :: FilePath
|
|
-> [String]
|
|
-> Maybe ProcessStatus
|
|
-> Either ProcessError ()
|
|
toProcessError exe args mps = case mps of
|
|
Just (SPP.Exited (ExitFailure xi)) -> Left $ NonZeroExit xi exe args
|
|
Just (SPP.Exited ExitSuccess ) -> Right ()
|
|
Just (Terminated _ _ ) -> Left $ PTerminated exe args
|
|
Just (Stopped _ ) -> Left $ PStopped exe args
|
|
Nothing -> Left $ NoSuchPid exe args
|
|
|
|
|
|
|
|
chmod_755 :: (MonadReader env m, HasLog env, MonadIO m) => FilePath -> m ()
|
|
chmod_755 fp = do
|
|
let exe_mode =
|
|
nullFileMode
|
|
`unionFileModes` ownerExecuteMode
|
|
`unionFileModes` ownerReadMode
|
|
`unionFileModes` ownerWriteMode
|
|
`unionFileModes` groupExecuteMode
|
|
`unionFileModes` groupReadMode
|
|
`unionFileModes` otherExecuteMode
|
|
`unionFileModes` otherReadMode
|
|
logDebug ("chmod 755 " <> T.pack fp)
|
|
liftIO $ setFileMode fp exe_mode
|
|
|
|
|
|
-- |Default permissions for a new file.
|
|
newFilePerms :: FileMode
|
|
newFilePerms =
|
|
ownerWriteMode
|
|
`unionFileModes` ownerReadMode
|
|
`unionFileModes` groupWriteMode
|
|
`unionFileModes` groupReadMode
|
|
`unionFileModes` otherWriteMode
|
|
`unionFileModes` otherReadMode
|
|
|
|
|
|
-- | Checks whether the binary is a broken link.
|
|
isBrokenSymlink :: FilePath -> IO Bool
|
|
isBrokenSymlink fp = do
|
|
try (pathIsSymbolicLink fp) >>= \case
|
|
Right True -> do
|
|
let symDir = takeDirectory fp
|
|
tfp <- getSymbolicLinkTarget fp
|
|
not <$> doesPathExist
|
|
-- this drops 'symDir' if 'tfp' is absolute
|
|
(symDir </> tfp)
|
|
Right b -> pure b
|
|
Left e | isDoesNotExistError e -> pure False
|
|
| otherwise -> throwIO e
|
|
|
|
copyFile :: FilePath -- ^ source file
|
|
-> FilePath -- ^ destination file
|
|
-> Bool -- ^ fail if file exists
|
|
-> IO ()
|
|
copyFile from to fail' = do
|
|
bracket
|
|
(openFdHandle from SPI.ReadOnly [FD.oNofollow] Nothing)
|
|
(hClose . snd)
|
|
$ \(fromFd, fH) -> do
|
|
sourceFileMode <- fileMode <$> getFdStatus fromFd
|
|
let dflags = [ FD.oNofollow
|
|
, if fail' then FD.oExcl else FD.oTrunc
|
|
]
|
|
bracket
|
|
(openFdHandle to SPI.WriteOnly dflags $ Just sourceFileMode)
|
|
(hClose . snd)
|
|
$ \(_, tH) -> do
|
|
hSetBinaryMode fH True
|
|
hSetBinaryMode tH True
|
|
streamlyCopy (fH, tH)
|
|
where
|
|
openFdHandle fp omode flags fM = do
|
|
fd <- openFd' fp omode flags fM
|
|
handle' <- SPI.fdToHandle fd
|
|
pure (fd, handle')
|
|
streamlyCopy (fH, tH) =
|
|
S.fold (FH.writeChunks tH) $ IFH.toChunksWithBufferOf (256 * 1024) fH
|
|
|
|
foreign import ccall unsafe "open"
|
|
c_open :: CString -> CInt -> Posix.CMode -> IO CInt
|
|
|
|
|
|
open_ :: CString
|
|
-> Posix.OpenMode
|
|
-> [FD.Flags]
|
|
-> Maybe Posix.FileMode
|
|
-> IO Posix.Fd
|
|
open_ str how optional_flags maybe_mode = do
|
|
fd <- c_open str all_flags mode_w
|
|
return (Posix.Fd fd)
|
|
where
|
|
all_flags = FD.unionFlags $ optional_flags ++ [open_mode] ++ creat
|
|
|
|
|
|
(creat, mode_w) = case maybe_mode of
|
|
Nothing -> ([],0)
|
|
Just x -> ([FD.oCreat], x)
|
|
|
|
open_mode = case how of
|
|
Posix.ReadOnly -> FD.oRdonly
|
|
Posix.WriteOnly -> FD.oWronly
|
|
Posix.ReadWrite -> FD.oRdwr
|
|
|
|
|
|
-- |Open and optionally create this file. See 'System.Posix.Files'
|
|
-- for information on how to use the 'FileMode' type.
|
|
--
|
|
-- Note that passing @Just x@ as the 4th argument triggers the
|
|
-- `oCreat` status flag, which must be set when you pass in `oExcl`
|
|
-- to the status flags. Also see the manpage for @open(2)@.
|
|
openFd' :: FilePath
|
|
-> Posix.OpenMode
|
|
-> [FD.Flags] -- ^ status flags of @open(2)@
|
|
-> Maybe Posix.FileMode -- ^ @Just x@ => creates the file with the given modes, Nothing => the file must exist.
|
|
-> IO Posix.Fd
|
|
openFd' name how optional_flags maybe_mode =
|
|
withFilePath name $ \str ->
|
|
throwErrnoPathIfMinus1Retry "openFd" name $
|
|
open_ str how optional_flags maybe_mode
|
|
|
|
|
|
-- |Deletes the given file. Raises `eISDIR`
|
|
-- if run on a directory. Does not follow symbolic links.
|
|
--
|
|
-- Throws:
|
|
--
|
|
-- - `InappropriateType` for wrong file type (directory)
|
|
-- - `NoSuchThing` if the file does not exist
|
|
-- - `PermissionDenied` if the directory cannot be read
|
|
--
|
|
-- Notes: calls `unlink`
|
|
deleteFile :: FilePath -> IO ()
|
|
deleteFile = removeLink
|
|
|
|
|
|
-- |Recreate a symlink.
|
|
--
|
|
-- In `Overwrite` copy mode only files and empty directories are deleted.
|
|
--
|
|
-- Safety/reliability concerns:
|
|
--
|
|
-- * `Overwrite` mode is inherently non-atomic
|
|
--
|
|
-- Throws:
|
|
--
|
|
-- - `InvalidArgument` if source file is wrong type (not a symlink)
|
|
-- - `PermissionDenied` if output directory cannot be written to
|
|
-- - `PermissionDenied` if source directory cannot be opened
|
|
-- - `SameFile` if source and destination are the same file
|
|
-- (`HPathIOException`)
|
|
--
|
|
--
|
|
-- Throws in `Strict` mode only:
|
|
--
|
|
-- - `AlreadyExists` if destination already exists
|
|
--
|
|
-- Throws in `Overwrite` mode only:
|
|
--
|
|
-- - `UnsatisfiedConstraints` if destination file is non-empty directory
|
|
--
|
|
-- Notes:
|
|
--
|
|
-- - calls `symlink`
|
|
recreateSymlink :: FilePath -- ^ the old symlink file
|
|
-> FilePath -- ^ destination file
|
|
-> Bool -- ^ fail if destination file exists
|
|
-> IO ()
|
|
recreateSymlink symsource newsym fail' = do
|
|
sympoint <- readSymbolicLink symsource
|
|
case fail' of
|
|
True -> pure ()
|
|
False ->
|
|
hideError doesNotExistErrorType $ deleteFile newsym
|
|
createSymbolicLink sympoint newsym
|
|
|
|
|
|
-- copys files, recreates symlinks, fails on all other types
|
|
install :: FilePath -> FilePath -> Bool -> IO ()
|
|
install from to fail' = do
|
|
fs <- PF.getSymbolicLinkStatus from
|
|
decide fs
|
|
where
|
|
decide fs | PF.isRegularFile fs = copyFile from to fail'
|
|
| PF.isSymbolicLink fs = recreateSymlink from to fail'
|
|
| otherwise = ioError $ mkIOError illegalOperationErrorType "install: not a regular file or symlink" Nothing (Just from)
|
|
|