Fix coding suggestions
This commit is contained in:
parent
afd7e7dc4f
commit
2ece023c0f
@ -135,6 +135,7 @@ library
|
||||
GHCup.Types.Stack
|
||||
GHCup.Utils
|
||||
GHCup.Utils.Dirs
|
||||
GHCup.Utils.Tar
|
||||
GHCup.Version
|
||||
|
||||
hs-source-dirs: lib
|
||||
|
||||
@ -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
|
||||
|
||||
|
||||
@ -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\/\<ver\>\/bin\/@
|
||||
ghcInternalBinDir :: (MonadReader env m, HasDirs env, MonadThrow m, MonadFail m, MonadIO m)
|
||||
=> GHCTargetVersion
|
||||
|
||||
139
lib/GHCup/Utils/Tar.hs
Normal file
139
lib/GHCup/Utils/Tar.hs
Normal file
@ -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
|
||||
|
||||
Loading…
Reference in New Issue
Block a user