More work
This commit is contained in:
parent
9d3631b20b
commit
d3072a88b8
25
ghcup.cabal
25
ghcup.cabal
@ -20,16 +20,21 @@ source-repository head
|
|||||||
type: git
|
type: git
|
||||||
location: https://github.com/hasufell/ghcup-hs
|
location: https://github.com/hasufell/ghcup-hs
|
||||||
|
|
||||||
|
common HsOpenSSL { build-depends: HsOpenSSL >= 0.11 }
|
||||||
common aeson { build-depends: aeson >= 1.4 }
|
common aeson { build-depends: aeson >= 1.4 }
|
||||||
common ascii-string { build-depends: ascii-string >= 1.0 }
|
common ascii-string { build-depends: ascii-string >= 1.0 }
|
||||||
common base { build-depends: base >= 4.12.0.0 && < 5 }
|
common async { build-depends: async >= 0.8 }
|
||||||
|
common base { build-depends: base >= 4.12 && < 5 }
|
||||||
common bytestring { build-depends: bytestring >= 0.10 }
|
common bytestring { build-depends: bytestring >= 0.10 }
|
||||||
common containers { build-depends: containers >= 0.6 }
|
common containers { build-depends: containers >= 0.6 }
|
||||||
common generics-sop { build-depends: generics-sop >= 0.5 }
|
common generics-sop { build-depends: generics-sop >= 0.5 }
|
||||||
common hpath { build-depends: hpath >= 0.10.1 }
|
common hpath { build-depends: hpath >= 0.10.1 }
|
||||||
common hpath-filepath { build-depends: hpath-filepath >= 0.10 }
|
common hpath-filepath { build-depends: hpath-filepath >= 0.10 }
|
||||||
common hpath-io { build-depends: hpath-io >= 0.10.1 }
|
common hpath-io { build-depends: hpath-io >= 0.10.1 }
|
||||||
|
common http-io-streams { build-depends: http-io-streams >= 0.1 }
|
||||||
|
common io-streams { build-depends: io-streams >= 1.5 }
|
||||||
common language-bash { build-depends: language-bash >= 0.9 }
|
common language-bash { build-depends: language-bash >= 0.9 }
|
||||||
|
common mtl { build-depends: mtl >= 2.2 }
|
||||||
common optics { build-depends: optics >= 0.2 }
|
common optics { build-depends: optics >= 0.2 }
|
||||||
common parsec { build-depends: parsec >= 3.1 }
|
common parsec { build-depends: parsec >= 3.1 }
|
||||||
common safe-exceptions { build-depends: safe-exceptions >= 0.1 }
|
common safe-exceptions { build-depends: safe-exceptions >= 0.1 }
|
||||||
@ -40,24 +45,31 @@ common text { build-depends: text >= 1.2 }
|
|||||||
common text-icu { build-depends: text-icu >= 0.7 }
|
common text-icu { build-depends: text-icu >= 0.7 }
|
||||||
common transformers { build-depends: transformers >= 0.5 }
|
common transformers { build-depends: transformers >= 0.5 }
|
||||||
common unix { build-depends: unix >= 2.7 }
|
common unix { build-depends: unix >= 2.7 }
|
||||||
|
common unix-bytestring { build-depends: unix-bytestring >= 0.3 }
|
||||||
common url { build-depends: url >= 2.1 }
|
common url { build-depends: url >= 2.1 }
|
||||||
common utf8-string { build-depends: utf8-string >= 1.0 }
|
common utf8-string { build-depends: utf8-string >= 1.0 }
|
||||||
common vector { build-depends: vector >= 0.12 }
|
common vector { build-depends: vector >= 0.12 }
|
||||||
common waargonaut { build-depends: waargonaut >= 0.8 }
|
|
||||||
common async { build-depends: async >= 0.8 }
|
|
||||||
common mtl { build-depends: mtl >= 2.2 }
|
|
||||||
common versions { build-depends: versions >= 3.5 }
|
common versions { build-depends: versions >= 3.5 }
|
||||||
|
common waargonaut { build-depends: waargonaut >= 0.8 }
|
||||||
|
|
||||||
|
|
||||||
common config
|
common config
|
||||||
default-language: Haskell2010
|
default-language: Haskell2010
|
||||||
ghc-options: -Wall -fwarn-tabs -fwarn-incomplete-uni-patterns -fwarn-incomplete-record-updates -O2 -fspec-constr-recursive=16 -fmax-worker-args=16
|
ghc-options: -Wall -fwarn-tabs -fwarn-incomplete-uni-patterns -fwarn-incomplete-record-updates -O2 -fspec-constr-recursive=16 -fmax-worker-args=16
|
||||||
default-extensions: LambdaCase, MultiWayIf, ScopedTypeVariables, StrictData, Strict, TupleSections
|
default-extensions: LambdaCase
|
||||||
|
, MultiWayIf
|
||||||
|
, PackageImports
|
||||||
|
, RecordWildCards
|
||||||
|
, ScopedTypeVariables
|
||||||
|
, StrictData
|
||||||
|
, Strict
|
||||||
|
, TupleSections
|
||||||
|
|
||||||
library
|
library
|
||||||
import: config
|
import: config
|
||||||
, base
|
, base
|
||||||
-- deps
|
-- deps
|
||||||
|
, HsOpenSSL
|
||||||
, aeson
|
, aeson
|
||||||
, ascii-string
|
, ascii-string
|
||||||
, async
|
, async
|
||||||
@ -67,6 +79,8 @@ library
|
|||||||
, hpath
|
, hpath
|
||||||
, hpath-filepath
|
, hpath-filepath
|
||||||
, hpath-io
|
, hpath-io
|
||||||
|
, http-io-streams
|
||||||
|
, io-streams
|
||||||
, language-bash
|
, language-bash
|
||||||
, mtl
|
, mtl
|
||||||
, optics
|
, optics
|
||||||
@ -79,6 +93,7 @@ library
|
|||||||
, text-icu
|
, text-icu
|
||||||
, transformers
|
, transformers
|
||||||
, unix
|
, unix
|
||||||
|
, unix-bytestring
|
||||||
, url
|
, url
|
||||||
, utf8-string
|
, utf8-string
|
||||||
, vector
|
, vector
|
||||||
|
171
lib/GHCup.hs
171
lib/GHCup.hs
@ -13,6 +13,9 @@ module GHCup where
|
|||||||
|
|
||||||
import Control.Applicative
|
import Control.Applicative
|
||||||
import Control.Monad
|
import Control.Monad
|
||||||
|
import Control.Monad.Trans.Maybe
|
||||||
|
import Control.Monad.IO.Class
|
||||||
|
import Control.Exception.Safe
|
||||||
import Data.Foldable ( asum )
|
import Data.Foldable ( asum )
|
||||||
import Data.Text ( Text )
|
import Data.Text ( Text )
|
||||||
import Data.Versions
|
import Data.Versions
|
||||||
@ -29,10 +32,32 @@ import Prelude hiding ( abs
|
|||||||
, readFile
|
, readFile
|
||||||
)
|
)
|
||||||
import System.Info
|
import System.Info
|
||||||
|
import System.IO.Error
|
||||||
import qualified Data.Text as T
|
import qualified Data.Text as T
|
||||||
import qualified Data.Text.ICU as ICU
|
import qualified Data.Text.ICU as ICU
|
||||||
import Data.Maybe ( isJust )
|
import Data.Maybe
|
||||||
import qualified Data.Map.Strict as Map
|
import qualified Data.Map.Strict as Map
|
||||||
|
import GHC.IO.Exception
|
||||||
|
import GHC.IO.Handle
|
||||||
|
import Network.Http.Client hiding ( URL )
|
||||||
|
import System.IO.Streams ( InputStream
|
||||||
|
, OutputStream
|
||||||
|
, stdout
|
||||||
|
)
|
||||||
|
import qualified System.IO.Streams as Streams
|
||||||
|
import System.Posix.Temp.ByteString
|
||||||
|
import "unix" System.Posix.IO.ByteString
|
||||||
|
hiding ( fdWrite )
|
||||||
|
import System.Posix.FD as FD
|
||||||
|
import System.Posix.Directory.Foreign ( oTrunc )
|
||||||
|
import qualified Data.ByteString as B
|
||||||
|
import OpenSSL ( withOpenSSL )
|
||||||
|
import qualified Data.ByteString.Char8 as C
|
||||||
|
import Data.Functor ( ($>) )
|
||||||
|
import System.Posix.Types
|
||||||
|
import "unix-bytestring" System.Posix.IO.ByteString
|
||||||
|
( fdWrite )
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
availableDownloads :: AvailableDownloads
|
availableDownloads :: AvailableDownloads
|
||||||
@ -78,11 +103,11 @@ availableDownloads = Map.fromList
|
|||||||
}
|
}
|
||||||
|
|
||||||
|
|
||||||
downloadURL :: ToolRequest
|
getDownloadURL :: ToolRequest
|
||||||
-> Maybe PlatformRequest
|
-> Maybe PlatformRequest
|
||||||
-> URLSource
|
-> URLSource
|
||||||
-> IO (Maybe URL) -- TODO: better error handling
|
-> IO (Maybe URL) -- TODO: better error handling
|
||||||
downloadURL (ToolRequest t v) mpfReq urlSource = do
|
getDownloadURL (ToolRequest t v) mpfReq urlSource = do
|
||||||
(PlatformRequest arch plat ver) <- case mpfReq of
|
(PlatformRequest arch plat ver) <- case mpfReq of
|
||||||
Just x -> pure x
|
Just x -> pure x
|
||||||
Nothing -> do
|
Nothing -> do
|
||||||
@ -95,10 +120,10 @@ downloadURL (ToolRequest t v) mpfReq urlSource = do
|
|||||||
OwnSource url -> fail "Not implemented"
|
OwnSource url -> fail "Not implemented"
|
||||||
OwnSpec dls -> pure dls
|
OwnSpec dls -> pure dls
|
||||||
|
|
||||||
pure $ downloadURL' t v arch plat ver dls
|
pure $ getDownloadURL' t v arch plat ver dls
|
||||||
|
|
||||||
|
|
||||||
downloadURL' :: Tool
|
getDownloadURL' :: Tool
|
||||||
-> Version
|
-> Version
|
||||||
-- ^ tool version
|
-- ^ tool version
|
||||||
-> Architecture
|
-> Architecture
|
||||||
@ -109,7 +134,7 @@ downloadURL' :: Tool
|
|||||||
-- ^ optional version of the platform
|
-- ^ optional version of the platform
|
||||||
-> AvailableDownloads
|
-> AvailableDownloads
|
||||||
-> Maybe URL
|
-> Maybe URL
|
||||||
downloadURL' t v a p mv dls =
|
getDownloadURL' t v a p mv dls =
|
||||||
with_distro <|> without_distro_ver <|> without_distro
|
with_distro <|> without_distro_ver <|> without_distro
|
||||||
|
|
||||||
where
|
where
|
||||||
@ -156,15 +181,15 @@ getLinuxDistro = do
|
|||||||
]
|
]
|
||||||
let parsedVer = ver >>= either (const Nothing) Just . versioning
|
let parsedVer = ver >>= either (const Nothing) Just . versioning
|
||||||
distro = if
|
distro = if
|
||||||
| hasWord name (T.pack <$> ["debian"]) -> Debian
|
| hasWord name ["debian"] -> Debian
|
||||||
| hasWord name (T.pack <$> ["ubuntu"]) -> Ubuntu
|
| hasWord name ["ubuntu"] -> Ubuntu
|
||||||
| hasWord name (T.pack <$> ["linuxmint", "Linux Mint"]) -> Mint
|
| hasWord name ["linuxmint", "Linux Mint"] -> Mint
|
||||||
| hasWord name (T.pack <$> ["fedora"]) -> Fedora
|
| hasWord name ["fedora"] -> Fedora
|
||||||
| hasWord name (T.pack <$> ["centos"]) -> CentOS
|
| hasWord name ["centos"] -> CentOS
|
||||||
| hasWord name (T.pack <$> ["Red Hat"]) -> RedHat
|
| hasWord name ["Red Hat"] -> RedHat
|
||||||
| hasWord name (T.pack <$> ["alpine"]) -> Alpine
|
| hasWord name ["alpine"] -> Alpine
|
||||||
| hasWord name (T.pack <$> ["exherbo"]) -> Exherbo
|
| hasWord name ["exherbo"] -> Exherbo
|
||||||
| hasWord name (T.pack <$> ["gentoo"]) -> Gentoo
|
| hasWord name ["gentoo"] -> Gentoo
|
||||||
| otherwise -> UnknownLinux
|
| otherwise -> UnknownLinux
|
||||||
pure (distro, parsedVer)
|
pure (distro, parsedVer)
|
||||||
where
|
where
|
||||||
@ -177,7 +202,7 @@ getLinuxDistro = do
|
|||||||
|| y
|
|| y
|
||||||
)
|
)
|
||||||
False
|
False
|
||||||
matches
|
(T.pack <$> matches)
|
||||||
|
|
||||||
os_release :: Path Abs
|
os_release :: Path Abs
|
||||||
os_release = [abs|/etc/os-release|]
|
os_release = [abs|/etc/os-release|]
|
||||||
@ -199,9 +224,10 @@ getLinuxDistro = do
|
|||||||
try_lsb_release_cmd :: IO (Text, Maybe Text)
|
try_lsb_release_cmd :: IO (Text, Maybe Text)
|
||||||
try_lsb_release_cmd = do
|
try_lsb_release_cmd = do
|
||||||
(Just _ ) <- findExecutable lsb_release_cmd
|
(Just _ ) <- findExecutable lsb_release_cmd
|
||||||
(Just (name, _)) <- executeOut lsb_release_cmd [fS "-si"]
|
(Just name) <- (fmap . fmap) _stdOut
|
||||||
ver <- executeOut lsb_release_cmd [fS "-sr"]
|
$ executeOut lsb_release_cmd [fS "-si"]
|
||||||
pure (lBS2sT name, fmap (lBS2sT . fst) ver)
|
ver <- (fmap . fmap) _stdOut $ executeOut lsb_release_cmd [fS "-sr"]
|
||||||
|
pure (lBS2sT name, fmap lBS2sT ver)
|
||||||
|
|
||||||
try_lsb_release :: IO (Text, Maybe Text)
|
try_lsb_release :: IO (Text, Maybe Text)
|
||||||
try_lsb_release = do
|
try_lsb_release = do
|
||||||
@ -236,11 +262,114 @@ getLinuxDistro = do
|
|||||||
pure (T.pack "debian", Just $ lBS2sT ver)
|
pure (T.pack "debian", Just $ lBS2sT ver)
|
||||||
|
|
||||||
|
|
||||||
|
-- | Tries to download from the given http or https url
|
||||||
|
-- and saves the result in continuous memory into a file.
|
||||||
|
-- If the filename is not provided, then we:
|
||||||
|
-- 1. try to guess the filename from the url path
|
||||||
|
-- 2. otherwise create a random file
|
||||||
|
--
|
||||||
|
-- The file must not exist.
|
||||||
|
download :: Bool -- ^ https?
|
||||||
|
-> String -- ^ host (e.g. "www.example.com")
|
||||||
|
-> String -- ^ path (e.g. "/my/file")
|
||||||
|
-> Maybe Integer -- ^ optional port (e.g. 3000)
|
||||||
|
-> Path Abs -- ^ destination directory to download into
|
||||||
|
-> Maybe (Path Fn) -- ^ optionally provided filename
|
||||||
|
-> IO (Path Abs)
|
||||||
|
download https host path port dest mfn = do
|
||||||
|
fromJust <$> downloadInternal https host path port (Right (dest, mfn))
|
||||||
|
|
||||||
|
-- | Same as 'download', except uses URL type. As such, this might
|
||||||
|
-- throw an exception if the url type or host protocol is not supported.
|
||||||
|
--
|
||||||
|
-- Only Absolute HTTP/HTTPS is supported.
|
||||||
|
download' :: URL -> Path Abs -> Maybe (Path Fn) -> IO (Path Abs)
|
||||||
|
download' url dest mfn = case url of
|
||||||
|
URL { url_type = Absolute (Host { protocol = HTTP https, host = host, port = port }), url_path = path, url_params = [] }
|
||||||
|
-> download https host path port dest mfn
|
||||||
|
_ -> fail ("Don't know how to handle URL: " <> exportURL url)
|
||||||
|
|
||||||
|
|
||||||
|
-- | Same as 'download', except with a file descriptor. Allows to e.g.
|
||||||
|
-- print to stdout.
|
||||||
|
downloadFd :: Bool -- ^ https?
|
||||||
|
-> String -- ^ host (e.g. "www.example.com")
|
||||||
|
-> String -- ^ path (e.g. "/my/file")
|
||||||
|
-> Maybe Integer -- ^ optional port (e.g. 3000)
|
||||||
|
-> Fd -- ^ function creating an Fd to write the body into
|
||||||
|
-> IO ()
|
||||||
|
downloadFd https host path port fd =
|
||||||
|
void $ downloadInternal https host path port (Left fd)
|
||||||
|
|
||||||
|
|
||||||
|
downloadInternal :: Bool
|
||||||
|
-> String
|
||||||
|
-> String
|
||||||
|
-> Maybe Integer
|
||||||
|
-> Either Fd (Path Abs, Maybe (Path Fn))
|
||||||
|
-> IO (Maybe (Path Abs))
|
||||||
|
downloadInternal https host path port dest = do
|
||||||
|
c <- case https of
|
||||||
|
True -> do
|
||||||
|
ctx <- baselineContextSSL
|
||||||
|
openConnectionSSL ctx (C.pack host) (fromIntegral $ fromMaybe 443 port)
|
||||||
|
False -> openConnection (C.pack host) (fromIntegral $ fromMaybe 80 port)
|
||||||
|
|
||||||
|
let q = buildRequest1 $ http GET (C.pack "/" <> C.pack path)
|
||||||
|
|
||||||
|
sendRequest c q emptyBody
|
||||||
|
|
||||||
|
(fd, mfp) <- case dest of
|
||||||
|
Right (dest, mfn) -> getFile dest mfn <&> (<&> Just)
|
||||||
|
Left fd -> pure (fd, Nothing)
|
||||||
|
|
||||||
|
-- wrapper so we can close Fds we created
|
||||||
|
let receiveResponse' c b = case dest of
|
||||||
|
Right _ -> (flip finally) (closeFd fd) $ receiveResponse c b
|
||||||
|
Left _ -> receiveResponse c b
|
||||||
|
|
||||||
|
receiveResponse'
|
||||||
|
c
|
||||||
|
(\p i -> do
|
||||||
|
outStream <- Streams.makeOutputStream
|
||||||
|
(\case
|
||||||
|
Just bs -> void $ fdWrite fd bs
|
||||||
|
Nothing -> pure ()
|
||||||
|
)
|
||||||
|
Streams.connect i outStream
|
||||||
|
)
|
||||||
|
|
||||||
|
closeConnection c
|
||||||
|
|
||||||
|
pure mfp
|
||||||
|
|
||||||
|
where
|
||||||
|
-- Manage to find a file we can write the body into.
|
||||||
|
getFile :: Path Abs -> Maybe (Path Fn) -> IO (Fd, Path Abs)
|
||||||
|
getFile dest mfn = do
|
||||||
|
-- destination dir must exist
|
||||||
|
hideError AlreadyExists $ createDirRecursive newDirPerms dest
|
||||||
|
case mfn of
|
||||||
|
-- if a filename was provided, try that
|
||||||
|
Just x ->
|
||||||
|
let fp = dest </> x
|
||||||
|
in fmap (, fp) $ createRegularFileFd newFilePerms fp
|
||||||
|
Nothing ->
|
||||||
|
-- ...otherwise try to infer the filename from the URL path
|
||||||
|
case (snd . T.breakOnEnd (fS "/") . T.pack) <$> decString False path of
|
||||||
|
Just x -> do
|
||||||
|
fn' <- parseFn (C.pack $ T.unpack x)
|
||||||
|
let fp = dest </> fn'
|
||||||
|
fmap (, fp) $ createRegularFileFd newFilePerms fp
|
||||||
|
Nothing -> do
|
||||||
|
-- ...if all fails, use a random filename!
|
||||||
|
(fp, handle) <- (mkstemp (toFilePath dest))
|
||||||
|
path <- parseAbs fp
|
||||||
|
fd <- handleToFd handle
|
||||||
|
pure (fd, path)
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
-- download :: URL -> Path Abs -> IO (Path Abs)
|
|
||||||
-- download = undefined
|
|
||||||
|
|
||||||
-- unpack :: Path Abs -> IO (Path Abs)
|
-- unpack :: Path Abs -> IO (Path Abs)
|
||||||
-- unpack = undefined
|
-- unpack = undefined
|
||||||
|
@ -1,3 +1,5 @@
|
|||||||
|
{-# LANGUAGE TemplateHaskell #-}
|
||||||
|
|
||||||
module GHCup.File where
|
module GHCup.File where
|
||||||
|
|
||||||
import Data.ByteString
|
import Data.ByteString
|
||||||
@ -6,6 +8,7 @@ import Data.Char
|
|||||||
import Data.Maybe
|
import Data.Maybe
|
||||||
import HPath
|
import HPath
|
||||||
import HPath.IO
|
import HPath.IO
|
||||||
|
import Optics
|
||||||
import Streamly.ByteString
|
import Streamly.ByteString
|
||||||
import Streamly
|
import Streamly
|
||||||
import System.Posix.FilePath hiding ( (</>) )
|
import System.Posix.FilePath hiding ( (</>) )
|
||||||
@ -14,8 +17,9 @@ import Control.Monad
|
|||||||
import Control.Exception.Safe
|
import Control.Exception.Safe
|
||||||
import Data.Functor
|
import Data.Functor
|
||||||
import System.Posix.Files.ByteString
|
import System.Posix.Files.ByteString
|
||||||
|
import System.Posix.Directory.Foreign ( oExcl )
|
||||||
import System.IO
|
import System.IO
|
||||||
import System.Posix.IO.ByteString
|
import "unix" System.Posix.IO.ByteString
|
||||||
hiding ( openFd )
|
hiding ( openFd )
|
||||||
import qualified System.Posix.Process.ByteString
|
import qualified System.Posix.Process.ByteString
|
||||||
as SPPB
|
as SPPB
|
||||||
@ -31,6 +35,18 @@ import qualified Streamly.Data.Fold as FL
|
|||||||
import Data.ByteString.Builder
|
import Data.ByteString.Builder
|
||||||
import Foreign.C.Error
|
import Foreign.C.Error
|
||||||
import GHCup.Prelude
|
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.
|
-- |Checks whether a file is executable. Follows symlinks.
|
||||||
@ -84,26 +100,70 @@ findExecutable ex = do
|
|||||||
sPaths
|
sPaths
|
||||||
|
|
||||||
|
|
||||||
-- | Execute the given command and collect the stdout and the exit code.
|
-- | 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'
|
executeOut :: Path Fn -- ^ command as filename, e.g. 'ls'
|
||||||
-> [ByteString] -- ^ arguments to the command
|
-> [ByteString] -- ^ arguments to the command
|
||||||
-> IO (Maybe (L.ByteString, ExitCode)) -- ^ fst of the tuple is the stdout
|
-> IO (Maybe CapturedProcess)
|
||||||
executeOut path args = withFnPath path $ \fp -> do
|
executeOut path args = withFnPath path
|
||||||
(parentRead, childWrite) <- createPipe
|
$ \fp -> captureOutStreams $ SPPB.executeFile fp True args Nothing
|
||||||
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
|
|
||||||
|
|
||||||
closeFd childWrite
|
|
||||||
|
-- | 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
|
SPPB.getProcessStatus True True pid >>= \case
|
||||||
-- readE will take care of closing the fd
|
-- readFd will take care of closing the fd
|
||||||
Just (SPPB.Exited es) -> readFd parentRead <&> Just . (, es)
|
Just (SPPB.Exited es) -> do
|
||||||
_ -> closeFd parentRead $> Nothing
|
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.Applicative
|
||||||
import Control.Monad
|
import Control.Monad
|
||||||
import Data.Strict.Maybe
|
import Control.Exception.Safe
|
||||||
|
import qualified Data.Strict.Maybe as S
|
||||||
import Data.Monoid ( (<>) )
|
import Data.Monoid ( (<>) )
|
||||||
import Prelude ( Monad
|
|
||||||
, Bool
|
|
||||||
, return
|
|
||||||
, (.)
|
|
||||||
)
|
|
||||||
import qualified Prelude as P
|
|
||||||
import Data.String
|
import Data.String
|
||||||
import qualified Data.Text.Lazy.Encoding as TLE
|
import qualified Data.Text.Lazy.Encoding as TLE
|
||||||
import qualified Data.Text.Lazy as TL
|
import qualified Data.Text.Lazy as TL
|
||||||
import Data.Text ( Text )
|
import Data.Text ( Text )
|
||||||
import qualified Data.ByteString.Lazy as L
|
import qualified Data.ByteString.Lazy as L
|
||||||
|
import System.IO.Error
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
fS :: IsString a => P.String -> a
|
fS :: IsString a => String -> a
|
||||||
fS = fromString
|
fS = fromString
|
||||||
|
|
||||||
fromStrictMaybe :: Maybe a -> P.Maybe a
|
fromStrictMaybe :: S.Maybe a -> Maybe a
|
||||||
fromStrictMaybe = maybe P.Nothing P.Just
|
fromStrictMaybe = S.maybe Nothing Just
|
||||||
|
|
||||||
fSM :: Maybe a -> P.Maybe a
|
fSM :: S.Maybe a -> Maybe a
|
||||||
fSM = fromStrictMaybe
|
fSM = fromStrictMaybe
|
||||||
|
|
||||||
toStrictMaybe :: P.Maybe a -> Maybe a
|
toStrictMaybe :: Maybe a -> S.Maybe a
|
||||||
toStrictMaybe = P.maybe Nothing Just
|
toStrictMaybe = maybe S.Nothing S.Just
|
||||||
|
|
||||||
tSM :: P.Maybe a -> Maybe a
|
tSM :: Maybe a -> S.Maybe a
|
||||||
tSM = toStrictMaybe
|
tSM = toStrictMaybe
|
||||||
|
|
||||||
instance Applicative Maybe where
|
internalError :: String -> IO a
|
||||||
pure = Just
|
internalError = fail . ("Internal error: " <>)
|
||||||
|
|
||||||
Just f <*> m = P.fmap f m
|
iE :: String -> IO a
|
||||||
Nothing <*> _m = Nothing
|
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.
|
-- | Like 'when', but where the test can be monadic.
|
||||||
whenM :: Monad m => m Bool -> m () -> m ()
|
whenM :: Monad m => m Bool -> m () -> m ()
|
||||||
@ -86,3 +68,12 @@ guardM ~f = guard =<< f
|
|||||||
|
|
||||||
lBS2sT :: L.ByteString -> Text
|
lBS2sT :: L.ByteString -> Text
|
||||||
lBS2sT = TL.toStrict . TLE.decodeUtf8
|
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 Network.URL
|
||||||
import qualified GHC.Generics as GHC
|
import qualified GHC.Generics as GHC
|
||||||
import Data.Versions
|
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
|
data Tool = GHC
|
||||||
| Cabal
|
| Cabal
|
||||||
|
@ -59,11 +59,11 @@ instance FromJSONKey Versioning where
|
|||||||
instance ToJSONKey (Maybe Versioning) where
|
instance ToJSONKey (Maybe Versioning) where
|
||||||
toJSONKey = toJSONKeyText $ \case
|
toJSONKey = toJSONKeyText $ \case
|
||||||
Just x -> prettyV x
|
Just x -> prettyV x
|
||||||
Nothing -> T.pack "unknown"
|
Nothing -> T.pack "unknown_version"
|
||||||
|
|
||||||
instance FromJSONKey (Maybe Versioning) where
|
instance FromJSONKey (Maybe Versioning) where
|
||||||
fromJSONKey = FromJSONKeyTextParser
|
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
|
where
|
||||||
just t = case versioning t of
|
just t = case versioning t of
|
||||||
Right x -> pure x
|
Right x -> pure x
|
||||||
|
Loading…
Reference in New Issue
Block a user