Allow to set downloader

2020-04-29 19:12:58 +02:00 · 2020-04-29 19:12:58 +02:00 · 0ff7ebb1fd
commit 0ff7ebb1fd
parent f83dcbc430
8 changed files with 126 additions and 30 deletions
--- 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"

--- 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
--- 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 ())
--- 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 "<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 { .. }


--- 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
--- 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 []
+
--- 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
--- 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 ]--