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..c2ef031 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 @@ -122,6 +135,8 @@ library GHCup.Types.Stack GHCup.Utils GHCup.Utils.Dirs + GHCup.Utils.Tar + GHCup.Utils.Tar.Types GHCup.Version hs-source-dirs: lib @@ -166,7 +181,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 +210,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 84fe860..cd3138f 100644 --- a/lib/GHCup/Errors.hs +++ b/lib/GHCup/Errors.hs @@ -21,7 +21,6 @@ module GHCup.Errors where import GHCup.Types -import Codec.Archive 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..fa8a65d 100644 --- a/lib/GHCup/Types.hs +++ b/lib/GHCup/Types.hs @@ -24,10 +24,12 @@ module GHCup.Types , Key(..) , Modifier(..) #endif + , ArchiveResult(..) ) where import GHCup.Types.Stack ( SetupInfo ) +import GHCup.Utils.Tar.Types ( ArchiveResult(..) ) import {-# SOURCE #-} GHCup.Utils.Dirs ( fromGHCupPath, GHCupPath ) import Control.DeepSeq ( NFData, rnf ) @@ -775,4 +777,3 @@ instance Pretty ToolVersion where data BuildSystem = Hadrian | Make deriving (Show, Eq) - diff --git a/lib/GHCup/Utils.hs b/lib/GHCup/Utils.hs index 6807008..c8b2b22 100644 --- a/lib/GHCup/Utils.hs +++ b/lib/GHCup/Utils.hs @@ -21,6 +21,7 @@ installation and introspection of files/versions etc. -} module GHCup.Utils ( module GHCup.Utils.Dirs + , module GHCup.Utils.Tar , module GHCup.Utils #if defined(IS_WINDOWS) , module GHCup.Prelude.Windows @@ -42,6 +43,7 @@ import GHCup.Types import GHCup.Types.Optics import GHCup.Types.JSON ( ) import GHCup.Utils.Dirs +import GHCup.Utils.Tar import GHCup.Version import GHCup.Prelude import GHCup.Prelude.File @@ -49,7 +51,6 @@ import GHCup.Prelude.Logger.Internal import GHCup.Prelude.MegaParsec import GHCup.Prelude.Process import GHCup.Prelude.String.QQ -import Codec.Archive hiding ( Directory ) import Control.Applicative import Control.Exception.Safe import Control.Monad @@ -79,10 +80,6 @@ import Text.Regex.Posix import Text.PrettyPrint.HughesPJClass (prettyShow) import URI.ByteString -import qualified Codec.Compression.BZip as BZip -import qualified Codec.Compression.GZip as GZip -import qualified Codec.Compression.Lzma as Lzma -import qualified Data.ByteString.Lazy as BL import qualified Data.Map.Strict as Map import qualified Data.Text as T import qualified Data.Text.Encoding as E @@ -783,99 +780,6 @@ getLatestToolFor tool target pvpIn dls = do - - - ----------------- - --[ Unpacking ]-- - ----------------- - - - --- | Unpack an archive to a temporary directory and return that path. -unpackToDir :: (MonadReader env m, HasLog env, MonadIO m, MonadThrow m) - => FilePath -- ^ destination dir - -> FilePath -- ^ archive path - -> Excepts '[UnknownArchive - , ArchiveResult - ] m () -unpackToDir dfp av = do - let fn = takeFileName av - lift $ logInfo $ "Unpacking: " <> T.pack fn <> " to " <> T.pack dfp - - 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 - - -- extract, depending on file extension - if - | ".tar.gz" `isSuffixOf` fn -> liftE - (untar . GZip.decompress =<< rf av) - | ".tar.xz" `isSuffixOf` fn -> do - filecontents <- liftE $ rf av - let decompressed = Lzma.decompressWith (Lzma.defaultDecompressParams { Lzma.decompressAutoDecoder= True }) filecontents - liftE $ untar decompressed - | ".tar.bz2" `isSuffixOf` fn -> - liftE (untar . BZip.decompress =<< rf av) - | ".tar" `isSuffixOf` fn -> liftE (untar =<< rf av) - | ".zip" `isSuffixOf` fn -> liftE (untar =<< rf av) - | otherwise -> throwE $ UnknownArchive fn - - -getArchiveFiles :: (MonadReader env m, HasLog env, MonadIO m, MonadThrow m) - => FilePath -- ^ archive path - -> Excepts '[UnknownArchive - , ArchiveResult - ] m [FilePath] -getArchiveFiles av = do - let fn = takeFileName av - - 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 - - -- extract, depending on file extension - if - | ".tar.gz" `isSuffixOf` fn -> liftE - (entries . GZip.decompress =<< rf av) - | ".tar.xz" `isSuffixOf` fn -> do - filecontents <- liftE $ rf av - let decompressed = Lzma.decompressWith (Lzma.defaultDecompressParams { Lzma.decompressAutoDecoder= True }) filecontents - liftE $ entries decompressed - | ".tar.bz2" `isSuffixOf` fn -> - liftE (entries . BZip.decompress =<< rf av) - | ".tar" `isSuffixOf` fn -> liftE (entries =<< rf av) - | ".zip" `isSuffixOf` fn -> liftE (entries =<< rf av) - | otherwise -> throwE $ UnknownArchive fn - - -intoSubdir :: (MonadReader env m, HasLog env, MonadIO m, MonadThrow m, MonadCatch m) - => GHCupPath -- ^ unpacked tar dir - -> TarDir -- ^ how to descend - -> Excepts '[TarDirDoesNotExist] m GHCupPath -intoSubdir bdir tardir = case tardir of - RealDir pr -> do - whenM (fmap not . liftIO . doesDirectoryExist $ fromGHCupPath (bdir `appendGHCupPath` pr)) - (throwE $ TarDirDoesNotExist tardir) - pure (bdir `appendGHCupPath` pr) - RegexDir r -> do - let rs = split (`elem` pathSeparators) r - foldlM - (\y x -> - (handleIO (\_ -> pure []) . liftIO . findFiles (fromGHCupPath y) . regex $ x) >>= (\case - [] -> throwE $ TarDirDoesNotExist tardir - (p : _) -> pure (y `appendGHCupPath` p)) . sort - ) - bdir - rs - where regex = makeRegexOpts compIgnoreCase execBlank - - - - ------------ --[ Tags ]-- ------------ @@ -929,6 +833,28 @@ getLatestBaseVersion av pvpVer = --[ Other ]-- ------------- + +intoSubdir :: (MonadReader env m, HasLog env, MonadIO m, MonadThrow m, MonadCatch m) + => GHCupPath -- ^ unpacked tar dir + -> TarDir -- ^ how to descend + -> Excepts '[TarDirDoesNotExist] m GHCupPath +intoSubdir bdir tardir = case tardir of + RealDir pr -> do + whenM (fmap not . liftIO . doesDirectoryExist $ fromGHCupPath (bdir `appendGHCupPath` pr)) + (throwE $ TarDirDoesNotExist tardir) + pure (bdir `appendGHCupPath` pr) + RegexDir r -> do + let rs = split (`elem` pathSeparators) r + foldlM + (\y x -> + (handleIO (\_ -> pure []) . liftIO . findFiles (fromGHCupPath y) . regex $ x) >>= (\case + [] -> throwE $ TarDirDoesNotExist tardir + (p : _) -> pure (y `appendGHCupPath` p)) . sort + ) + bdir + rs + where regex = makeRegexOpts compIgnoreCase execBlank + -- | Usually @~\/.ghcup\/ghc\/\\/bin\/@ ghcInternalBinDir :: (MonadReader env m, HasDirs env, MonadThrow m, MonadFail m, MonadIO m) => GHCTargetVersion diff --git a/lib/GHCup/Utils/Tar.hs b/lib/GHCup/Utils/Tar.hs new file mode 100644 index 0000000..4d17974 --- /dev/null +++ b/lib/GHCup/Utils/Tar.hs @@ -0,0 +1,141 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} + +{-| +Module : GHCup.Utils.Tar +Description : GHCup tar abstractions +Copyright : (c) Julian Ospald, 2024 +License : LGPL-3.0 +Maintainer : hasufell@hasufell.de +Stability : experimental +Portability : portable +-} +module GHCup.Utils.Tar where + +import GHCup.Utils.Tar.Types ( ArchiveResult(..) ) +import GHCup.Errors +import GHCup.Prelude +import GHCup.Prelude.Logger.Internal +import GHCup.Types.Optics + +import Control.Monad.Catch (MonadThrow) +import Control.Monad.Reader +import Data.List +import Haskus.Utils.Variant.Excepts +import System.FilePath + +#if defined(TAR) +import Codec.Archive.Zip +import qualified Codec.Archive.Tar as Tar +import qualified Codec.Archive.Tar.Entry as Tar +import qualified Data.Map.Strict as Map +#else +import Codec.Archive hiding ( Directory + , ArchiveResult -- imported from "GHCup.Utils.Tar.Types" + ) +#endif + +import qualified Codec.Compression.BZip as BZip +import qualified Codec.Compression.GZip as GZip +import qualified Codec.Compression.Lzma as Lzma +import qualified Data.ByteString.Lazy as BL +import qualified Data.Text as T + + +-- | Unpack an archive to a given directory. +unpackToDir :: (MonadReader env m, HasLog env, MonadIO m, MonadThrow m) + => FilePath -- ^ destination dir + -> FilePath -- ^ archive path + -> Excepts '[UnknownArchive + , ArchiveResult + ] m () +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 + | ".tar.gz" `isSuffixOf` fn -> liftE + (untar . GZip.decompress =<< rf av) + | ".tar.xz" `isSuffixOf` fn -> do + filecontents <- liftE $ rf av + let decompressed = Lzma.decompressWith (Lzma.defaultDecompressParams { Lzma.decompressAutoDecoder= True }) filecontents + liftE $ untar decompressed + | ".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 + + +-- | Get all files from an archive. +getArchiveFiles :: (MonadReader env m, HasLog env, MonadIO m, MonadThrow m) + => FilePath -- ^ archive path + -> 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 + | ".tar.gz" `isSuffixOf` fn -> liftE + (entries . GZip.decompress =<< rf av) + | ".tar.xz" `isSuffixOf` fn -> do + filecontents <- liftE $ rf av + let decompressed = Lzma.decompressWith (Lzma.defaultDecompressParams { Lzma.decompressAutoDecoder= True }) filecontents + liftE $ entries decompressed + | ".tar.bz2" `isSuffixOf` fn -> + liftE (entries . BZip.decompress =<< rf av) + | ".tar" `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 + diff --git a/lib/GHCup/Utils/Tar/Types.hs b/lib/GHCup/Utils/Tar/Types.hs new file mode 100644 index 0000000..72fe645 --- /dev/null +++ b/lib/GHCup/Utils/Tar/Types.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE CPP #-} +#if defined(TAR) +{-# LANGUAGE DeriveGeneric #-} +#endif + +module GHCup.Utils.Tar.Types + ( ArchiveResult(..) + ) + where + +#if defined(TAR) + +import Control.Exception ( Exception ) +import Control.DeepSeq ( NFData ) +import qualified GHC.Generics as GHC + +data ArchiveResult = ArchiveFatal + | ArchiveFailed + | ArchiveWarn + | ArchiveRetry + | ArchiveOk + | ArchiveEOF + deriving (Eq, Show, GHC.Generic) + +instance NFData ArchiveResult + +instance Exception ArchiveResult + +#else + +import Codec.Archive ( ArchiveResult(..) ) + +#endif