hasufell
/
ghcup-hs
1
1
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Re-introduce tar

This commit is contained in:
Julian Ospald 2024-01-03 00:32:23 +08:00
parent 55030d83da
commit afd7e7dc4f
No known key found for this signature in database
GPG Key ID: 4275CDA6A29BED43
15 changed files with 94 additions and 15 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
app/ghcup/BrickMain.hs
View File

@ -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)

10
cabal.project
View File

@ -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

2
cabal.project.release
View File

@ -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)

25
ghcup.cabal
View File

@ -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

1
lib-opt/GHCup/OptParse/Compile.hs
View File

@ -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

1
lib-opt/GHCup/OptParse/Install.hs
View File

@ -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

1
lib-opt/GHCup/OptParse/Run.hs
View File

@ -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

1
lib-opt/GHCup/OptParse/Test.hs
View File

@ -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

1
lib/GHCup/Cabal.hs
View File

@ -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

2
lib/GHCup/Errors.hs
View File

@ -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 )

1
lib/GHCup/GHC.hs
View File

@ -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

1
lib/GHCup/HLS.hs
View File

@ -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

1
lib/GHCup/Stack.hs
View File

@ -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

17
lib/GHCup/Types.hs
View File

@ -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

44
lib/GHCup/Utils.hs
View File

@ -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