From afd7e7dc4f4e51c700f5e1673835cbe9dbba5b29 Mon Sep 17 00:00:00 2001 From: Julian Ospald Date: Wed, 3 Jan 2024 00:32:23 +0800 Subject: [PATCH 1/5] 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 From 2ece023c0f702dedb8b33a05071331ac3f126c5e Mon Sep 17 00:00:00 2001 From: Julian Ospald Date: Sun, 7 Jan 2024 22:03:06 +0800 Subject: [PATCH 2/5] Fix coding suggestions --- ghcup.cabal | 1 + lib/GHCup/Types.hs | 8 +- lib/GHCup/Utils.hs | 162 ++++++----------------------------------- lib/GHCup/Utils/Tar.hs | 139 +++++++++++++++++++++++++++++++++++ 4 files changed, 170 insertions(+), 140 deletions(-) create mode 100644 lib/GHCup/Utils/Tar.hs diff --git a/ghcup.cabal b/ghcup.cabal index 6cd5332..169c25b 100644 --- a/ghcup.cabal +++ b/ghcup.cabal @@ -135,6 +135,7 @@ library GHCup.Types.Stack GHCup.Utils GHCup.Utils.Dirs + GHCup.Utils.Tar GHCup.Version hs-source-dirs: lib diff --git a/lib/GHCup/Types.hs b/lib/GHCup/Types.hs index 427db19..aac45af 100644 --- a/lib/GHCup/Types.hs +++ b/lib/GHCup/Types.hs @@ -3,7 +3,6 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} @@ -790,6 +789,11 @@ data ArchiveResult = ArchiveFatal | ArchiveRetry | ArchiveOk | ArchiveEOF - deriving (Eq, Show, GHC.Generic, NFData, Exception) + deriving (Eq, Show, GHC.Generic) + +instance NFData ArchiveResult + +instance Exception ArchiveResult + #endif diff --git a/lib/GHCup/Utils.hs b/lib/GHCup/Utils.hs index 3f2cb5b..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,13 +51,6 @@ 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 @@ -85,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 @@ -789,133 +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 - -#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 - - -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 - - -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 ]-- ------------ @@ -969,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..9d2eab1 --- /dev/null +++ b/lib/GHCup/Utils/Tar.hs @@ -0,0 +1,139 @@ +{-# 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.Types +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 +#else +import Codec.Archive hiding ( Directory ) +#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.Map.Strict as Map +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 + From 87ec8c756f324bcb4741868f0a1d2a4b1f731e7d Mon Sep 17 00:00:00 2001 From: "Rune K. Svendsen" Date: Tue, 9 Jan 2024 10:19:58 +0100 Subject: [PATCH 3/5] Move ArchiveResult into GHCup.Utils.Tar.Types So a module that wants to import ArchiveResult doesn't have to worry about CPP. --- ghcup.cabal | 1 + lib/GHCup/Errors.hs | 3 --- lib/GHCup/Types.hs | 22 +--------------------- lib/GHCup/Utils/Tar.hs | 6 ++++-- lib/GHCup/Utils/Tar/Types.hs | 31 +++++++++++++++++++++++++++++++ 5 files changed, 37 insertions(+), 26 deletions(-) create mode 100644 lib/GHCup/Utils/Tar/Types.hs diff --git a/ghcup.cabal b/ghcup.cabal index 169c25b..c2ef031 100644 --- a/ghcup.cabal +++ b/ghcup.cabal @@ -136,6 +136,7 @@ library GHCup.Utils GHCup.Utils.Dirs GHCup.Utils.Tar + GHCup.Utils.Tar.Types GHCup.Version hs-source-dirs: lib diff --git a/lib/GHCup/Errors.hs b/lib/GHCup/Errors.hs index 35e7925..a923096 100644 --- a/lib/GHCup/Errors.hs +++ b/lib/GHCup/Errors.hs @@ -21,9 +21,6 @@ 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/Types.hs b/lib/GHCup/Types.hs index aac45af..fa8a65d 100644 --- a/lib/GHCup/Types.hs +++ b/lib/GHCup/Types.hs @@ -29,14 +29,10 @@ module GHCup.Types where import GHCup.Types.Stack ( SetupInfo ) +import GHCup.Utils.Tar.Types ( ArchiveResult(..) ) 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 ) @@ -781,19 +777,3 @@ instance Pretty ToolVersion where data BuildSystem = Hadrian | Make deriving (Show, Eq) - -#if defined(TAR) -data ArchiveResult = ArchiveFatal - | ArchiveFailed - | ArchiveWarn - | ArchiveRetry - | ArchiveOk - | ArchiveEOF - deriving (Eq, Show, GHC.Generic) - -instance NFData ArchiveResult - -instance Exception ArchiveResult - -#endif - diff --git a/lib/GHCup/Utils/Tar.hs b/lib/GHCup/Utils/Tar.hs index 9d2eab1..355ee5a 100644 --- a/lib/GHCup/Utils/Tar.hs +++ b/lib/GHCup/Utils/Tar.hs @@ -14,7 +14,7 @@ Portability : portable -} module GHCup.Utils.Tar where -import GHCup.Types +import GHCup.Utils.Tar.Types ( ArchiveResult(..) ) import GHCup.Errors import GHCup.Prelude import GHCup.Prelude.Logger.Internal @@ -31,7 +31,9 @@ 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 ) +import Codec.Archive hiding ( Directory + , ArchiveResult -- imported from "GHCup.Utils.Tar.Types" + ) #endif import qualified Codec.Compression.BZip as BZip diff --git a/lib/GHCup/Utils/Tar/Types.hs b/lib/GHCup/Utils/Tar/Types.hs new file mode 100644 index 0000000..4dcddfc --- /dev/null +++ b/lib/GHCup/Utils/Tar/Types.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveGeneric #-} + +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 From 2cafd9d2bc01bb228dcfd9f1cefd9c15e71e2498 Mon Sep 17 00:00:00 2001 From: "Rune K. Svendsen" Date: Tue, 9 Jan 2024 10:22:51 +0100 Subject: [PATCH 4/5] Fix redundant import warning --- lib/GHCup/Utils/Tar.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lib/GHCup/Utils/Tar.hs b/lib/GHCup/Utils/Tar.hs index 355ee5a..4d17974 100644 --- a/lib/GHCup/Utils/Tar.hs +++ b/lib/GHCup/Utils/Tar.hs @@ -30,6 +30,7 @@ import System.FilePath 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" @@ -40,7 +41,6 @@ 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 From 856e48aa14cff68ea4a6eb4409224aa87ae396e6 Mon Sep 17 00:00:00 2001 From: "Rune K. Svendsen" Date: Tue, 9 Jan 2024 10:26:46 +0100 Subject: [PATCH 5/5] Make HLint happy --- lib/GHCup/Utils/Tar/Types.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/lib/GHCup/Utils/Tar/Types.hs b/lib/GHCup/Utils/Tar/Types.hs index 4dcddfc..72fe645 100644 --- a/lib/GHCup/Utils/Tar/Types.hs +++ b/lib/GHCup/Utils/Tar/Types.hs @@ -1,5 +1,7 @@ {-# LANGUAGE CPP #-} +#if defined(TAR) {-# LANGUAGE DeriveGeneric #-} +#endif module GHCup.Utils.Tar.Types ( ArchiveResult(..)