From afd7e7dc4f4e51c700f5e1673835cbe9dbba5b29 Mon Sep 17 00:00:00 2001 From: Julian Ospald Date: Wed, 3 Jan 2024 00:32:23 +0800 Subject: [PATCH] Re-introduce tar --- app/ghcup/BrickMain.hs | 1 - cabal.project | 10 ++++++- cabal.project.release | 2 +- ghcup.cabal | 25 ++++++++++++++++-- lib-opt/GHCup/OptParse/Compile.hs | 1 - lib-opt/GHCup/OptParse/Install.hs | 1 - lib-opt/GHCup/OptParse/Run.hs | 1 - lib-opt/GHCup/OptParse/Test.hs | 1 - lib/GHCup/Cabal.hs | 1 - lib/GHCup/Errors.hs | 2 ++ lib/GHCup/GHC.hs | 1 - lib/GHCup/HLS.hs | 1 - lib/GHCup/Stack.hs | 1 - lib/GHCup/Types.hs | 17 ++++++++++++ lib/GHCup/Utils.hs | 44 +++++++++++++++++++++++++++++-- 15 files changed, 94 insertions(+), 15 deletions(-) diff --git a/app/ghcup/BrickMain.hs b/app/ghcup/BrickMain.hs index d9c226f..e769a56 100644 --- a/app/ghcup/BrickMain.hs +++ b/app/ghcup/BrickMain.hs @@ -44,7 +44,6 @@ import Brick.Widgets.Center ( center, centerLayer ) import qualified Brick.Widgets.List as L import Brick.Focus (FocusRing) import qualified Brick.Focus as F -import Codec.Archive import Control.Applicative import Control.Exception.Safe #if !MIN_VERSION_base(4,13,0) diff --git a/cabal.project b/cabal.project index fa6ad49..02254fe 100644 --- a/cabal.project +++ b/cabal.project @@ -3,7 +3,7 @@ packages: ./ghcup.cabal optional-packages: ./vendored/*/*.cabal package ghcup - flags: +tui + flags: +tui +tar constraints: http-io-streams -brotli, any.aeson >= 2.0.1.0 @@ -13,6 +13,11 @@ source-repository-package location: https://github.com/fosskers/versions.git tag: 7bc3355348aac3510771d4622aff09ac38c9924d +source-repository-package + type: git + location: https://github.com/haskell/tar.git + tag: d94a988be4311b830149a9f8fc16739927e5fc1c + package libarchive flags: -system-libarchive @@ -30,3 +35,6 @@ package streamly package * test-show-details: direct + +allow-newer: cabal-install-parsers:tar + diff --git a/cabal.project.release b/cabal.project.release index 67f00cc..81d8e11 100644 --- a/cabal.project.release +++ b/cabal.project.release @@ -5,7 +5,7 @@ optional-packages: ./vendored/*/*.cabal optimization: 2 package ghcup - flags: +tui + flags: +tui -tar if os(linux) if arch(x86_64) || arch(i386) diff --git a/ghcup.cabal b/ghcup.cabal index 476eb8e..6cd5332 100644 --- a/ghcup.cabal +++ b/ghcup.cabal @@ -53,6 +53,11 @@ flag no-exe default: False manual: True +flag tar + description: Use haskell tar instead of libarchive. + default: False + manual: True + common app-common-depends build-depends: , aeson >=1.4 @@ -68,7 +73,6 @@ common app-common-depends , filepath ^>=1.4.2.1 , haskus-utils-types ^>=1.5 , haskus-utils-variant ^>=3.2.1 - , libarchive ^>=3.0.3.0 , megaparsec >=8.0.0 && <9.3 , mtl ^>=2.2 , optparse-applicative >=0.15.1.0 && <0.18 @@ -90,6 +94,15 @@ common app-common-depends , versions >=6.0.3 && <6.1 , yaml-streamly ^>=0.12.0 + if flag(tar) + cpp-options: -DTAR + build-depends: + tar ^>=0.6.0.0 + , zip ^>=2.0.0 + + else + build-depends: libarchive ^>=3.0.3.0 + library exposed-modules: GHCup @@ -166,7 +179,6 @@ library , filepath ^>=1.4.2.1 , haskus-utils-types ^>=1.5 , haskus-utils-variant ^>=3.2.1 - , libarchive ^>=3.0.3.0 , lzma-static ^>=5.2.5.3 , megaparsec >=8.0.0 && <9.3 , mtl ^>=2.2 @@ -196,6 +208,15 @@ library , yaml-streamly ^>=0.12.0 , zlib ^>=0.6.2.2 + if flag(tar) + cpp-options: -DTAR + build-depends: + tar ^>=0.6.0.0 + , zip ^>=2.0.0 + + else + build-depends: libarchive ^>=3.0.3.0 + if (flag(internal-downloader) && !os(windows)) exposed-modules: GHCup.Download.IOStreams cpp-options: -DINTERNAL_DOWNLOADER diff --git a/lib-opt/GHCup/OptParse/Compile.hs b/lib-opt/GHCup/OptParse/Compile.hs index 1d1d908..ba14235 100644 --- a/lib-opt/GHCup/OptParse/Compile.hs +++ b/lib-opt/GHCup/OptParse/Compile.hs @@ -25,7 +25,6 @@ import GHCup.OptParse.Common #if !MIN_VERSION_base(4,13,0) import Control.Monad.Fail ( MonadFail ) #endif -import Codec.Archive ( ArchiveResult ) import Control.Concurrent (threadDelay) import Control.Monad.Reader import Control.Monad.Trans.Resource diff --git a/lib-opt/GHCup/OptParse/Install.hs b/lib-opt/GHCup/OptParse/Install.hs index 7ad5005..9d6e80a 100644 --- a/lib-opt/GHCup/OptParse/Install.hs +++ b/lib-opt/GHCup/OptParse/Install.hs @@ -24,7 +24,6 @@ import GHCup.Prelude import GHCup.Prelude.Logger import GHCup.Prelude.String.QQ -import Codec.Archive #if !MIN_VERSION_base(4,13,0) import Control.Monad.Fail ( MonadFail ) #endif diff --git a/lib-opt/GHCup/OptParse/Run.hs b/lib-opt/GHCup/OptParse/Run.hs index c6e8e8f..72caeab 100644 --- a/lib-opt/GHCup/OptParse/Run.hs +++ b/lib-opt/GHCup/OptParse/Run.hs @@ -28,7 +28,6 @@ import Control.Exception.Safe ( MonadMask, MonadCatch ) #if !MIN_VERSION_base(4,13,0) import Control.Monad.Fail ( MonadFail ) #endif -import Codec.Archive import Control.Monad.Reader import Control.Monad.Trans.Resource import Data.Functor diff --git a/lib-opt/GHCup/OptParse/Test.hs b/lib-opt/GHCup/OptParse/Test.hs index bfa3cee..8ccdef1 100644 --- a/lib-opt/GHCup/OptParse/Test.hs +++ b/lib-opt/GHCup/OptParse/Test.hs @@ -23,7 +23,6 @@ import GHCup.Utils.Dirs import GHCup.Prelude.Logger import GHCup.Prelude.String.QQ -import Codec.Archive #if !MIN_VERSION_base(4,13,0) import Control.Monad.Fail ( MonadFail ) #endif diff --git a/lib/GHCup/Cabal.hs b/lib/GHCup/Cabal.hs index 8504539..50ad004 100644 --- a/lib/GHCup/Cabal.hs +++ b/lib/GHCup/Cabal.hs @@ -26,7 +26,6 @@ import GHCup.Prelude import GHCup.Prelude.File import GHCup.Prelude.Logger -import Codec.Archive ( ArchiveResult ) import Control.Applicative import Control.Exception.Safe import Control.Monad diff --git a/lib/GHCup/Errors.hs b/lib/GHCup/Errors.hs index 7cac935..35e7925 100644 --- a/lib/GHCup/Errors.hs +++ b/lib/GHCup/Errors.hs @@ -21,7 +21,9 @@ module GHCup.Errors where import GHCup.Types +#if !defined(TAR) import Codec.Archive +#endif import Control.Exception.Safe import Data.ByteString ( ByteString ) import Data.CaseInsensitive ( CI ) diff --git a/lib/GHCup/GHC.hs b/lib/GHCup/GHC.hs index 1f0f26c..dd6fc07 100644 --- a/lib/GHCup/GHC.hs +++ b/lib/GHCup/GHC.hs @@ -34,7 +34,6 @@ import GHCup.Prelude.String.QQ import GHCup.Prelude.Version.QQ import GHCup.Prelude.MegaParsec -import Codec.Archive ( ArchiveResult ) import Control.Applicative import Control.Concurrent ( threadDelay ) import Control.Exception.Safe diff --git a/lib/GHCup/HLS.hs b/lib/GHCup/HLS.hs index 3ac6d05..f40fbc2 100644 --- a/lib/GHCup/HLS.hs +++ b/lib/GHCup/HLS.hs @@ -30,7 +30,6 @@ import GHCup.Prelude.Logger import GHCup.Prelude.Process import GHCup.Prelude.String.QQ -import Codec.Archive ( ArchiveResult ) import Control.Applicative import Control.Exception.Safe import Control.Monad diff --git a/lib/GHCup/Stack.hs b/lib/GHCup/Stack.hs index e86bf78..0498bc5 100644 --- a/lib/GHCup/Stack.hs +++ b/lib/GHCup/Stack.hs @@ -26,7 +26,6 @@ import GHCup.Prelude import GHCup.Prelude.File import GHCup.Prelude.Logger -import Codec.Archive ( ArchiveResult ) import Control.Applicative import Control.Exception.Safe import Control.Monad diff --git a/lib/GHCup/Types.hs b/lib/GHCup/Types.hs index 4690506..427db19 100644 --- a/lib/GHCup/Types.hs +++ b/lib/GHCup/Types.hs @@ -3,6 +3,7 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} @@ -24,6 +25,7 @@ module GHCup.Types , Key(..) , Modifier(..) #endif + , ArchiveResult(..) ) where @@ -31,6 +33,11 @@ import GHCup.Types.Stack ( SetupInfo ) import {-# SOURCE #-} GHCup.Utils.Dirs ( fromGHCupPath, GHCupPath ) import Control.DeepSeq ( NFData, rnf ) +#if defined(TAR) +import Control.Exception ( Exception ) +#else +import Codec.Archive ( ArchiveResult(..) ) +#endif import Data.Map.Strict ( Map ) import Data.List.NonEmpty ( NonEmpty (..) ) import Data.Time.Calendar ( Day ) @@ -776,3 +783,13 @@ data BuildSystem = Hadrian | Make deriving (Show, Eq) +#if defined(TAR) +data ArchiveResult = ArchiveFatal + | ArchiveFailed + | ArchiveWarn + | ArchiveRetry + | ArchiveOk + | ArchiveEOF + deriving (Eq, Show, GHC.Generic, NFData, Exception) +#endif + diff --git a/lib/GHCup/Utils.hs b/lib/GHCup/Utils.hs index 6807008..3f2cb5b 100644 --- a/lib/GHCup/Utils.hs +++ b/lib/GHCup/Utils.hs @@ -49,7 +49,13 @@ import GHCup.Prelude.Logger.Internal import GHCup.Prelude.MegaParsec import GHCup.Prelude.Process import GHCup.Prelude.String.QQ +#if defined(TAR) +import Codec.Archive.Zip +import qualified Codec.Archive.Tar as Tar +import qualified Codec.Archive.Tar.Entry as Tar +#else import Codec.Archive hiding ( Directory ) +#endif import Control.Applicative import Control.Exception.Safe import Control.Monad @@ -802,11 +808,19 @@ unpackToDir dfp av = do let fn = takeFileName av lift $ logInfo $ "Unpacking: " <> T.pack fn <> " to " <> T.pack dfp +#if defined(TAR) + let untar :: MonadIO m => BL.ByteString -> Excepts '[ArchiveResult] m () + untar = liftIO . Tar.unpack dfp . Tar.read + + rf :: MonadIO m => FilePath -> Excepts '[ArchiveResult] m BL.ByteString + rf = liftIO . BL.readFile +#else let untar :: MonadIO m => BL.ByteString -> Excepts '[ArchiveResult] m () untar = lEM . liftIO . runArchiveM . unpackToDirLazy dfp rf :: MonadIO m => FilePath -> Excepts '[ArchiveResult] m BL.ByteString rf = liftIO . BL.readFile +#endif -- extract, depending on file extension if @@ -819,23 +833,42 @@ unpackToDir dfp av = do | ".tar.bz2" `isSuffixOf` fn -> liftE (untar . BZip.decompress =<< rf av) | ".tar" `isSuffixOf` fn -> liftE (untar =<< rf av) +#if defined(TAR) + | ".zip" `isSuffixOf` fn -> withArchive av (unpackInto dfp) +#else + -- libarchive supports zip | ".zip" `isSuffixOf` fn -> liftE (untar =<< rf av) +#endif | otherwise -> throwE $ UnknownArchive fn getArchiveFiles :: (MonadReader env m, HasLog env, MonadIO m, MonadThrow m) => FilePath -- ^ archive path - -> Excepts '[UnknownArchive + -> Excepts '[ UnknownArchive , ArchiveResult ] m [FilePath] getArchiveFiles av = do let fn = takeFileName av +#if defined(TAR) + let entries :: Monad m => BL.ByteString -> Excepts '[ArchiveResult] m [FilePath] + entries = + lE @ArchiveResult + . Tar.foldEntries + (\e x -> fmap (Tar.entryTarPath e :) x) + (Right []) + (\_ -> Left ArchiveFailed) + . Tar.decodeLongNames + . Tar.read + rf :: MonadIO m => FilePath -> Excepts '[ArchiveResult] m BL.ByteString + rf = liftIO . BL.readFile +#else let entries :: Monad m => BL.ByteString -> Excepts '[ArchiveResult] m [FilePath] entries = (fmap . fmap) filepath . lE . readArchiveBSL rf :: MonadIO m => FilePath -> Excepts '[ArchiveResult] m BL.ByteString rf = liftIO . BL.readFile +#endif -- extract, depending on file extension if @@ -848,7 +881,14 @@ getArchiveFiles av = do | ".tar.bz2" `isSuffixOf` fn -> liftE (entries . BZip.decompress =<< rf av) | ".tar" `isSuffixOf` fn -> liftE (entries =<< rf av) - | ".zip" `isSuffixOf` fn -> liftE (entries =<< rf av) + | ".zip" `isSuffixOf` fn -> +#if defined(TAR) + withArchive av $ do + entries' <- getEntries + pure $ fmap unEntrySelector $ Map.keys entries' +#else + liftE (entries =<< rf av) +#endif | otherwise -> throwE $ UnknownArchive fn