hasufell
/
ghcup-hs
1
1
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Allow to set downloader

This commit is contained in:
Julian Ospald 2020-04-29 19:12:58 +02:00
parent f83dcbc430
commit 0ff7ebb1fd
No known key found for this signature in database
GPG Key ID: 511B62C09D50CD28
8 changed files with 126 additions and 30 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
.gitlab/before_script/linux/install_deps.sh
View File

@ -3,7 +3,7 @@
set -eux
sudo apt-get update -y
sudo apt-get install -y libnuma-dev zlib1g-dev libgmp-dev libgmp10 libssl-dev liblzma-dev git
sudo apt-get install -y libnuma-dev zlib1g-dev libgmp-dev libgmp10 libssl-dev liblzma-dev git wget
. "$( cd "$(dirname "$0")" ; pwd -P )/../../ghcup_env"

6
.gitlab/script/ghcup_version.sh
View File

@ -71,7 +71,11 @@ ghci-$(ghc --numeric-version) --version
# test installing new ghc doesn't mess with currently set GHC
# https://gitlab.haskell.org/haskell/ghcup-hs/issues/7
eghcup install 8.4.4
if [ "${OS}" = "DARWIN" ] ; then
eghcup install 8.4.4
else # test wget a bit
eghcup install --downloader=wget 8.4.4
fi
[ "$(ghc --numeric-version)" = "${ghc_ver}" ]
eghcup set 8.4.4
eghcup set 8.4.4

2
app/ghcup-gen/Validate.hs
View File

