Skip to content

Commit 6ae312c

Browse files
hasufellhasufell
committed
Merge remote-tracking branch 'origin/tar'
2 parents f6cf4cb + 856e48a commit 6ae312c

17 files changed

+235
-113
lines changed

‎app/ghcup/BrickMain.hs

-1
Original file line numberDiff line numberDiff line change
@@ -44,7 +44,6 @@ import Brick.Widgets.Center ( center, centerLayer )
4444
import qualified Brick.Widgets.List as L
4545
import Brick.Focus (FocusRing)
4646
import qualified Brick.Focus as F
47-
import Codec.Archive
4847
import Control.Applicative
4948
import Control.Exception.Safe
5049
#if !MIN_VERSION_base(4,13,0)

‎cabal.project

+9-1
Original file line numberDiff line numberDiff line change
@@ -3,7 +3,7 @@ packages: ./ghcup.cabal
33
optional-packages: ./vendored/*/*.cabal
44

55
package ghcup
6-
flags: +tui
6+
flags: +tui +tar
77

88
constraints: http-io-streams -brotli,
99
any.aeson >= 2.0.1.0
@@ -13,6 +13,11 @@ source-repository-package
1313
location: https://github.com/fosskers/versions.git
1414
tag: 7bc3355348aac3510771d4622aff09ac38c9924d
1515

16+
source-repository-package
17+
type: git
18+
location: https://github.com/haskell/tar.git
19+
tag: d94a988be4311b830149a9f8fc16739927e5fc1c
20+
1621
package libarchive
1722
flags: -system-libarchive
1823

@@ -30,3 +35,6 @@ package streamly
3035

3136
package *
3237
test-show-details: direct
38+
39+
allow-newer: cabal-install-parsers:tar
40+

‎cabal.project.release

+1-1
Original file line numberDiff line numberDiff line change
@@ -5,7 +5,7 @@ optional-packages: ./vendored/*/*.cabal
55
optimization: 2
66

77
package ghcup
8-
flags: +tui
8+
flags: +tui -tar
99

1010
if os(linux)
1111
if arch(x86_64) || arch(i386)

‎ghcup.cabal

+25-2
Original file line numberDiff line numberDiff line change
@@ -53,6 +53,11 @@ flag no-exe
5353
default: False
5454
manual: True
5555

56+
flag tar
57+
description: Use haskell tar instead of libarchive.
58+
default: False
59+
manual: True
60+
5661
common app-common-depends
5762
build-depends:
5863
, aeson >=1.4
@@ -68,7 +73,6 @@ common app-common-depends
6873
, filepath ^>=1.4.2.1
6974
, haskus-utils-types ^>=1.5
7075
, haskus-utils-variant ^>=3.2.1
71-
, libarchive ^>=3.0.3.0
7276
, megaparsec >=8.0.0 && <9.3
7377
, mtl ^>=2.2
7478
, optparse-applicative >=0.15.1.0 && <0.18
@@ -90,6 +94,15 @@ common app-common-depends
9094
, versions >=6.0.3 && <6.1
9195
, yaml-streamly ^>=0.12.0
9296

97+
if flag(tar)
98+
cpp-options: -DTAR
99+
build-depends:
100+
tar ^>=0.6.0.0
101+
, zip ^>=2.0.0
102+
103+
else
104+
build-depends: libarchive ^>=3.0.3.0
105+
93106
library
94107
exposed-modules:
95108
GHCup
@@ -122,6 +135,8 @@ library
122135
GHCup.Types.Stack
123136
GHCup.Utils
124137
GHCup.Utils.Dirs
138+
GHCup.Utils.Tar
139+
GHCup.Utils.Tar.Types
125140
GHCup.Version
126141

127142
hs-source-dirs: lib
@@ -166,7 +181,6 @@ library
166181
, filepath ^>=1.4.2.1
167182
, haskus-utils-types ^>=1.5
168183
, haskus-utils-variant ^>=3.2.1
169-
, libarchive ^>=3.0.3.0
170184
, lzma-static ^>=5.2.5.3
171185
, megaparsec >=8.0.0 && <9.3
172186
, mtl ^>=2.2
@@ -196,6 +210,15 @@ library
196210
, yaml-streamly ^>=0.12.0
197211
, zlib ^>=0.6.2.2
198212

