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.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.IO
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.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 ProcessError = NonZeroExit Int
                  | PTerminated
                  | PStopped
                  | NoSuchPid
                  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)


exe :: ByteString
   -> [ByteString]
   -> Bool
   -> Maybe (Path Abs)
   -> IO (Either ProcessError ())
exe exe' args spath chdir = do
  pid <- SPPB.forkProcess $ do
    maybe (pure ()) (changeWorkingDirectory . toFilePath) chdir
    SPPB.executeFile exe' spath args Nothing

  fmap toProcessError $ SPPB.getProcessStatus True True pid


toProcessError :: Maybe ProcessStatus -> Either ProcessError ()
toProcessError mps = case mps of
  Just (SPPB.Exited (ExitFailure i)) -> Left $ NonZeroExit i
  Just (SPPB.Exited ExitSuccess    ) -> Right ()
  Just (Terminated _ _             ) -> Left $ PTerminated
  Just (Stopped _                  ) -> Left $ PStopped
  Nothing                            -> Left $ NoSuchPid