@ -175,7 +175,7 @@ validateTarballs dls = do
where
downloadAll dli = do
let settings = Settings True False Never
let settings = Settings True False Never Curl
let runLogger = myLoggerT LoggerConfig { lcPrintDebug = True
, colorOutter = B.hPut stderr
, rawOutter = (\_ -> pure ())

37
app/ghcup/Main.hs
View File

@ -75,6 +75,7 @@ data Options = Options
, optUrlSource :: Maybe URI
, optNoVerify :: Bool
, optKeepDirs :: KeepDirs
, optsDownloader :: Downloader
-- commands
, optCommand :: Command
}
@ -170,8 +171,25 @@ opts =
( long "keep"
<> metavar "<always|errors|never>"
<> help
"Keep build directories?"
"Keep build directories? (default: never)"
<> value Never
<> hidden
)
<*> option
(eitherReader downloaderParser)
( long "downloader"
#if defined(INTERNAL_DOWNLOADER)
<> metavar "<internal|curl|wget>"
<> help
"Downloader to use (default: internal)"
<> value Internal
#else
<> metavar "<curl|wget>"
<> help
"Downloader to use (default: curl)"
<> value Curl
#endif
<> hidden
)
<*> com
where
@ -524,6 +542,16 @@ keepOnParser s' | t == T.pack "always" = Right Always
where t = T.toLower (T.pack s')
downloaderParser :: String -> Either String Downloader
downloaderParser s' | t == T.pack "curl" = Right Curl
| t == T.pack "wget" = Right Wget
#if defined(INTERNAL_DOWNLOADER)
| t == T.pack "internal" = Right Internal
#endif
| otherwise = Left ("Unknown downloader value: " <> s')
where t = T.toLower (T.pack s')
platformParser :: String -> Either String PlatformRequest
platformParser s' = case MP.parse (platformP <* MP.eof) "" (T.pack s') of
Right r -> pure r
@ -599,9 +627,10 @@ platformParser s' = case MP.parse (platformP <* MP.eof) "" (T.pack s') of
toSettings :: Options -> Settings
toSettings Options {..} =
let cache = optCache
noVerify = optNoVerify
keepDirs = optKeepDirs
let cache = optCache
noVerify = optNoVerify
keepDirs = optKeepDirs
downloader = optsDownloader
in Settings { .. }

4
ghcup.cabal
View File

@ -346,6 +346,10 @@ executable ghcup
hs-source-dirs: app/ghcup
default-language: Haskell2010
if flag(internal-downloader)
cpp-options: -DINTERNAL_DOWNLOADER
executable ghcup-gen
import:
config

87
lib/GHCup/Download.hs
View File

@ -47,6 +47,7 @@ import Data.Time.Clock.POSIX
import Data.Time.Format
#endif
import Data.Versions
import Data.Word8
import GHC.IO.Exception
import HPath
import HPath.IO as HIO
@ -57,9 +58,11 @@ import Prelude hiding ( abs
, writeFile
)
import System.IO.Error
import System.Posix.Env.ByteString ( getEnv )
import URI.ByteString
import qualified Crypto.Hash.SHA256 as SHA256
import qualified Data.ByteString as BS
import qualified Data.ByteString.Base16 as B16
import qualified Data.ByteString.Lazy as L
#if defined(INTERNAL_DOWNLOADER)
@ -92,6 +95,7 @@ getDownloadsF :: ( FromJSONKey Tool
, MonadLogger m
, MonadThrow m
, MonadFail m
, MonadReader Settings m
)
=> URLSource
-> Excepts
@ -132,6 +136,7 @@ getDownloads :: ( FromJSONKey Tool
, MonadLogger m
, MonadThrow m
, MonadFail m
, MonadReader Settings m
)
=> URLSource
-> Excepts '[JSONError , DownloadFailed] m GHCupInfo
@ -157,7 +162,12 @@ getDownloads urlSource = do
--
-- Always save the local file with the mod time of the remote file.
smartDl :: forall m1
. (MonadCatch m1, MonadIO m1, MonadFail m1, MonadLogger m1)
. ( MonadCatch m1
, MonadIO m1
, MonadFail m1
, MonadLogger m1
, MonadReader Settings m1
)
=> URI
-> Excepts
'[ FileDoesNotExistError
@ -319,12 +329,19 @@ download dli dest mfn
(liftIO $ hideError doesNotExistErrorType $ deleteFile destFile)
>> (throwE . DownloadFailed $ e)
) $ do
#if !defined(INTERNAL_DOWNLOADER)
liftE $ lEM @_ @'[ProcessError] $ liftIO $ exec "curl" True
["-fL", "-o", toFilePath destFile , serializeURIRef' $ view dlUri dli] Nothing Nothing
#else
(https, host, fullPath, port) <- liftE $ uriToQuadruple (view dlUri dli)
liftE $ downloadToFile https host fullPath port destFile
lift getDownloader >>= \case
Curl -> do
o' <- liftIO getCurlOpts
liftE $ lEM @_ @'[ProcessError] $ liftIO $ exec "curl" True
(o' ++ ["-fL", "-o", toFilePath destFile, serializeURIRef' $ view dlUri dli]) Nothing Nothing
Wget -> do
o' <- liftIO getWgetOpts
liftE $ lEM @_ @'[ProcessError] $ liftIO $ exec "wget" True
(o' ++ ["-O", toFilePath destFile , serializeURIRef' $ view dlUri dli]) Nothing Nothing
#if defined(INTERNAL_DOWNLOADER)
Internal -> do
(https, host, fullPath, port) <- liftE $ uriToQuadruple (view dlUri dli)
liftE $ downloadToFile https host fullPath port destFile
#endif
liftE $ checkDigest dli destFile
@ -377,7 +394,7 @@ downloadCached dli mfn = do
-- | This is used for downloading the JSON.
downloadBS :: (MonadCatch m, MonadIO m, MonadLogger m)
downloadBS :: (MonadReader Settings m, MonadCatch m, MonadIO m, MonadLogger m)
=> URI
-> Excepts
'[ FileDoesNotExistError
@ -404,19 +421,33 @@ downloadBS uri'
where
scheme = view (uriSchemeL' % schemeBSL') uri'
path = view pathL' uri'
#if !defined(INTERNAL_DOWNLOADER)
dl _ = do
lift $ $(logDebug) [i|downloading: #{serializeURIRef' uri'}|]
let exe = [rel|curl|]
args = ["-sSfL", serializeURIRef' uri']
liftIO (executeOut exe args Nothing) >>= \case
CapturedProcess ExitSuccess stdout _ -> do
pure $ L.fromStrict stdout
CapturedProcess (ExitFailure i') _ _ -> throwE $ NonZeroExit i' (toFilePath exe) args
#else
#if defined(INTERNAL_DOWNLOADER)
dl https = do
(_, host', fullPath', port') <- liftE $ uriToQuadruple uri'
liftE $ downloadBS' https host' fullPath' port'
#else
dl _ = do
#endif
lift $ $(logDebug) [i|downloading: #{serializeURIRef' uri'}|]
lift getDownloader >>= \case
Curl -> do
o' <- liftIO getCurlOpts
let exe = [rel|curl|]
args = o' ++ ["-sSfL", serializeURIRef' uri']
liftIO (executeOut exe args Nothing) >>= \case
CapturedProcess ExitSuccess stdout _ -> do
pure $ L.fromStrict stdout
CapturedProcess (ExitFailure i') _ _ -> throwE $ NonZeroExit i' (toFilePath exe) args
Wget -> do
o' <- liftIO getWgetOpts
let exe = [rel|wget|]
args = o' ++ ["-qO-", serializeURIRef' uri']
liftIO (executeOut exe args Nothing) >>= \case
CapturedProcess ExitSuccess stdout _ -> do
pure $ L.fromStrict stdout
CapturedProcess (ExitFailure i') _ _ -> throwE $ NonZeroExit i' (toFilePath exe) args
#if defined(INTERNAL_DOWNLOADER)
Internal -> do
(_, host', fullPath', port') <- liftE $ uriToQuadruple uri'
liftE $ downloadBS' https host' fullPath' port'
#endif
@ -434,3 +465,19 @@ checkDigest dli file = do
let eDigest = view dlHash dli
when ((cDigest /= eDigest) && verify) $ throwE (DigestError cDigest eDigest)
-- | Get additional curl args from env. This is an undocumented option.
getCurlOpts :: IO [ByteString]
getCurlOpts =
getEnv "GHCUP_CURL_OPTS" >>= \case
Just r -> pure $ BS.split _space r
Nothing -> pure []
-- | Get additional wget args from env. This is an undocumented option.
getWgetOpts :: IO [ByteString]
getWgetOpts =
getEnv "GHCUP_WGET_OPTS" >>= \case
Just r -> pure $ BS.split _space r
Nothing -> pure []

14
lib/GHCup/Types.hs
View File

@ -1,3 +1,4 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveGeneric #-}
module GHCup.Types where
@ -140,9 +141,10 @@ data URLSource = GHCupURL
data Settings = Settings
{ cache :: Bool
, noVerify :: Bool
, keepDirs :: KeepDirs
{ cache :: Bool
, noVerify :: Bool
, keepDirs :: KeepDirs
, downloader :: Downloader
}
deriving Show
@ -152,6 +154,12 @@ data KeepDirs = Always
| Never
deriving (Eq, Show, Ord)
data Downloader = Curl
| Wget
#if defined(INTERNAL_DOWNLOADER)
| Internal
#endif
deriving (Eq, Show, Ord)
data DebugInfo = DebugInfo
{ diBaseDir :: Path Abs

4
lib/GHCup/Utils.hs
View File

@ -311,6 +311,10 @@ getCache :: MonadReader Settings m => m Bool
getCache = ask <&> cache
getDownloader :: MonadReader Settings m => m Downloader
getDownloader = ask <&> downloader
-------------
--[ Other ]--