213+
if flag(tar)
214+
cpp-options: -DTAR
215+
build-depends:
216+
tar ^>=0.6.0.0
217+
, zip ^>=2.0.0
218+
219+
else
220+
build-depends: libarchive ^>=3.0.3.0
221+
199222
if (flag(internal-downloader) && !os(windows))
200223
exposed-modules: GHCup.Download.IOStreams
201224
cpp-options: -DINTERNAL_DOWNLOADER

‎lib-opt/GHCup/OptParse/Compile.hs

-1
Original file line numberDiff line numberDiff line change
@@ -25,7 +25,6 @@ import GHCup.OptParse.Common
2525
#if !MIN_VERSION_base(4,13,0)
2626
import Control.Monad.Fail ( MonadFail )
2727
#endif
28-
import Codec.Archive ( ArchiveResult )
2928
import Control.Concurrent (threadDelay)
3029
import Control.Monad.Reader
3130
import Control.Monad.Trans.Resource

‎lib-opt/GHCup/OptParse/Install.hs

-1
Original file line numberDiff line numberDiff line change
@@ -24,7 +24,6 @@ import GHCup.Prelude
2424
import GHCup.Prelude.Logger
2525
import GHCup.Prelude.String.QQ
2626

27-
import Codec.Archive
2827
#if !MIN_VERSION_base(4,13,0)
2928
import Control.Monad.Fail ( MonadFail )
3029
#endif

‎lib-opt/GHCup/OptParse/Run.hs

-1
Original file line numberDiff line numberDiff line change
@@ -28,7 +28,6 @@ import Control.Exception.Safe ( MonadMask, MonadCatch )
2828
#if !MIN_VERSION_base(4,13,0)
2929
import Control.Monad.Fail ( MonadFail )
3030
#endif
31-
import Codec.Archive
3231
import Control.Monad.Reader
3332
import Control.Monad.Trans.Resource
3433
import Data.Functor

‎lib-opt/GHCup/OptParse/Test.hs

-1
Original file line numberDiff line numberDiff line change
@@ -23,7 +23,6 @@ import GHCup.Utils.Dirs
2323
import GHCup.Prelude.Logger
2424
import GHCup.Prelude.String.QQ
2525

26-
import Codec.Archive
2726
#if !MIN_VERSION_base(4,13,0)
2827
import Control.Monad.Fail ( MonadFail )
2928
#endif

‎lib/GHCup/Cabal.hs

-1
Original file line numberDiff line numberDiff line change
@@ -26,7 +26,6 @@ import GHCup.Prelude
2626
import GHCup.Prelude.File
2727
import GHCup.Prelude.Logger
2828

29-
import Codec.Archive ( ArchiveResult )
3029
import Control.Applicative
3130
import Control.Exception.Safe
3231
import Control.Monad

‎lib/GHCup/Errors.hs

-1
Original file line numberDiff line numberDiff line change
@@ -21,7 +21,6 @@ module GHCup.Errors where
2121

2222
import GHCup.Types
2323

24-
import Codec.Archive
2524
import Control.Exception.Safe
2625
import Data.ByteString ( ByteString )
2726
import Data.CaseInsensitive ( CI )

‎lib/GHCup/GHC.hs

-1
Original file line numberDiff line numberDiff line change
@@ -34,7 +34,6 @@ import GHCup.Prelude.String.QQ
3434
import GHCup.Prelude.Version.QQ
3535
import GHCup.Prelude.MegaParsec
3636

37-
import Codec.Archive ( ArchiveResult )
3837
import Control.Applicative
3938
import Control.Concurrent ( threadDelay )
4039
import Control.Exception.Safe

‎lib/GHCup/HLS.hs

-1
Original file line numberDiff line numberDiff line change
@@ -30,7 +30,6 @@ import GHCup.Prelude.Logger
3030
import GHCup.Prelude.Process
3131
import GHCup.Prelude.String.QQ
3232

33-
import Codec.Archive ( ArchiveResult )
3433
import Control.Applicative
3534
import Control.Exception.Safe
3635
import Control.Monad

‎lib/GHCup/Stack.hs

-1
Original file line numberDiff line numberDiff line change
@@ -26,7 +26,6 @@ import GHCup.Prelude
2626
import GHCup.Prelude.File
2727
import GHCup.Prelude.Logger
2828

29-
import Codec.Archive ( ArchiveResult )
3029
import Control.Applicative
3130
import Control.Exception.Safe
3231
import Control.Monad

‎lib/GHCup/Types.hs

