From 2ece023c0f702dedb8b33a05071331ac3f126c5e Mon Sep 17 00:00:00 2001 From: Julian Ospald Date: Sun, 7 Jan 2024 22:03:06 +0800 Subject: [PATCH] Fix coding suggestions --- ghcup.cabal | 1 + lib/GHCup/Types.hs | 8 +- lib/GHCup/Utils.hs | 162 ++++++----------------------------------- lib/GHCup/Utils/Tar.hs | 139 +++++++++++++++++++++++++++++++++++ 4 files changed, 170 insertions(+), 140 deletions(-) create mode 100644 lib/GHCup/Utils/Tar.hs diff --git a/ghcup.cabal b/ghcup.cabal index 6cd5332..169c25b 100644 --- a/ghcup.cabal +++ b/ghcup.cabal @@ -135,6 +135,7 @@ library GHCup.Types.Stack GHCup.Utils GHCup.Utils.Dirs + GHCup.Utils.Tar GHCup.Version hs-source-dirs: lib diff --git a/lib/GHCup/Types.hs b/lib/GHCup/Types.hs index 427db19..aac45af 100644 --- a/lib/GHCup/Types.hs +++ b/lib/GHCup/Types.hs @@ -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 diff --git a/lib/GHCup/Utils.hs b/lib/GHCup/Utils.hs index 3f2cb5b..c8b2b22 100644 --- a/lib/GHCup/Utils.hs +++ b/lib/GHCup/Utils.hs @@ -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\/\\/bin\/@ ghcInternalBinDir :: (MonadReader env m, HasDirs env, MonadThrow m, MonadFail m, MonadIO m) => GHCTargetVersion diff --git a/lib/GHCup/Utils/Tar.hs b/lib/GHCup/Utils/Tar.hs new file mode 100644 index 0000000..9d2eab1 --- /dev/null +++ b/lib/GHCup/Utils/Tar.hs @@ -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 +