ghcup-hs/lib/GHCup/File.hs

{-# LANGUAGE TemplateHaskell #-}

module GHCup.File where

import           Data.ByteString
import qualified Data.ByteString.Lazy          as L
import           Data.Char
import           Data.Maybe
import           HPath
import           HPath.IO
import           Optics
import           Streamly.ByteString
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.Directory.Foreign ( oExcl )
import           System.IO
import "unix"    System.Posix.IO.ByteString
                                         hiding ( openFd )
import qualified System.Posix.Process.ByteString
                                               as SPPB
import           System.Posix.Types

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


data CapturedProcess = CapturedProcess {
    _exitCode :: ExitCode
  , _stdOut   :: L.ByteString
  , _stdErr   :: L.ByteString
} deriving (Eq, Show)

makeLenses ''CapturedProcess


-- |Checks whether a file is executable. Follows symlinks.
--
-- Only eACCES, eROFS, eTXTBSY, ePERM are catched (and return False).
--
-- Throws:
--
--     - `NoSuchThing` if the file does not exist
--
-- Note: calls `access`
isExecutable :: Path b -> IO Bool
isExecutable p = fileAccess (toFilePath p) False False True


readFd :: Fd -> IO L.ByteString
readFd fd = do
  handle' <- fdToHandle fd
  let stream =
        (S.unfold (SU.finally hClose FH.readChunks) handle')
          >>= arrayToByteString
  toLazyByteString <$> S.fold FL.mconcat (fmap byteString stream)


-- | 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
    . (>>= arrayToByteString)
    . AS.splitOn (fromIntegral $ ord '\n')
    . (>>= byteStringToArray)
    $ 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 :: RelC r => Path r -> 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 Fn      -- ^ command as filename, e.g. 'ls'
           -> [ByteString] -- ^ arguments to the command
           -> IO (Maybe CapturedProcess)
executeOut path args = withFnPath path
  $ \fp -> captureOutStreams $ 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)
captureOutStreams action =
  actionWithPipes $ \(parentStdoutRead, childStdoutWrite) ->
    actionWithPipes $ \(parentStderrRead, childStderrWrite) -> do
      pid <- SPPB.forkProcess $ do
        -- don't mess up stdin from the parent
        closeFd stdInput

        -- 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' <- readFd parentStdoutRead
          stderr' <- 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)