From 0ff7ebb1fdffa2b1006e912c4f82e30e84f30769 Mon Sep 17 00:00:00 2001 From: Julian Ospald Date: Wed, 29 Apr 2020 19:12:58 +0200 Subject: [PATCH] Allow to set downloader --- .gitlab/before_script/linux/install_deps.sh | 2 +- .gitlab/script/ghcup_version.sh | 6 +- app/ghcup-gen/Validate.hs | 2 +- app/ghcup/Main.hs | 37 ++++++++- ghcup.cabal | 4 + lib/GHCup/Download.hs | 87 ++++++++++++++++----- lib/GHCup/Types.hs | 14 +++- lib/GHCup/Utils.hs | 4 + 8 files changed, 126 insertions(+), 30 deletions(-) diff --git a/.gitlab/before_script/linux/install_deps.sh b/.gitlab/before_script/linux/install_deps.sh index 15c1afc..f219eb0 100755 --- a/.gitlab/before_script/linux/install_deps.sh +++ b/.gitlab/before_script/linux/install_deps.sh @@ -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" diff --git a/.gitlab/script/ghcup_version.sh b/.gitlab/script/ghcup_version.sh index b072bf4..1f641d6 100755 --- a/.gitlab/script/ghcup_version.sh +++ b/.gitlab/script/ghcup_version.sh @@ -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 diff --git a/app/ghcup-gen/Validate.hs b/app/ghcup-gen/Validate.hs index 53ef367..8e0ef92 100644 --- a/app/ghcup-gen/Validate.hs +++ b/app/ghcup-gen/Validate.hs @@ -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 ()) diff --git a/app/ghcup/Main.hs b/app/ghcup/Main.hs index 113810f..4a4f32e 100644 --- a/app/ghcup/Main.hs +++ b/app/ghcup/Main.hs @@ -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 "" <> help - "Keep build directories?" + "Keep build directories? (default: never)" <> value Never + <> hidden + ) + <*> option + (eitherReader downloaderParser) + ( long "downloader" +#if defined(INTERNAL_DOWNLOADER) + <> metavar "" + <> help + "Downloader to use (default: internal)" + <> value Internal +#else + <> metavar "" + <> 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 { .. } diff --git a/ghcup.cabal b/ghcup.cabal index bceecf1..16b74d9 100644 --- a/ghcup.cabal +++ b/ghcup.cabal @@ -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 diff --git a/lib/GHCup/Download.hs b/lib/GHCup/Download.hs index 93b2ccf..4752048 100644 --- a/lib/GHCup/Download.hs +++ b/lib/GHCup/Download.hs @@ -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 [] + diff --git a/lib/GHCup/Types.hs b/lib/GHCup/Types.hs index e5c8338..d263f86 100644 --- a/lib/GHCup/Types.hs +++ b/lib/GHCup/Types.hs @@ -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 diff --git a/lib/GHCup/Utils.hs b/lib/GHCup/Utils.hs index 9ebe964..99b2e4a 100644 --- a/lib/GHCup/Utils.hs +++ b/lib/GHCup/Utils.hs @@ -311,6 +311,10 @@ getCache :: MonadReader Settings m => m Bool getCache = ask <&> cache +getDownloader :: MonadReader Settings m => m Downloader +getDownloader = ask <&> downloader + + ------------- --[ Other ]--