Allow to set downloader

.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"
 

.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

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 ())

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
+  let cache      = optCache
-      noVerify = optNoVerify
+      noVerify   = optNoVerify
-      keepDirs = optKeepDirs
+      keepDirs   = optKeepDirs
+      downloader = optsDownloader
   in  Settings { .. }
 
 

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

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)
+              lift getDownloader >>= \case
-              liftE $ lEM @_ @'[ProcessError] $ liftIO $ exec "curl" True
+                Curl -> do
-                ["-fL", "-o", toFilePath destFile , serializeURIRef' $ view dlUri dli] Nothing Nothing
+                  o' <- liftIO getCurlOpts
-#else
+                  liftE $ lEM @_ @'[ProcessError] $ liftIO $ exec "curl" True
-              (https, host, fullPath, port) <- liftE $ uriToQuadruple (view dlUri dli)
+                    (o' ++ ["-fL", "-o", toFilePath destFile, serializeURIRef' $ view dlUri dli]) Nothing Nothing
-              liftE $ downloadToFile https host fullPath port destFile
+                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)
+#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
   dl https = do
-    (_, host', fullPath', port') <- liftE $ uriToQuadruple uri'
+#else
-    liftE $ downloadBS' https host' fullPath' port'
+  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 []
+

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
+  { cache      :: Bool
-  , noVerify :: Bool
+  , noVerify   :: Bool
-  , keepDirs :: KeepDirs
+  , 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

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