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

Merge remote-tracking branch 'origin/tar'

This commit is contained in:
Julian Ospald 2024-01-20 16:55:46 +08:00
parent f6cf4cb90c 856e48aa14
commit 6ae312c1f9
No known key found for this signature in database
GPG Key ID: 4275CDA6A29BED43
17 changed files with 235 additions and 113 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)

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

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

1
lib/GHCup/Errors.hs
View File

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

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

3
lib/GHCup/Types.hs
View File

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

122
lib/GHCup/Utils.hs
View File

@ -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\/\<ver\>\/bin\/@
ghcInternalBinDir :: (MonadReader env m, HasDirs env, MonadThrow m, MonadFail m, MonadIO m)
=> GHCTargetVersion

141
lib/GHCup/Utils/Tar.hs Normal file
View File

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

33
lib/GHCup/Utils/Tar/Types.hs Normal file
View File

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