+2-1
Original file line numberDiff line numberDiff line change
@@ -24,10 +24,12 @@ module GHCup.Types
2424
, Key(..)
2525
, Modifier(..)
2626
#endif
27+
, ArchiveResult(..)
2728
)
2829
where
2930

3031
import GHCup.Types.Stack ( SetupInfo )
32+
import GHCup.Utils.Tar.Types ( ArchiveResult(..) )
3133
import {-# SOURCE #-} GHCup.Utils.Dirs ( fromGHCupPath, GHCupPath )
3234

3335
import Control.DeepSeq ( NFData, rnf )
@@ -775,4 +777,3 @@ instance Pretty ToolVersion where
775777
data BuildSystem = Hadrian
776778
| Make
777779
deriving (Show, Eq)
778-

‎lib/GHCup/Utils.hs

+24-98
Original file line numberDiff line numberDiff line change
@@ -21,6 +21,7 @@ installation and introspection of files/versions etc.
2121
-}
2222
module GHCup.Utils
2323
( module GHCup.Utils.Dirs
24+
, module GHCup.Utils.Tar
2425
, module GHCup.Utils
2526
#if defined(IS_WINDOWS)
2627
, module GHCup.Prelude.Windows
@@ -42,14 +43,14 @@ import GHCup.Types
4243
import GHCup.Types.Optics
4344
import GHCup.Types.JSON ( )
4445
import GHCup.Utils.Dirs
46+
import GHCup.Utils.Tar
4547
import GHCup.Version
4648
import GHCup.Prelude
4749
import GHCup.Prelude.File
4850
import GHCup.Prelude.Logger.Internal
4951
import GHCup.Prelude.MegaParsec
5052
import GHCup.Prelude.Process
5153
import GHCup.Prelude.String.QQ
52-
import Codec.Archive hiding ( Directory )
5354
import Control.Applicative
5455
import Control.Exception.Safe
5556
import Control.Monad
@@ -79,10 +80,6 @@ import Text.Regex.Posix
7980
import Text.PrettyPrint.HughesPJClass (prettyShow)
8081
import URI.ByteString
8182

82-
import qualified Codec.Compression.BZip as BZip
83-
import qualified Codec.Compression.GZip as GZip
84-
import qualified Codec.Compression.Lzma as Lzma
85-
import qualified Data.ByteString.Lazy as BL
8683
import qualified Data.Map.Strict as Map
8784
import qualified Data.Text as T
8885
import qualified Data.Text.Encoding as E
@@ -783,99 +780,6 @@ getLatestToolFor tool target pvpIn dls = do
783780

784781

785782

786-
787-
788-
-----------------
789-
--[ Unpacking ]--
790-
-----------------
791-
792-
793-
794-
-- | Unpack an archive to a temporary directory and return that path.
795-
unpackToDir :: (MonadReader env m, HasLog env, MonadIO m, MonadThrow m)
796-
=> FilePath -- ^ destination dir
797-
-> FilePath -- ^ archive path
798-
-> Excepts '[UnknownArchive
799-
, ArchiveResult
800-
] m ()
801-
unpackToDir dfp av = do
802-
let fn = takeFileName av
803-
lift $ logInfo $ "Unpacking: " <> T.pack fn <> " to " <> T.pack dfp
804-
805-
let untar :: MonadIO m => BL.ByteString -> Excepts '[ArchiveResult] m ()
806-
untar = lEM . liftIO . runArchiveM . unpackToDirLazy dfp
807-
808-
rf :: MonadIO m => FilePath -> Excepts '[ArchiveResult] m BL.ByteString
809-
rf = liftIO . BL.readFile
810-
811-
-- extract, depending on file extension
812-
if
813-
| ".tar.gz" `isSuffixOf` fn -> liftE
814-
(untar . GZip.decompress =<< rf av)
815-
| ".tar.xz" `isSuffixOf` fn -> do
816-
filecontents <- liftE $ rf av
817-
let decompressed = Lzma.decompressWith (Lzma.defaultDecompressParams { Lzma.decompressAutoDecoder= True }) filecontents
818-
liftE $ untar decompressed
819-
| ".tar.bz2" `isSuffixOf` fn ->
820-
liftE (untar . BZip.decompress =<< rf av)
821-
| ".tar" `isSuffixOf` fn -> liftE (untar =<< rf av)
822-
| ".zip" `isSuffixOf` fn -> liftE (untar =<< rf av)
823-
| otherwise -> throwE $ UnknownArchive fn
824-
825-
826-
getArchiveFiles :: (MonadReader env m, HasLog env, MonadIO m, MonadThrow m)
827-
=> FilePath -- ^ archive path
828-
-> Excepts '[UnknownArchive
829-
, ArchiveResult
830-
] m [FilePath]
831-
getArchiveFiles av = do
832-
let fn = takeFileName av
833-
834-
let entries :: Monad m => BL.ByteString -> Excepts '[ArchiveResult] m [FilePath]
835-
entries = (fmap . fmap) filepath . lE . readArchiveBSL
836-
837-
rf :: MonadIO m => FilePath -> Excepts '[ArchiveResult] m BL.ByteString
838-
rf = liftIO . BL.readFile
839-
840-
-- extract, depending on file extension
841-
if
842-
| ".tar.gz" `isSuffixOf` fn -> liftE
843-
(entries . GZip.decompress =<< rf av)
844-
| ".tar.xz" `isSuffixOf` fn -> do
845-
filecontents <- liftE $ rf av
846-
let decompressed = Lzma.decompressWith (Lzma.defaultDecompressParams { Lzma.decompressAutoDecoder= True }) filecontents
847-
liftE $ entries decompressed
848-
| ".tar.bz2" `isSuffixOf` fn ->
849-
liftE (entries . BZip.decompress =<< rf av)
850-
| ".tar" `isSuffixOf` fn -> liftE (entries =<< rf av)
851-
| ".zip" `isSuffixOf` fn -> liftE (entries =<< rf av)
852-
| otherwise -> throwE $ UnknownArchive fn
853-
854-
855-
intoSubdir :: (MonadReader env m, HasLog env, MonadIO m, MonadThrow m, MonadCatch m)
856-
=> GHCupPath -- ^ unpacked tar dir
857-
-> TarDir -- ^ how to descend
858-
-> Excepts '[TarDirDoesNotExist] m GHCupPath
859-
intoSubdir bdir tardir = case tardir of
860-
RealDir pr -> do
861-
whenM (fmap not . liftIO . doesDirectoryExist $ fromGHCupPath (bdir `appendGHCupPath` pr))
862-
(throwE $ TarDirDoesNotExist tardir)
863-
pure (bdir `appendGHCupPath` pr)
864-
RegexDir r -> do
865-
let rs = split (`elem` pathSeparators) r
866-
foldlM
867-
(\y x ->
868-
(handleIO (\_ -> pure []) . liftIO . findFiles (fromGHCupPath y) . regex $ x) >>= (\case
869-
[] -> throwE $ TarDirDoesNotExist tardir
870-
(p : _) -> pure (y `appendGHCupPath` p)) . sort
871-
)
872-
bdir
873-
rs
874-
where regex = makeRegexOpts compIgnoreCase execBlank
875-
876-
877-
878-
879783
------------
880784
--[ Tags ]--
881785
------------
@@ -929,6 +833,28 @@ getLatestBaseVersion av pvpVer =
929833
--[ Other ]--
930834
-------------
931835

