Fix unpacking of bindists with hardinks pointing to themselves

https://github.com/vmchale/libarchive/issues/14
https://github.com/libarchive/libarchive/issues/1381

.gitlab/script/ghcup_release.sh

@@ -19,7 +19,7 @@ if [ "${OS}" = "LINUX" ] ; then
 	if [ "${BIT}" = "32" ] ; then
 		ecabal build -w ghc-${GHC_VERSION} --ghc-options='-split-sections -optl-static' -ftui -ftar
 	else
-		ecabal build -w ghc-${GHC_VERSION} --ghc-options='-split-sections -optl-static' -ftui -finternal-downloader
+		ecabal build -w ghc-${GHC_VERSION} --ghc-options='-split-sections -optl-static' -ftui
 	fi
 elif [ "${OS}" = "FREEBSD" ] ; then
 	ecabal build -w ghc-${GHC_VERSION} --ghc-options='-split-sections' --constraint="zlib static" -ftui

3rdparty/libarchive/c/archive_write_disk_posix.c

@@ -546,6 +546,7 @@ _archive_write_disk_header(struct archive *_a, struct archive_entry *entry)
 {
 	struct archive_write_disk *a = (struct archive_write_disk *)_a;
 	struct fixup_entry *fe;
+	const char *linkname;
 	int ret, r;
 
 	archive_check_magic(&a->archive, ARCHIVE_WRITE_DISK_MAGIC,
@@ -590,6 +591,17 @@ _archive_write_disk_header(struct archive *_a, struct archive_entry *entry)
 	if (ret != ARCHIVE_OK)
 		return (ret);
 
+	/*
+	 * Check if we have a hardlink that points to itself.
+	 */
+	linkname = archive_entry_hardlink(a->entry);
+	if (linkname != NULL && strcmp(a->name, linkname) == 0) {
+		archive_set_error(&a->archive, ARCHIVE_ERRNO_MISC,
+		    "Skipping hardlink pointing to itself: %s",
+		    a->name);
+		return (ARCHIVE_WARN);
+	}
+
 	/*
 	 * Query the umask so we get predictable mode settings.
 	 * This gets done on every call to _write_header in case the

app/ghcup/Main.hs

@@ -1033,7 +1033,10 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
                       runLogger
                         ($(logError) [i|Error fetching download info: #{e}|])
                       exitWith (ExitFailure 2)
-          runLogger $ checkForUpdates dls pfreq
+
+          case optCommand of
+            Upgrade _ _ -> pure ()
+            _ -> runLogger $ checkForUpdates dls pfreq
 
 
 

ghcup-0.0.2.json

@@ -851,9 +851,9 @@
           "A_64": {
             "Linux_Alpine": {
               "unknown_versioning": {
-                "dlHash": "ec6d0417822c3bfafc7aea0b0402294901231bc5d72dd17a2b849e3f44850695",
+                "dlHash": "76cedc5a9ed9fe259bc7e279defa789f833c5d7144a83915ba8b67371aca481b",
                 "dlSubdir": "ghc-8.6.5",
-                "dlUri": "https://github.com/redneb/ghc-alt-libc/releases/download/ghc-8.6.5-musl/ghc-8.6.5-x86_64-unknown-linux-musl.tar.xz"
+                "dlUri": "https://files.hasufell.de/ghc/ghc-8.6.5-x86_64-alpine-linux.tar.xz"
               }
             },
             "FreeBSD": {
@@ -1253,6 +1253,20 @@
       "8.8.4": {
         "viArch": {
           "A_64": {
+            "Linux_Alpine": {
+              "unknown_versioning": {
+                "dlHash": "5b8dbe2f2430bd66ddc0572fa5a5b5201b9fb7c9a66e13fd5bfb377a5a891bac",
+                "dlSubdir": "ghc-8.8.4",
+                "dlUri": "https://files.hasufell.de/ghc/ghc-8.8.4-x86_64-alpine-linux.tar.xz"
+              }
+            },
+            "FreeBSD": {
+              "unknown_versioning": {
+                "dlHash": "8cebe5ccf454e82acd1ff52ca57590d1ab0f3f44a981b46257ec12158c8c447e",
+                "dlSubdir": "ghc-8.8.4",
+                "dlUri": "https://files.hasufell.de/ghc/ghc-8.8.4-x86_64-portbld-freebsd.tar.xz"
+              }
+            },
             "Linux_Debian": {
               "unknown_versioning": {
                 "dlHash": "4862559d221153caf978f4bf2c15a82c114d1e1f43b298b2ecff2ac94b586d20",
@@ -1333,13 +1347,6 @@
             }
           },
           "A_32": {
-            "FreeBSD": {
-              "unknown_versioning": {
-                "dlHash": "8cebe5ccf454e82acd1ff52ca57590d1ab0f3f44a981b46257ec12158c8c447e",
-                "dlSubdir": "ghc-8.8.4",
-                "dlUri": "https://files.hasufell.de/ghc/ghc-8.8.4-x86_64-portbld-freebsd.tar.xz"
-              }
-            },
             "Linux_Debian": {
               "unknown_versioning": {
                 "dlHash": "43dd954910c9027694312cef0aabc7774d102d0422b7172802cfb72f7d5da3a0",

ghcup.cabal

@@ -105,14 +105,11 @@ common hpath-io
 common hpath-posix
   build-depends: hpath-posix >=0.13.2
 
-common http-client
+common http-io-streams
-  build-depends: http-client >=0.7.1
+  build-depends: http-io-streams >=0.1.2.0
 
-common http-client-openssl
+common io-streams
-  build-depends: http-client-openssl >=0.3.1.0
+  build-depends: io-streams >=1.5
-
-common http-types
-  build-depends: http-types >=0.12.3
 
 common libarchive
   build-depends: libarchive >= 2.2.5.0
@@ -123,9 +120,6 @@ common lzma
 common megaparsec
   build-depends: megaparsec >=8.0.0
 
-common monad-control
-  build-depends: monad-control >=1.0.2.3
-
 common monad-logger
   build-depends: monad-logger >=0.3.31
 
@@ -195,9 +189,6 @@ common time
 common transformers
   build-depends: transformers >=0.5
 
-common transformers-base
-  build-depends: transformers-base >=0.4.4
-
 common os-release
   build-depends: os-release >=1.0.0
 
@@ -272,7 +263,6 @@ library
     , hpath-posix
     , lzma
     , megaparsec
-    , monad-control
     , monad-logger
     , mtl
     , optics
@@ -292,7 +282,6 @@ library
     , text
     , time
     , transformers
-    , transformers-base
     , os-release
     , unix
     , unix-bytestring
@@ -310,6 +299,7 @@ library
     GHCup.Data.GHCupInfo
     GHCup.Data.ToolRequirements
     GHCup.Download
+    GHCup.Download.Utils
     GHCup.Errors
     GHCup.Platform
     GHCup.Requirements
@@ -333,11 +323,10 @@ library
   if flag(internal-downloader)
     import:
         HsOpenSSL
-      , http-client
+      , http-io-streams
-      , http-client-openssl
+      , io-streams
-      , http-types
       , terminal-progress-bar
-    exposed-modules: GHCup.Download.Internal
+    exposed-modules: GHCup.Download.IOStreams
     cpp-options:     -DINTERNAL_DOWNLOADER
 
   if flag(tar)

lib/GHCup/Data/GHCupDownloads.hs

@@ -652,11 +652,11 @@ ghc_865_64_darwin = DownloadInfo
   (Just [rel|ghc-8.6.5|])
   "dfc1bdb1d303a87a8552aa17f5b080e61351f2823c2b99071ec23d0837422169"
 
-ghc_865_64_musl :: DownloadInfo
+ghc_865_64_alpine :: DownloadInfo
-ghc_865_64_musl = DownloadInfo
+ghc_865_64_alpine = DownloadInfo
-  [uri|https://github.com/redneb/ghc-alt-libc/releases/download/ghc-8.6.5-musl/ghc-8.6.5-x86_64-unknown-linux-musl.tar.xz|]
+  [uri|https://files.hasufell.de/ghc/ghc-8.6.5-x86_64-alpine-linux.tar.xz|]
   (Just [rel|ghc-8.6.5|])
-  "ec6d0417822c3bfafc7aea0b0402294901231bc5d72dd17a2b849e3f44850695"
+  "76cedc5a9ed9fe259bc7e279defa789f833c5d7144a83915ba8b67371aca481b"
 
 ghc_865_32_musl :: DownloadInfo
 ghc_865_32_musl = DownloadInfo
@@ -894,6 +894,12 @@ ghc_884_64_freebsd = DownloadInfo
   (Just [rel|ghc-8.8.4|])
   "8cebe5ccf454e82acd1ff52ca57590d1ab0f3f44a981b46257ec12158c8c447e"
 
+ghc_884_64_alpine :: DownloadInfo
+ghc_884_64_alpine = DownloadInfo
+  [uri|https://files.hasufell.de/ghc/ghc-8.8.4-x86_64-alpine-linux.tar.xz|]
+  (Just [rel|ghc-8.8.4|])
+  "5b8dbe2f2430bd66ddc0572fa5a5b5201b9fb7c9a66e13fd5bfb377a5a891bac"
+
 
 
     -----------------
@@ -1702,7 +1708,7 @@ ghcupDownloads = M.fromList
                       ]
                     )
                   , (Darwin      , M.fromList [(Nothing, ghc_865_64_darwin)])
-                  , (Linux Alpine, M.fromList [(Nothing, ghc_865_64_musl)])
+                  , (Linux Alpine, M.fromList [(Nothing, ghc_865_64_alpine)])
                   , (FreeBSD     , M.fromList [(Nothing, ghc_865_64_freebsd)])
                   ]
                 )
@@ -1920,6 +1926,8 @@ ghcupDownloads = M.fromList
                       ]
                     )
                   , (Darwin, M.fromList [(Nothing, ghc_884_64_darwin)])
+                  , (Linux Alpine, M.fromList [(Nothing, ghc_884_64_alpine)])
+                  , (FreeBSD     , M.fromList [(Nothing, ghc_884_64_freebsd)])
                   ]
                 )
               , ( A_32
@@ -1930,7 +1938,6 @@ ghcupDownloads = M.fromList
                   , (Linux Ubuntu, M.fromList [(Nothing, ghc_884_32_deb9)])
                   , (Linux Mint  , M.fromList [(Nothing, ghc_884_32_deb9)])
                   , (Linux Debian, M.fromList [(Nothing, ghc_884_32_deb9)])
-                  , (FreeBSD     , M.fromList [(Nothing, ghc_884_64_freebsd)])
                   ]
                 )
               ]

lib/GHCup/Download.hs

@@ -12,7 +12,8 @@
 module GHCup.Download where
 
 #if defined(INTERNAL_DOWNLOADER)
-import           GHCup.Download.Internal
+import           GHCup.Download.IOStreams
+import           GHCup.Download.Utils
 #endif
 import           GHCup.Errors
 import           GHCup.Types
@@ -232,20 +233,16 @@ getDownloads urlSource = do
 #if !defined(INTERNAL_DOWNLOADER)
       pure Nothing
 #else
-      Settings{..} <- lift ask
+      headers <-
-      case downloader of
+        handleIO (\_ -> pure mempty)
-        Internal -> do
+        $ liftE
-          headers <-
+        $ ( catchAllE
-            handleIO (\_ -> pure mempty)
+              (\_ ->
-            $ liftE
+                pure mempty :: Excepts '[] m1 (M.Map (CI ByteString) ByteString)
-            $ ( catchAllE
-                  (\_ ->
-                    pure mempty :: Excepts '[] m1 (M.Map (CI ByteString) ByteString)
-                  )
-              $ getHead uri'
               )
-          pure $ parseModifiedHeader headers
+          $ getHead uri'
-        _ -> pure Nothing
+          )
+      pure $ parseModifiedHeader headers
 
   parseModifiedHeader :: (M.Map (CI ByteString) ByteString) -> Maybe UTCTime
   parseModifiedHeader headers =
@@ -342,7 +339,9 @@ download dli dest mfn
                   liftE $ lEM @_ @'[ProcessError] $ liftIO $ exec "wget" True
                     (o' ++ ["-O", toFilePath destFile , serializeURIRef' $ view dlUri dli]) Nothing Nothing
 #if defined(INTERNAL_DOWNLOADER)
-                Internal -> liftE $ downloadToFile (_dlUri dli) destFile
+                Internal -> do
+                  (https, host, fullPath, port) <- liftE $ uriToQuadruple (view dlUri dli)
+                  liftE $ downloadToFile https host fullPath port destFile
 #endif
 
     liftE $ checkDigest dli destFile
@@ -409,8 +408,10 @@ downloadBS :: (MonadReader Settings m, MonadCatch m, MonadIO m, MonadLogger m)
                 m
                 L.ByteString
 downloadBS uri'
-  | scheme == "https" || scheme == "http"
+  | scheme == "https"
-  = dl
+  = dl True
+  | scheme == "http"
+  = dl False
   | scheme == "file"
   = liftIOException doesNotExistErrorType (FileDoesNotExistError path)
     $ (liftIO $ RD.readFile path)
@@ -420,7 +421,11 @@ downloadBS uri'
  where
   scheme = view (uriSchemeL' % schemeBSL') uri'
   path   = view pathL' uri'
-  dl = do
+#if defined(INTERNAL_DOWNLOADER)
+  dl https = do
+#else
+  dl _ = do
+#endif
     lift $ $(logDebug) [i|downloading: #{serializeURIRef' uri'}|]
     lift getDownloader >>= \case
       Curl -> do
@@ -440,7 +445,9 @@ downloadBS uri'
             pure $ L.fromStrict stdout
           CapturedProcess (ExitFailure i') _ _ -> throwE $ NonZeroExit i' (toFilePath exe) args
 #if defined(INTERNAL_DOWNLOADER)
-      Internal -> liftE $ downloadBS' uri'
+      Internal -> do
+        (_, host', fullPath', port') <- liftE $ uriToQuadruple uri'
+        liftE $ downloadBS' https host' fullPath' port'
 #endif
 
 

lib/GHCup/Download/IOStreams.hs

@@ -0,0 +1,253 @@
+{-# LANGUAGE DataKinds             #-}
+{-# LANGUAGE DeriveGeneric         #-}
+{-# LANGUAGE FlexibleContexts      #-}
+{-# LANGUAGE OverloadedStrings     #-}
+{-# LANGUAGE QuasiQuotes           #-}
+{-# LANGUAGE TemplateHaskell       #-}
+{-# LANGUAGE TypeApplications      #-}
+{-# LANGUAGE TypeFamilies          #-}
+
+
+module GHCup.Download.IOStreams where
+
+
+import           GHCup.Download.Utils
+import           GHCup.Errors
+import           GHCup.Types.Optics
+import           GHCup.Types.JSON               ( )
+import           GHCup.Utils.File
+import           GHCup.Utils.Prelude
+
+import           Control.Applicative
+import           Control.Exception.Safe
+import           Control.Monad
+import           Control.Monad.Reader
+import           Data.ByteString                ( ByteString )
+import           Data.ByteString.Builder
+import           Data.CaseInsensitive           ( CI )
+import           Data.IORef
+import           Data.Maybe
+import           Data.Text.Read
+import           HPath
+import           HPath.IO                      as HIO
+import           Haskus.Utils.Variant.Excepts
+import           Network.Http.Client     hiding ( URL )
+import           Optics
+import           Prelude                 hiding ( abs
+                                                , readFile
+                                                , writeFile
+                                                )
+import "unix"    System.Posix.IO.ByteString
+                                         hiding ( fdWrite )
+import "unix-bytestring" System.Posix.IO.ByteString
+                                                ( fdWrite )
+import           System.ProgressBar
+import           URI.ByteString
+
+import qualified Data.ByteString               as BS
+import qualified Data.ByteString.Lazy          as L
+import qualified Data.Map.Strict               as M
+import qualified System.IO.Streams             as Streams
+
+
+
+
+
+    ----------------------------
+    --[ Low-level (non-curl) ]--
+    ----------------------------
+
+
+-- | Load the result of this download into memory at once.
+downloadBS' :: MonadIO m
+            => Bool             -- ^ https?
+            -> ByteString       -- ^ host (e.g. "www.example.com")
+            -> ByteString       -- ^ path (e.g. "/my/file") including query
+            -> Maybe Int        -- ^ optional port (e.g. 3000)
+            -> Excepts
+                 '[ HTTPStatusError
+                  , URIParseError
+                  , UnsupportedScheme
+                  , NoLocationHeader
+                  , TooManyRedirs
+                  ]
+                 m
+                 (L.ByteString)
+downloadBS' https host path port = do
+  bref <- liftIO $ newIORef (mempty :: Builder)
+  let stepper bs = modifyIORef bref (<> byteString bs)
+  downloadInternal False https host path port stepper
+  liftIO (readIORef bref <&> toLazyByteString)
+
+
+downloadToFile :: (MonadMask m, MonadIO m)
+               => Bool             -- ^ https?
+               -> ByteString       -- ^ host (e.g. "www.example.com")
+               -> ByteString       -- ^ path (e.g. "/my/file") including query
+               -> Maybe Int        -- ^ optional port (e.g. 3000)
+               -> Path Abs         -- ^ destination file to create and write to
+               -> Excepts '[DownloadFailed] m ()
+downloadToFile https host fullPath port destFile = do
+  fd <- liftIO $ createRegularFileFd newFilePerms destFile
+  let stepper = fdWrite fd
+  flip finally (liftIO $ closeFd fd)
+    $ reThrowAll DownloadFailed $ downloadInternal True https host fullPath port stepper
+
+
+downloadInternal :: MonadIO m
+                 => Bool        -- ^ whether to show a progress bar
+                 -> Bool        -- ^ https?
+                 -> ByteString  -- ^ host
+                 -> ByteString  -- ^ path with query
+                 -> Maybe Int   -- ^ optional port
+                 -> (ByteString -> IO a)   -- ^ the consuming step function
+                 -> Excepts
+                      '[ HTTPStatusError
+                       , URIParseError
+                       , UnsupportedScheme
+                       , NoLocationHeader
+                       , TooManyRedirs
+                       ]
+                      m
+                      ()
+downloadInternal = go (5 :: Int)
+
+ where
+  go redirs progressBar https host path port consumer = do
+    r <- liftIO $ withConnection' https host port action
+    veitherToExcepts r >>= \case
+      Just r' ->
+        if redirs > 0 then followRedirectURL r' else throwE TooManyRedirs
+      Nothing -> pure ()
+   where
+    action c = do
+      let q = buildRequest1 $ http GET path
+
+      sendRequest c q emptyBody
+
+      receiveResponse
+        c
+        (\r i' -> runE $ do
+          let scode = getStatusCode r
+          if
+            | scode >= 200 && scode < 300 -> downloadStream r i' >> pure Nothing
+            | scode >= 300 && scode < 400 -> case getHeader r "Location" of
+              Just r' -> pure $ Just $ r'
+              Nothing -> throwE NoLocationHeader
+            | otherwise -> throwE $ HTTPStatusError scode
+        )
+
+    followRedirectURL bs = case parseURI strictURIParserOptions bs of
+      Right uri' -> do
+        (https', host', fullPath', port') <- liftE $ uriToQuadruple uri'
+        go (redirs - 1) progressBar https' host' fullPath' port' consumer
+      Left e -> throwE e
+
+    downloadStream r i' = do
+      let size = case getHeader r "Content-Length" of
+            Just x' -> case decimal $ decUTF8Safe x' of
+              Left  _       -> 0
+              Right (r', _) -> r'
+            Nothing -> 0
+
+      mpb <- if progressBar
+        then Just <$> (liftIO $ newProgressBar defStyle 10 (Progress 0 size ()))
+        else pure Nothing
+
+      outStream <- liftIO $ Streams.makeOutputStream
+        (\case
+          Just bs -> do
+            forM_ mpb $ \pb -> incProgress pb (BS.length bs)
+            void $ consumer bs
+          Nothing -> pure ()
+        )
+      liftIO $ Streams.connect i' outStream
+
+
+getHead :: (MonadCatch m, MonadIO m)
+        => URI
+        -> Excepts
+             '[ HTTPStatusError
+              , URIParseError
+              , UnsupportedScheme
+              , NoLocationHeader
+              , TooManyRedirs
+              , ProcessError
+              ]
+             m
+             (M.Map (CI ByteString) ByteString)
+getHead uri' | scheme == "https" = head' True
+             | scheme == "http"  = head' False
+             | otherwise         = throwE UnsupportedScheme
+
+ where
+  scheme = view (uriSchemeL' % schemeBSL') uri'
+  head' https = do
+    (_, host', fullPath', port') <- liftE $ uriToQuadruple uri'
+    liftE $ headInternal https host' fullPath' port'
+
+
+headInternal :: MonadIO m
+             => Bool        -- ^ https?
+             -> ByteString  -- ^ host
+             -> ByteString  -- ^ path with query
+             -> Maybe Int   -- ^ optional port
+             -> Excepts
+                  '[ HTTPStatusError
+                   , URIParseError
+                   , UnsupportedScheme
+                   , TooManyRedirs
+                   , NoLocationHeader
+                   ]
+                  m
+                  (M.Map (CI ByteString) ByteString)
+headInternal = go (5 :: Int)
+
+ where
+  go redirs https host path port = do
+    r <- liftIO $ withConnection' https host port action
+    veitherToExcepts r >>= \case
+      Left r' ->
+        if redirs > 0 then followRedirectURL r' else throwE TooManyRedirs
+      Right hs -> pure hs
+   where
+
+    action c = do
+      let q = buildRequest1 $ http HEAD path
+
+      sendRequest c q emptyBody
+
+      unsafeReceiveResponse
+        c
+        (\r _ -> runE $ do
+          let scode = getStatusCode r
+          if
+            | scode >= 200 && scode < 300 -> do
+              let headers = getHeaderMap r
+              pure $ Right $ headers
+            | scode >= 300 && scode < 400 -> case getHeader r "Location" of
+              Just r' -> pure $ Left $ r'
+              Nothing -> throwE NoLocationHeader
+            | otherwise -> throwE $ HTTPStatusError scode
+        )
+
+    followRedirectURL bs = case parseURI strictURIParserOptions bs of
+      Right uri' -> do
+        (https', host', fullPath', port') <- liftE $ uriToQuadruple uri'
+        go (redirs - 1) https' host' fullPath' port'
+      Left e -> throwE e
+
+
+withConnection' :: Bool
+                -> ByteString
+                -> Maybe Int
+                -> (Connection -> IO a)
+                -> IO a
+withConnection' https host port action = bracket acquire closeConnection action
+
+ where
+  acquire = case https of
+    True -> do
+      ctx <- baselineContextSSL
+      openConnectionSSL ctx host (fromIntegral $ fromMaybe 443 port)
+    False -> openConnection host (fromIntegral $ fromMaybe 80 port)

lib/GHCup/Download/Internal.hs

@@ -1,213 +0,0 @@
-{-# LANGUAGE CPP                   #-}
-{-# LANGUAGE DataKinds             #-}
-{-# LANGUAGE DeriveGeneric         #-}
-{-# LANGUAGE FlexibleContexts      #-}
-{-# LANGUAGE OverloadedStrings     #-}
-{-# LANGUAGE QuasiQuotes           #-}
-{-# LANGUAGE TemplateHaskell       #-}
-{-# LANGUAGE TypeApplications      #-}
-{-# LANGUAGE TypeFamilies          #-}
-
-
-module GHCup.Download.Internal where
-
-
-import           GHCup.Errors
-import           GHCup.Types.Optics
-import           GHCup.Types.JSON               ( )
-import           GHCup.Utils.File
-import           GHCup.Utils.Prelude
-
-import           Control.Applicative
-import           Control.Exception.Safe
-import           Control.Monad
-import           Control.Monad.Reader
-import           Data.ByteString                ( ByteString )
-import           Data.ByteString.Builder
-import           Data.CaseInsensitive           ( CI )
-import           Data.IORef
-import           Data.Maybe
-import           Data.Text.Read
-import           HPath
-import           HPath.IO                      as HIO
-import           Haskus.Utils.Variant.Excepts
-import           Network.HTTP.Client
-import           Network.HTTP.Client.OpenSSL
-import           Network.HTTP.Types.Status
-import           Network.HTTP.Types.Header
-import           Optics
-import           Prelude                 hiding ( abs
-                                                , readFile
-                                                , writeFile
-                                                )
-import "unix"    System.Posix.IO.ByteString
-                                         hiding ( fdWrite )
-import "unix-bytestring" System.Posix.IO.ByteString
-                                                ( fdWrite )
-import           System.ProgressBar
-import           URI.ByteString
-
-import qualified Data.ByteString               as BS
-import qualified Data.ByteString.Lazy          as L
-import qualified Data.Map.Strict               as M
-import qualified Data.Text                     as T
-import qualified OpenSSL.Session               as SSL
-
-
-
-
-
-    ----------------------------
-    --[ Low-level (non-curl) ]--
-    ----------------------------
-
-
--- | Load the result of this download into memory at once.
-downloadBS' :: (MonadThrow m, MonadIO m)
-            => URI
-            -> Excepts
-                 '[HTTPStatusError]
-                 m
-                 (L.ByteString)
-downloadBS' uri' = do
-  bref <- liftIO $ newIORef (mempty :: Builder)
-  let stepper bs = modifyIORef bref (<> byteString bs)
-  downloadInternal False
-                   (T.unpack . decUTF8Safe . serializeURIRef' $ uri')
-                   stepper
-  liftIO (readIORef bref <&> toLazyByteString)
-
-
-downloadToFile :: (MonadMask m, MonadIO m)
-               => URI
-               -> Path Abs         -- ^ destination file to create and write to
-               -> Excepts '[DownloadFailed] m ()
-downloadToFile uri' destFile = do
-  fd <- liftIO $ createRegularFileFd newFilePerms destFile
-  let stepper = fdWrite fd
-  flip finally (liftIO $ closeFd fd)
-    $ reThrowAll DownloadFailed
-    $ downloadInternal True
-                       (T.unpack . decUTF8Safe . serializeURIRef' $ uri')
-                       stepper
-
-
-downloadInternal :: (MonadThrow m, MonadIO m)
-                 => Bool        -- ^ whether to show a progress bar
-                 -> String
-                 -> (ByteString -> IO a)   -- ^ the consuming step function
-                 -> Excepts
-                      '[HTTPStatusError]
-                      m
-                      ()
-downloadInternal progressBar uri' consumer = lEM $ liftIO $ withConnection' action
- where
-  action :: (MonadThrow m, MonadIO m) => Manager -> m (Either HTTPStatusError ())
-  action m = do
-    request <- parseRequest ("GET " <> uri')
-    liftIO $ withResponse
-      request
-      m
-      (\r -> do
-        let scode = statusCode . responseStatus $ r
-        if
-          | scode >= 200 && scode < 300 ->
-              let headers = M.fromList . responseHeaders $ r
-              in fmap Right $ liftIO $ downloadStream (responseBody r) headers
-          | otherwise -> pure $ Left $ HTTPStatusError scode
-      )
-
-  downloadStream :: BodyReader -> M.Map HeaderName ByteString -> IO ()
-  downloadStream br headers = do
-    let size = case M.lookup "Content-Length" headers of
-          Just x' -> case decimal $ decUTF8Safe x' of
-            Left  _       -> 0
-            Right (r', _) -> r'
-          Nothing -> 0
-
-    mpb <- if progressBar
-      then Just <$> (liftIO $ newProgressBar defStyle 10 (Progress 0 size ()))
-      else pure Nothing
-
-    loop mpb
-
-   where
-    loop mpb = do
-      bs <- brRead br
-      if BS.length bs == 0 then pure () else do
-        void $ consumer bs
-        forM_ mpb $ \pb -> incProgress pb (BS.length bs)
-        loop mpb
-
-
-getHead :: (MonadCatch m, MonadIO m)
-        => URI
-        -> Excepts
-             '[HTTPStatusError, UnsupportedScheme]
-             m
-             (M.Map (CI ByteString) ByteString)
-getHead uri' | scheme == "https" || scheme == "http" = head'
-             | otherwise                             = throwE UnsupportedScheme
-
- where
-  scheme = view (uriSchemeL' % schemeBSL') uri'
-  head' =
-    liftE $ headInternal (T.unpack . decUTF8Safe . serializeURIRef' $ uri')
-
-
-headInternal :: (MonadThrow m, MonadIO m)
-             => String
-             -> Excepts
-                  '[HTTPStatusError]
-                  m
-                  (M.Map (CI ByteString) ByteString)
-headInternal uri' = lEM $ liftIO $ withConnection' action
- where
-  action :: (MonadThrow m, MonadIO m)
-         => Manager
-         -> m (Either HTTPStatusError (M.Map (CI ByteString) ByteString))
-  action m = do
-    request <- parseRequest ("HEAD " <> uri')
-    liftIO $ withResponse
-      request
-      m
-      (\r -> do
-        let scode = statusCode . responseStatus $ r
-        if
-          | scode >= 200 && scode < 300 -> do
-            let headers = responseHeaders r
-            pure $ Right $ M.fromList $ headers
-          | otherwise -> pure $ Left (HTTPStatusError scode)
-      )
-
-
-withConnection' :: (Manager -> IO a) -> IO a
-withConnection' action = do
-  mg  <- newManager $ opensslManagerSettings baselineContextSSL
-  withOpenSSL (action mg)
-
-
-baselineContextSSL :: IO SSL.SSLContext
-baselineContextSSL = withOpenSSL $ do
-    ctx <- SSL.context
-    SSL.contextSetDefaultCiphers ctx
-#if defined(darwin_HOST_OS)
-    SSL.contextSetVerificationMode ctx SSL.VerifyNone
-#elif defined(mingw32_HOST_OS)
-    SSL.contextSetVerificationMode ctx SSL.VerifyNone
-#elif defined(freebsd_HOST_OS)
-    SSL.contextSetCAFile ctx "/usr/local/etc/ssl/cert.pem"
-    SSL.contextSetVerificationMode ctx $ SSL.VerifyPeer True True Nothing
-#elif defined(openbsd_HOST_OS)
-    SSL.contextSetCAFile ctx "/etc/ssl/cert.pem"
-    SSL.contextSetVerificationMode ctx $ SSL.VerifyPeer True True Nothing
-#else
-    fedora <- doesDirectoryExist [abs|/etc/pki/tls|]
-    if fedora
-        then do
-            SSL.contextSetCAFile ctx "/etc/pki/tls/certs/ca-bundle.crt"
-        else do
-            SSL.contextSetCADirectory ctx "/etc/ssl/certs"
-    SSL.contextSetVerificationMode ctx $ SSL.VerifyPeer True True Nothing
-#endif
-    return ctx

lib/GHCup/Download/Utils.hs

@@ -0,0 +1,64 @@
+{-# LANGUAGE DataKinds             #-}
+{-# LANGUAGE DeriveGeneric         #-}
+{-# LANGUAGE FlexibleContexts      #-}
+{-# LANGUAGE OverloadedStrings     #-}
+{-# LANGUAGE QuasiQuotes           #-}
+{-# LANGUAGE TemplateHaskell       #-}
+{-# LANGUAGE TypeApplications      #-}
+{-# LANGUAGE TypeFamilies          #-}
+
+
+module GHCup.Download.Utils where
+
+
+import           GHCup.Errors
+import           GHCup.Types.Optics
+import           GHCup.Types.JSON               ( )
+import           GHCup.Utils.Prelude
+
+import           Control.Applicative
+import           Control.Monad
+import           Data.ByteString                ( ByteString )
+import           Data.Maybe
+import           Haskus.Utils.Variant.Excepts
+import           Optics
+import           Prelude                 hiding ( abs
+                                                , readFile
+                                                , writeFile
+                                                )
+import           URI.ByteString
+
+import qualified Data.Binary.Builder           as B
+import qualified Data.ByteString               as BS
+import qualified Data.ByteString.Lazy          as L
+
+
+-- | Extracts from a URI type: (https?, host, path+query, port)
+uriToQuadruple :: Monad m
+               => URI
+               -> Excepts
+                    '[UnsupportedScheme]
+                    m
+                    (Bool, ByteString, ByteString, Maybe Int)
+uriToQuadruple URI {..} = do
+  let scheme = view schemeBSL' uriScheme
+
+  host <-
+    preview (_Just % authorityHostL' % hostBSL') uriAuthority
+      ?? UnsupportedScheme
+
+  https <- if
+    | scheme == "https" -> pure True
+    | scheme == "http"  -> pure False
+    | otherwise         -> throwE UnsupportedScheme
+
+  let queryBS =
+        BS.intercalate "&"
+          . fmap (\(x, y) -> encodeQuery x <> "=" <> encodeQuery y)
+          $ (queryPairs uriQuery)
+      port =
+        preview (_Just % authorityPortL' % _Just % portNumberL') uriAuthority
+      fullpath = if BS.null queryBS then uriPath else uriPath <> "?" <> queryBS
+  pure (https, host, fullpath, port)
+  where encodeQuery = L.toStrict . B.toLazyByteString . urlEncodeQuery
+

lib/GHCup/Utils/Prelude.hs

@@ -1,12 +1,8 @@
-{-# OPTIONS_GHC -Wno-orphans #-}
-
 {-# LANGUAGE DataKinds           #-}
 {-# LANGUAGE DeriveLift          #-}
 {-# LANGUAGE FlexibleContexts    #-}
 {-# LANGUAGE FlexibleInstances   #-}
 {-# LANGUAGE QuasiQuotes         #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE UndecidableInstances #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeApplications    #-}
 {-# LANGUAGE TypeFamilies        #-}
@@ -17,10 +13,8 @@ module GHCup.Utils.Prelude where
 import           Control.Applicative
 import           Control.Exception.Safe
 import           Control.Monad
-import           Control.Monad.Base
 import           Control.Monad.IO.Class
 import           Control.Monad.Trans.Class      ( lift )
-import           Control.Monad.Trans.Control
 import           Data.Bifunctor
 import           Data.ByteString                ( ByteString )
 import           Data.String
@@ -270,40 +264,3 @@ decUTF8Safe = E.decodeUtf8With E.lenientDecode
 
 decUTF8Safe' :: L.ByteString -> Text
 decUTF8Safe' = TL.toStrict . TLE.decodeUtf8With E.lenientDecode
-
-
-instance MonadBaseControl b m => MonadBaseControl b (Excepts e m) where
-    type StM (Excepts e m) a = ComposeSt (Excepts e) m a
-    liftBaseWith   = defaultLiftBaseWith
-    restoreM       = defaultRestoreM
-    {-# INLINABLE liftBaseWith #-}
-    {-# INLINABLE restoreM #-}
-
-instance MonadTransControl (Excepts e) where
-    type StT (Excepts e) a = VEither e a
-    liftWith f = veitherMToExcepts <$> liftM return $ f $ runE
-    restoreT = veitherMToExcepts
-    {-# INLINABLE liftWith #-}
-    {-# INLINABLE restoreT #-}
-
-instance MonadBase b m => MonadBase b (Excepts e m) where
-  liftBase = liftBaseDefault
-  {-# INLINABLE liftBase #-}
-
-instance MonadBaseControl (VEither e) (VEither e) where
-  type StM (VEither e) a = a
-  liftBaseWith f = f id
-  restoreM = return
-  {-# INLINABLE liftBaseWith #-}
-  {-# INLINABLE restoreM #-}
-
-instance MonadBase (VEither e) (VEither e) where
-  liftBase = id
-  {-# INLINABLE liftBase #-}
-
-
-veitherMToExcepts :: Monad m => m (VEither es a) -> Excepts es m a
-veitherMToExcepts ma = do
-  ve <- lift ma
-  veitherToExcepts ve
-