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

Re-introduce tar

Browse Source
This commit is contained in:
Julian Ospald
2024-01-03 00:32:23 +08:00
parent 55030d83da
commit afd7e7dc4f
15 changed files with 94 additions and 15 deletions
Download Patch File Download Diff File Expand all files Collapse all files

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