836+
837+
intoSubdir :: (MonadReader env m, HasLog env, MonadIO m, MonadThrow m, MonadCatch m)
838+
=> GHCupPath -- ^ unpacked tar dir
839+
-> TarDir -- ^ how to descend
840+
-> Excepts '[TarDirDoesNotExist] m GHCupPath
841+
intoSubdir bdir tardir = case tardir of
842+
RealDir pr -> do
843+
whenM (fmap not . liftIO . doesDirectoryExist $ fromGHCupPath (bdir `appendGHCupPath` pr))
844+
(throwE $ TarDirDoesNotExist tardir)
845+
pure (bdir `appendGHCupPath` pr)
846+
RegexDir r -> do
847+
let rs = split (`elem` pathSeparators) r
848+
foldlM
849+
(\y x ->
850+
(handleIO (\_ -> pure []) . liftIO . findFiles (fromGHCupPath y) . regex $ x) >>= (\case
851+
[] -> throwE $ TarDirDoesNotExist tardir
852+
(p : _) -> pure (y `appendGHCupPath` p)) . sort
853+
)
854+
bdir
855+
rs
856+
where regex = makeRegexOpts compIgnoreCase execBlank
857+
932858
-- | Usually @~\/.ghcup\/ghc\/\<ver\>\/bin\/@
933859
ghcInternalBinDir :: (MonadReader env m, HasDirs env, MonadThrow m, MonadFail m, MonadIO m)
934860
=> GHCTargetVersion

0 commit comments

Comments
 (0)