More work
This commit is contained in:
@@ -1,3 +1,5 @@
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
|
||||
module GHCup.File where
|
||||
|
||||
import Data.ByteString
|
||||
@@ -6,6 +8,7 @@ import Data.Char
|
||||
import Data.Maybe
|
||||
import HPath
|
||||
import HPath.IO
|
||||
import Optics
|
||||
import Streamly.ByteString
|
||||
import Streamly
|
||||
import System.Posix.FilePath hiding ( (</>) )
|
||||
@@ -14,8 +17,9 @@ 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 System.Posix.IO.ByteString
|
||||
import "unix" System.Posix.IO.ByteString
|
||||
hiding ( openFd )
|
||||
import qualified System.Posix.Process.ByteString
|
||||
as SPPB
|
||||
@@ -31,6 +35,18 @@ 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.
|
||||
@@ -84,26 +100,70 @@ findExecutable ex = do
|
||||
sPaths
|
||||
|
||||
|
||||
-- | Execute the given command and collect the stdout and the exit code.
|
||||
executeOut :: Path Fn -- ^ command as filename, e.g. 'ls'
|
||||
-- | 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 (L.ByteString, ExitCode)) -- ^ fst of the tuple is the stdout
|
||||
executeOut path args = withFnPath path $ \fp -> do
|
||||
(parentRead, childWrite) <- createPipe
|
||||
pid <- SPPB.forkProcess $ do
|
||||
whileM_
|
||||
(dupTo childWrite stdOutput)
|
||||
(\r ->
|
||||
getErrno >>= \e -> pure $ r == fromIntegral (-1 :: Int) && e == eINTR
|
||||
)
|
||||
closeFd childWrite
|
||||
closeFd parentRead
|
||||
closeFd stdInput
|
||||
SPPB.executeFile fp True args Nothing
|
||||
-> IO (Maybe CapturedProcess)
|
||||
executeOut path args = withFnPath path
|
||||
$ \fp -> captureOutStreams $ SPPB.executeFile fp True args Nothing
|
||||
|
||||
closeFd childWrite
|
||||
|
||||
SPPB.getProcessStatus True True pid >>= \case
|
||||
-- readE will take care of closing the fd
|
||||
Just (SPPB.Exited es) -> readFd parentRead <&> Just . (, es)
|
||||
_ -> closeFd parentRead $> 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)
|
||||
|
||||
@@ -6,57 +6,39 @@ module GHCup.Prelude where
|
||||
|
||||
import Control.Applicative
|
||||
import Control.Monad
|
||||
import Data.Strict.Maybe
|
||||
import Control.Exception.Safe
|
||||
import qualified Data.Strict.Maybe as S
|
||||
import Data.Monoid ( (<>) )
|
||||
import Prelude ( Monad
|
||||
, Bool
|
||||
, return
|
||||
, (.)
|
||||
)
|
||||
import qualified Prelude as P
|
||||
import Data.String
|
||||
import qualified Data.Text.Lazy.Encoding as TLE
|
||||
import qualified Data.Text.Lazy as TL
|
||||
import Data.Text ( Text )
|
||||
import qualified Data.ByteString.Lazy as L
|
||||
import System.IO.Error
|
||||
|
||||
|
||||
|
||||
fS :: IsString a => P.String -> a
|
||||
fS :: IsString a => String -> a
|
||||
fS = fromString
|
||||
|
||||
fromStrictMaybe :: Maybe a -> P.Maybe a
|
||||
fromStrictMaybe = maybe P.Nothing P.Just
|
||||
fromStrictMaybe :: S.Maybe a -> Maybe a
|
||||
fromStrictMaybe = S.maybe Nothing Just
|
||||
|
||||
fSM :: Maybe a -> P.Maybe a
|
||||
fSM :: S.Maybe a -> Maybe a
|
||||
fSM = fromStrictMaybe
|
||||
|
||||
toStrictMaybe :: P.Maybe a -> Maybe a
|
||||
toStrictMaybe = P.maybe Nothing Just
|
||||
toStrictMaybe :: Maybe a -> S.Maybe a
|
||||
toStrictMaybe = maybe S.Nothing S.Just
|
||||
|
||||
tSM :: P.Maybe a -> Maybe a
|
||||
tSM :: Maybe a -> S.Maybe a
|
||||
tSM = toStrictMaybe
|
||||
|
||||
instance Applicative Maybe where
|
||||
pure = Just
|
||||
internalError :: String -> IO a
|
||||
internalError = fail . ("Internal error: " <>)
|
||||
|
||||
Just f <*> m = P.fmap f m
|
||||
Nothing <*> _m = Nothing
|
||||
iE :: String -> IO a
|
||||
iE = internalError
|
||||
|
||||
liftA2 f (Just x) (Just y) = Just (f x y)
|
||||
liftA2 _ _ _ = Nothing
|
||||
|
||||
Just _m1 *> m2 = m2
|
||||
Nothing *> _m2 = Nothing
|
||||
|
||||
instance Alternative Maybe where
|
||||
empty = Nothing
|
||||
Nothing <|> r = r
|
||||
l <|> _ = l
|
||||
|
||||
|
||||
internalError :: P.String -> P.IO a
|
||||
internalError = P.fail . ("Internal error: " <>)
|
||||
|
||||
-- | Like 'when', but where the test can be monadic.
|
||||
whenM :: Monad m => m Bool -> m () -> m ()
|
||||
@@ -86,3 +68,12 @@ guardM ~f = guard =<< f
|
||||
|
||||
lBS2sT :: L.ByteString -> Text
|
||||
lBS2sT = TL.toStrict . TLE.decodeUtf8
|
||||
|
||||
|
||||
handleIO' :: IOErrorType -> (IOException -> IO ()) -> IO () -> IO ()
|
||||
handleIO' err handler =
|
||||
handleIO (\e -> if err == ioeGetErrorType e then handler e else ioError e)
|
||||
|
||||
hideError :: IOErrorType -> IO () -> IO ()
|
||||
hideError err = handleIO (\e -> if err == ioeGetErrorType e then pure () else ioError e)
|
||||
|
||||
|
||||
@@ -6,7 +6,16 @@ import Data.Map.Strict ( Map )
|
||||
import Network.URL
|
||||
import qualified GHC.Generics as GHC
|
||||
import Data.Versions
|
||||
import HPath
|
||||
import System.Posix.Types
|
||||
|
||||
data DownloadDestination = DPath {
|
||||
dDestDir :: Path Abs
|
||||
, dFileName :: Maybe (Path Fn)
|
||||
} |
|
||||
Fd {
|
||||
dFd :: Fd
|
||||
}
|
||||
|
||||
data Tool = GHC
|
||||
| Cabal
|
||||
|
||||
@@ -59,11 +59,11 @@ instance FromJSONKey Versioning where
|
||||
instance ToJSONKey (Maybe Versioning) where
|
||||
toJSONKey = toJSONKeyText $ \case
|
||||
Just x -> prettyV x
|
||||
Nothing -> T.pack "unknown"
|
||||
Nothing -> T.pack "unknown_version"
|
||||
|
||||
instance FromJSONKey (Maybe Versioning) where
|
||||
fromJSONKey = FromJSONKeyTextParser
|
||||
$ \t -> if t == T.pack "unknown" then pure Nothing else pure $ just t
|
||||
$ \t -> if t == T.pack "unknown_version" then pure Nothing else pure $ just t
|
||||
where
|
||||
just t = case versioning t of
|
||||
Right x -> pure x
|
||||
|
||||
Reference in New Issue
Block a user